home *** CD-ROM | disk | FTP | other *** search
/ The Fred Fish Collection 1.5 / ffcollection-1-5-1992-11.iso / ff_progs / prog_c / schem2c1.lzh / Scheme2C / Scheme-src.lzh / scrt / scinit.c < prev    next >
Encoding:
C/C++ Source or Header  |  1991-10-11  |  28.8 KB  |  948 lines
  1. /* SCHEME->C */
  2.  
  3. /*              Copyright 1989 Digital Equipment Corporation
  4.  *                         All Rights Reserved
  5.  *
  6.  * Permission to use, copy, and modify this software and its documentation is
  7.  * hereby granted only under the following terms and conditions.  Both the
  8.  * above copyright notice and this permission notice must appear in all copies
  9.  * of the software, derivative works or modified versions, and any portions
  10.  * thereof, and both notices must appear in supporting documentation.
  11.  *
  12.  * Users of this software agree to the terms and conditions set forth herein,
  13.  * and hereby grant back to Digital a non-exclusive, unrestricted, royalty-free
  14.  * right and license under any changes, enhancements or extensions made to the
  15.  * core functions of the software, including but not limited to those affording
  16.  * compatibility with other hardware or software environments, but excluding
  17.  * applications which incorporate this software.  Users further agree to use
  18.  * their best efforts to return to Digital any such changes, enhancements or
  19.  * extensions that they make and inform Digital of noteworthy uses of this
  20.  * software.  Correspondence should be provided to Digital at:
  21.  * 
  22.  *                       Director of Licensing
  23.  *                       Western Research Laboratory
  24.  *                       Digital Equipment Corporation
  25.  *                       100 Hamilton Avenue
  26.  *                       Palo Alto, California  94301  
  27.  * 
  28.  * This software may be distributed (but not offered for sale or transferred
  29.  * for compensation) to third parties, provided such third parties agree to
  30.  * abide by the terms and conditions of this notice.  
  31.  * 
  32.  * THE SOFTWARE IS PROVIDED "AS IS" AND DIGITAL EQUIPMENT CORP. DISCLAIMS ALL
  33.  * WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING ALL IMPLIED WARRANTIES OF
  34.  * MERCHANTABILITY AND FITNESS.   IN NO EVENT SHALL DIGITAL EQUIPMENT
  35.  * CORPORATION BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL
  36.  * DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR
  37.  * PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS
  38.  * ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS
  39.  * SOFTWARE.
  40. */
  41.  
  42. /* This module defines some basic global objects and initializes those parts
  43.    of the SCHEME->C runtime system which are written in C.  For
  44.    compatibility with other modules, the routines and Scheme globals provided
  45.    by these routines appear as members of the module "sc".
  46. */
  47.  
  48. /* External Definitions */
  49.  
  50. extern  char *sbrk();
  51. extern  char *getenv();
  52.  
  53. extern  errno;            /* C-library Error flag */
  54.  
  55. #ifdef AMIGA
  56. extern _tsize;
  57. #define ETEXT    ((int) _tsize)
  58. #define STACKBASE (FindTask(0)->tc_SPLower)
  59. #else
  60. extern  etext;
  61. #endif
  62.  
  63. #ifdef MIPS
  64. #define ETEXT    ((int)&etext)    /* First address after text */
  65. #include <mips/param.h>
  66. #include <mips/vmparam.h>
  67. #define STACKBASE (int*)USRSTACK
  68. #endif
  69. #ifdef TITAN
  70. #define ETEXT    etext        /* First address after text */
  71. #include <sys/mparam.h>
  72. #define STACKBASE (int*)(MAXUSERADDR+1)
  73. #endif
  74. #ifdef VAX
  75. #define ETEXT    ((int)&etext)    /* First address after text */
  76. #include <vax/param.h>
  77. #include <vax/vmparam.h>
  78. #define STACKBASE (int*)USRSTACK
  79. #endif
  80. #ifdef apollo
  81. #define ETEXT    ((int)&etext)    /* First address after text */
  82. #include <sys/param.h>
  83. /* the stack back moves depending on shared libraries */
  84. #include <apollo/base.h>
  85. #include <apollo/error.h>
  86. #include <apollo/proc2.h>
  87. static proc2_$info_t sc_apollo_proc2;
  88. #define STACKBASE ((int*) sc_apollo_proc2.stack_base)
  89. #endif
  90. #ifdef SPARC
  91. #define ETEXT    ((int)&etext)    /* First address after text */
  92. #include <sun4/vmparam.h>
  93. #define STACKBASE (int*)USRSTACK
  94. #endif
  95. #ifdef SUN3
  96. #define ETEXT    ((int)&etext)    /* First address after text */
  97. #include <sun3/param.h>
  98. #include <sun3/vmparam.h>
  99. #define STACKBASE (int*)USRSTACK
  100. #endif
  101. #ifdef ISC386IX
  102. #define ETEXT    ((int)&etext)    /* First address after text */
  103. #include <sys/types.h>
  104. #include <sys/fcntl.h>        /* probably should be elsewhere */
  105. #include <sys/immu.h>
  106. #define STACKBASE (int*)UVSTACK
  107. #endif
  108.  
  109. #ifdef    AMIGA
  110. #include <fcntl.h>
  111. #include <string.h>
  112. #include <exec/types.h>
  113. #include <exec/tasks.h>
  114. #include <proto/exec.h>
  115. #else
  116. #include <sys/types.h>
  117. #include <sys/file.h>
  118. #include <sys/uio.h>
  119. #include <strings.h>
  120. #endif
  121. #include <varargs.h>
  122.  
  123. /* Definitions for objects within sc */
  124.  
  125. #include "objects.h"
  126. #include "scinit.h"
  127. #include "heap.h"
  128. #include "apply.h"
  129. #include "callcc.h"
  130. #include "signal.h"
  131. #ifdef GGC
  132. #include "GGC.h"
  133. #endif
  134.  
  135. /* Definitions for objects elsewhere in the Scheme system */
  136.  
  137. extern  TSCP  scrt1_reverse();
  138. extern  TSCP  scrt6_error();
  139.  
  140. /* Global data structure for this module. */
  141.  
  142. /* this struct must look like an SCOBJ */
  143. static struct
  144. {
  145.     F2(unsigned  tag:8,
  146.     unsigned  length:24);
  147. } emptyvector, emptystring[2];
  148.  
  149. FILE   *sc_stdin,    /* Standard I/O Subroutine FILE pointers */
  150.        *sc_stdout,
  151.        *sc_stderr;
  152.  
  153. /* Command line arguments and environment variables which control the heap are
  154.    interpreted by the following functions.
  155. */
  156.  
  157. static  char *heapfilename = NULL;    /* Pointer to heap file name */
  158.  
  159. static  int  defaultheap = 4,        /* Default heap size in megabytes */
  160.          minheap = 1,        /* Minimum heap size in megabytes */
  161.          maxheap = 1000,        /* Maximum heap size in megabytes */
  162.          defaultlimit = 33,        /* Default collection limit */
  163.          minlimit = 10,        /* Minimum total collection limit */
  164.          maxlimit = 45,        /* Maximun total collection limit */
  165.          scheap,            /* Heap size in megabytes */
  166.          sclimit;            /* % at which to do total collection */
  167.  
  168. static char*  getargval( argc, argv, cl, env )
  169.     int  argc;
  170.     char  *argv[],
  171.           *cl,    /* Ptr to command line argument name */
  172.           *env;    /* Ptr to environment variable name */
  173. {
  174.     int  i;
  175.  
  176.     for  (i = 1; i < argc-1; i++)  {
  177.        if  (strcmp( argv[ i ], cl ) == 0)  return( argv[ i+1 ] );
  178.     }
  179.     return( getenv( env ) );
  180. }
  181.     
  182. static void  decodearguments( argc, argv )
  183.     int  argc;
  184.     char  *argv[];
  185. {
  186.     char  *val;
  187.     
  188.     val = getargval( argc, argv, "-sch", "SCHEAP" );
  189.     if  (val != NULL)  {
  190.        scheap = atoi( val );
  191.        if  (scheap < minheap)  scheap = minheap;
  192.        if  (scheap > maxheap)  scheap = maxheap;
  193.     }
  194.     else  scheap = defaultheap;
  195.     heapfilename = getargval( argc, argv, "-schf", "SCHEAPFILE" );
  196.     val = getargval( argc, argv, "-scgc", "SCGCINFO" );
  197.     if  (val != NULL)  {
  198.        sc_gcinfo = atoi( val );
  199.        if  (sc_gcinfo < 0  ||  sc_gcinfo > 2)  sc_gcinfo = 0;
  200.     }
  201.     else  sc_gcinfo = 0;
  202.     val = getargval( argc, argv, "-scl", "SCLIMIT" );
  203.     if  (val != NULL)  {
  204.        sclimit = atoi( val );
  205.        if  (sclimit < minlimit)  sclimit = defaultlimit;
  206.        if  (sclimit > maxlimit)  sclimit = defaultlimit;
  207.     }
  208.     else  sclimit = defaultlimit;
  209. }
  210.  
  211. /* The variables holding the values of the functions defined in this module
  212.    are initialized by the following procedure.
  213. */
  214.  
  215. DEFSTRING( t1030, "MY-RUSAGE", 9 );
  216. DEFSTRING( t1032, "COLLECT-RUSAGE", 14 );
  217. DEFSTRING( t1034, "COLLECT", 7 );
  218. DEFSTRING( t1035, "COLLECT-ALL", 11 );
  219. DEFSTRING( t1036, "CONS", 4 );
  220. DEFSTRING( t1038, "MAKE-STRING", 11 );
  221. DEFSTRING( t1040, "STRING-COPY", 11 );
  222. DEFSTRING( t1044, "MAKE-VECTOR", 11 );
  223. DEFSTRING( t1046, "STRING->SYMBOL", 14 );
  224. DEFSTRING( t1048, "STRING->UNINTERNED-SYMBOL", 25 );
  225. DEFSTRING( t1050, "UNINTERNED-SYMBOL?", 18 );
  226. DEFSTRING( t1052, "CALL-WITH-CURRENT-CONTINUATION", 30 );
  227. DEFSTRING( t1056, "SAVE-HEAP", 9 );
  228. DEFSTRING( t1058, "IMPLEMENTATION-INFORMATION", 26 );
  229. DEFSTRING( t1060, "AFTER-COLLECT", 13 );
  230.  
  231. static  init_procs()
  232. {
  233. #ifndef NO_RUSAGE
  234.         INITIALIZEVAR( U_TX( ADR( t1030 ) ), 
  235.                        ADR( sc_my_2drusage_v ), 
  236.                        MAKEPROCEDURE( 0, 
  237.                                       0, sc_my_2drusage, EMPTYLIST ) );
  238.         INITIALIZEVAR( U_TX( ADR( t1032 ) ), 
  239.                        ADR( sc_collect_2drusage_v ), 
  240.                        MAKEPROCEDURE( 0, 
  241.                                       0, 
  242.                                       sc_collect_2drusage, EMPTYLIST ) );
  243. #endif
  244.         INITIALIZEVAR( U_TX( ADR( t1034 ) ), 
  245.                        ADR( sc_collect_v ), 
  246.                        MAKEPROCEDURE( 0, 
  247.                                       0, sc_collect, EMPTYLIST ) );
  248.         INITIALIZEVAR( U_TX( ADR( t1035 ) ), 
  249.                        ADR( sc_collect_2dall_v ), 
  250.                        MAKEPROCEDURE( 0, 
  251.                                       0, sc_collect_2dall, EMPTYLIST ) );
  252.         INITIALIZEVAR( U_TX( ADR( t1036 ) ), 
  253.                        ADR( sc_cons_v ), 
  254.                        MAKEPROCEDURE( 2, 0, sc_cons, EMPTYLIST ) );
  255.         INITIALIZEVAR( U_TX( ADR( t1038 ) ), 
  256.                        ADR( sc_make_2dstring_v ), 
  257.                        MAKEPROCEDURE( 1, 
  258.                                       1, 
  259.                                       sc_make_2dstring, EMPTYLIST ) );
  260.         INITIALIZEVAR( U_TX( ADR( t1040 ) ), 
  261.                        ADR( sc_string_2dcopy_v ), 
  262.                        MAKEPROCEDURE( 1, 
  263.                                       0, 
  264.                                       sc_string_2dcopy, EMPTYLIST ) );
  265.         INITIALIZEVAR( U_TX( ADR( t1044 ) ), 
  266.                        ADR( sc_make_2dvector_v ), 
  267.                        MAKEPROCEDURE( 1, 
  268.                                       1, 
  269.                                       sc_make_2dvector, EMPTYLIST ) );
  270.         INITIALIZEVAR( U_TX( ADR( t1046 ) ), 
  271.                        ADR( sc_string_2d_3esymbol_v ), 
  272.                        MAKEPROCEDURE( 1, 
  273.                                       0, 
  274.                                       sc_string_2d_3esymbol, EMPTYLIST ) );
  275.         INITIALIZEVAR( U_TX( ADR( t1048 ) ), 
  276.                        ADR( sc_d_2dsymbol_ab4b4447_v ), 
  277.                        MAKEPROCEDURE( 1, 
  278.                                       0, 
  279.                                       sc_d_2dsymbol_ab4b4447, 
  280.                                       EMPTYLIST ) );
  281.         INITIALIZEVAR( U_TX( ADR( t1050 ) ), 
  282.                        ADR( sc_uninterned_2dsymbol_3f_v ), 
  283.                        MAKEPROCEDURE( 1, 
  284.                                       0, 
  285.                                       sc_uninterned_2dsymbol_3f, 
  286.                                       EMPTYLIST ) );
  287.         INITIALIZEVAR( U_TX( ADR( t1052 ) ), 
  288.                        ADR( sc_ntinuation_1af38b9f_v ), 
  289.                        MAKEPROCEDURE( 1, 
  290.                                       0, 
  291.                                       sc_ntinuation_1af38b9f, 
  292.                                       EMPTYLIST ) );
  293.         INITIALIZEVAR( U_TX( ADR( t1056 ) ), 
  294.                        ADR( sc_save_2dheap_v ), 
  295.                        MAKEPROCEDURE( 1, 
  296.                                       1, sc_save_2dheap, EMPTYLIST ) );
  297.     INITIALIZEVAR( U_TX( ADR( t1058 ) ),
  298.                ADR( sc_implementation_v ),
  299.                MAKEPROCEDURE( 0,
  300.                       0, sc_implementation, EMPTYLIST ) );
  301.     INITIALIZEVAR( U_TX( ADR( t1060 ) ),
  302.                ADR( sc_after_2dcollect_v ),
  303.                FALSEVALUE );
  304.         MAXDISPLAY( 0 );
  305.         return;
  306. }
  307.  
  308. /* Memory is allocated from the heap by calling the following function
  309.    with a byte count.  It returns a pointer to the space.  Errors will
  310.    cause the program to abort.
  311. */
  312.  
  313. static char  *getmem( bytes )
  314.     int  bytes;
  315. {
  316.     char  *memp;
  317.  
  318.     memp = sbrk( 0 );
  319.     if  ((int)memp & 7)
  320.        sbrk( 8-(int)memp & 7 );
  321.     memp = sbrk( bytes );
  322.     if  ((int)memp == -1)  {
  323.        fprintf( stderr, "***** Memory allocation failed: sbrk( %d )\n",
  324.                bytes );
  325.        exit( 1 );
  326.     }
  327.     return( memp );
  328. }
  329. #ifdef    AMIGA
  330. /*
  331.  * On the Amiga, sbrk() does not return contiguous blocks after each call.
  332.  * So we pre-allocate everything we're going to need, and provide our own sbrk.
  333.  */
  334. static char *amiga_heap ;
  335. static unsigned amiga_heap_size ;
  336.  
  337. static char *sbrk(unsigned size) {
  338.  
  339.     if (size > amiga_heap_size) return NULL ;
  340.     amiga_heap_size -= size ;
  341.     amiga_heap += size ;
  342.     return amiga_heap - size ;
  343.     }
  344. #endif
  345.  
  346. /* The following function is called to initialize the heap from scratch. */
  347.  
  348. static int  module_initialized = 0;
  349.  
  350. sc_newheap()
  351. {
  352.     int  i;
  353.     char  *freebase;
  354.     TSCP  unknown;
  355.  
  356. #ifdef apollo
  357.     /* on an apollo, we get the stack top at run time */
  358.     uid_$t me;
  359.     status_$t status;
  360.     proc2_$who_am_i(&me);
  361.     proc2_$get_info(me, &sc_apollo_proc2, sizeof(sc_apollo_proc2), &status);
  362.     if (status.all != status_$ok && status.all != proc2_$is_current)
  363.     {
  364.         error_$print(status);
  365.         exit(2);
  366.     }
  367. #endif
  368.  
  369.     sc_heappages = scheap*(ONEMB/PAGEBYTES);
  370. #ifdef    AMIGA
  371.     /* Allocate the contiguous chunk of memory that everything else comes from */
  372.     amiga_heap_size = scheap*ONEMB + 16*sc_heappages + 2*PAGEBYTES - 32 ;
  373.     if ( ! ( amiga_heap = (char *) malloc( amiga_heap_size ) ) ) {
  374.            fprintf( stderr, "***** Memory allocation failed: malloc( %d )\n", 
  375.            amiga_heap_size ) ;
  376.        exit( 1 );
  377.     }
  378. #endif
  379.     if  (sc_gcinfo)
  380.        fprintf( stderr, "***** SCGCINFO = %d  SCHEAP = %d  SCLIMIT = %d\n",
  381.                sc_gcinfo, scheap, sclimit );
  382.     sc_limit = sclimit;
  383.     sc_allocatedheappages = 0;
  384.     freebase = getmem( scheap*ONEMB+PAGEBYTES-1 );
  385.     if  ((int)freebase & (PAGEBYTES-1))
  386.        freebase = freebase+(PAGEBYTES-((int)freebase & (PAGEBYTES-1)));
  387.     sc_firstheappage = ADDRESS_PAGE( freebase );
  388.     sc_lastheappage = sc_firstheappage+sc_heappages-1;
  389.     sc_freepage = sc_firstheappage;
  390.     sc_firstheapp = (int*)freebase;
  391.     sc_lastheapp = sc_firstheapp+PAGEWORDS*sc_heappages-1;
  392.     sc_pagegeneration = ((int*)getmem( sc_heappages*4 ))-sc_firstheappage;
  393.     sc_current_generation = 3;
  394.     sc_next_generation = 3;
  395.     sc_genlist = -1;
  396.     sc_pagetype = ((int*)getmem( sc_heappages*4 ))-sc_firstheappage;
  397.     sc_pagelock = ((int*)getmem( sc_heappages*4 ))-sc_firstheappage;
  398.     sc_pagelink = ((int*)getmem( sc_heappages*4 ))-sc_firstheappage;
  399.     for  (i = sc_firstheappage; i <= sc_lastheappage; i++ )  {
  400.        sc_pagegeneration[ i ] = 1;
  401.        sc_pagelock[ i ] = 0;
  402.     }
  403.     sc_initiallink = OKTOSET;
  404.     sc_conscnt = 0;
  405.     sc_extobjwords = 0;
  406.     sc_mutex = 0;
  407.     sc_pendingsignals = 0;
  408.     sc_emptylist = EMPTYLIST;
  409.     emptyvector.tag = VECTORTAG;
  410.     emptystring[0].tag = STRINGTAG;
  411.     sc_emptyvector = U_T( &emptyvector, EXTENDEDTAG );
  412.     sc_emptystring = U_T( emptystring, EXTENDEDTAG );
  413.     sc_falsevalue = FALSEVALUE;
  414.     sc_truevalue = TRUEVALUE;
  415.     sc_eofobject = EOFOBJECT;
  416.     sc_undefined = UNDEFINED;
  417.     sc_stdin = stdin;
  418.     sc_stdout = stdout;
  419.     sc_stderr = stderr;
  420.     sc_constants = NULL;
  421.     sc_globals = NULL;
  422.     sc_stackbase = STACKBASE;
  423.     sc_whenfreed = EMPTYLIST;
  424.     sc_freed = EMPTYLIST;
  425.     sc_clink = EMPTYLIST;
  426.     sc_globals = addtoSCPTRS( sc_globals, &sc_clink );
  427.     sc_stacktrace = NULL;
  428.     sc_obarray = sc_make_2dvector( 1023*4, EMPTYLIST );
  429.     sc_initializevar( sc_cstringtostring( "*OBARRAY*" ),
  430.               &sc_obarray,
  431.               sc_obarray );
  432.     init_procs();
  433.     unknown = sc_makeprocedure( 0, 0, sc_unknowncall, EMPTYLIST );
  434.     TX_U( unknown )->procedure.required = 255;
  435.     for  (i = 0;  i <= 3;  i++)  {
  436.        sc_unknownproc[ i ] = unknown;
  437.        sc_globals = addtoSCPTRS( sc_globals, &sc_unknownproc[ i ] );
  438.     }
  439.     module_initialized = 1;
  440. }
  441.  
  442. /* The routines which follow are responsible for saving the heap to disc
  443.    and reloading it.  Saved heap images have the following header at the
  444.    front of the file.  Following the header is the sc_constants array, the
  445.    sc_globals array, thepagegeneration array, the pagetype array, and all
  446.    valid pages of the heap.
  447. */
  448.  
  449. #ifndef    AMIGA
  450. static struct  {
  451.     char  id[4];        /* S->C */
  452.     TSCP  procedure;    /* Restart procedure */
  453.     TSCP  correct;        /* List of values for constants & globals */
  454.     int  etext;
  455.     int  locklist;            /* From heap.h */
  456.     int  lockcnt;
  457.     int  current_generation;
  458.     int  next_generation;
  459.     int  limit;
  460.     int  heappages;
  461.     int  firstheappage;
  462.     int  freepage;
  463.     int  allocatedheappages;
  464.     int  *firstheapp;
  465.     int  conscnt;
  466.     SCP  consp;
  467.     int  extobjwords;
  468.     int  extwaste;
  469.     SCP  extobjp;
  470.     int  *sc_stackbase;
  471.     TSCP  sc_whenfreed;
  472.     int  sc_constants_limit;    /* From objects.h */
  473.     int  sc_globals_limit;
  474.     int  sc_maxdisplay;
  475.        }  save;
  476.  
  477. /* I/O is done directly with system calls so as to not allocate any data
  478.    from the heap when the heap must be restored.
  479. */
  480.  
  481. static  int  heapfile;        /* File descriptor for the heap file */
  482.  
  483. static void  heapin( address, count )
  484.     char  *address;
  485.     int  count;
  486. {
  487.     if  (read( heapfile, address, count ) != count)  {
  488.        fprintf( stderr, "***** SAVE-HEAP HEAP FILE read error: %d\n",
  489.                errno );
  490.        exit( 1 );
  491.     }
  492. }
  493.  
  494. static void  heapout( address, count )
  495.     char  *address;
  496.     int  count;
  497. {
  498.     int  error;
  499.  
  500.     if  (write( heapfile, address, count ) != count)  {
  501.        error = errno;
  502.        close( heapfile );
  503.        sc_error( "SAVE-HEAP", "HEAP FILE fwrite error: ~s", 1,
  504.                      C_FIXED( error ) );
  505.     }
  506. }
  507. #endif    AMIGA
  508.  
  509. /* A Scheme program may call (SAVE-HEAP filename . procedure) to save the
  510.    heap in a file named "filename".  When the heap is reloaded into a
  511.    newly created process, execution will start at the procedure "procedure"
  512.    which will be called with the command line argument list.  If procedure is
  513.    not supplied, then the normal start up procedure will be used.
  514. */
  515.  
  516. TSCP  sc_save_2dheap_v;
  517.  
  518. TSCP  sc_save_2dheap( filename, argl )
  519.     TSCP  filename, argl;
  520. {
  521.     int  i, firstpage, pagecount;
  522.     TSCP  correct, cl, symbol, procedure;
  523.  
  524. #ifdef    AMIGA
  525.     sc_error( "SAVE-HEAP", "Heap save/restore not supported on the Amiga", 0 );
  526. #else
  527.     procedure = FALSEVALUE;
  528.     if  (argl != EMPTYLIST)  {
  529.        procedure = PAIR_CAR( argl );
  530.        if  (TSCPTAG( procedure ) != EXTENDEDTAG  ||
  531.           T_U( procedure )->procedure.tag != PROCEDURETAG)
  532.           sc_error( "SAVE-HEAP",
  533.                   "Restart procedure is not a PROCEDURE: ~s",
  534.                    1, procedure );
  535.        if  (PROCEDURE_REQUIRED( procedure ) > 1  ||
  536.             (PROCEDURE_REQUIRED( procedure ) == 0  &&
  537.          PROCEDURE_OPTIONAL( procedure ) == 0))
  538.           sc_error( "SAVE-HEAP",
  539.                   "Restart procedure must take 1 argument", 0 );
  540.        if  (PAIR_CDR( argl ) != EMPTYLIST)  {
  541.           sc_error( "SAVE-HEAP", "Too many arguments", 0 );
  542.        }
  543.     }
  544.     if  (TSCPTAG( filename ) != EXTENDEDTAG  ||
  545.          T_U( filename )->string.tag != STRINGTAG)
  546.        sc_error( "SAVE-HEAP", "File name is not a STRING: ~s", 1,
  547.                 filename );
  548.     heapfile = open( &(T_U( filename )->string.char0),
  549.              (O_WRONLY | O_CREAT | O_TRUNC), 0750 );
  550.     if  (heapfile == -1)
  551.        sc_error( "SAVE-HEAP", "Can't open HEAP FILE: ~s", 1,
  552.                  C_FIXED( errno ) );
  553.     sc_collect_2dall();
  554.     /* Build the save-heap file header */
  555.     correct = EMPTYLIST;
  556.     for  (i = 0; i < sc_constants->count; i++)
  557.        correct = sc_cons( *(sc_constants->ptrs[ i ]), correct );
  558.         for  (i = 0; i < sc_globals->count; i++)
  559.        correct = sc_cons( *(sc_globals->ptrs[ i ]), correct );
  560.     strncpy( save.id, "S->C", 4 );
  561.     save.procedure = procedure;
  562.     save.correct = correct;
  563.     save.etext = ETEXT;
  564.     save.locklist = sc_locklist;
  565.     save.lockcnt = sc_lockcnt;
  566.     save.current_generation = sc_current_generation;
  567.     save.next_generation = sc_next_generation;
  568.     save.limit = sc_limit;
  569.     save.heappages = sc_heappages;
  570.     save.firstheappage = sc_firstheappage;
  571.     save.freepage = sc_freepage;
  572.     save.allocatedheappages = sc_allocatedheappages;
  573.     save.firstheapp = sc_firstheapp;
  574.     save.conscnt = sc_conscnt;
  575.     save.consp = sc_consp;
  576.     save.extobjwords = sc_extobjwords;
  577.     save.extwaste = sc_extwaste;
  578.     save.extobjp = sc_extobjp;
  579.     save.sc_stackbase = sc_stackbase;
  580.     save.sc_whenfreed = sc_whenfreed;
  581.     save.sc_constants_limit = sc_constants->limit;
  582.     save.sc_globals_limit = sc_globals->limit;
  583.     save.sc_maxdisplay = sc_maxdisplay;
  584.     heapout( &save, sizeof( save ) );
  585.     heapout( sc_constants, sizeofSCPTRS( sc_constants->limit ) );
  586.     heapout( sc_globals, sizeofSCPTRS( sc_globals->limit ) );
  587.     heapout( &sc_pagegeneration[ sc_firstheappage ], sc_heappages*4 );
  588.     heapout( &sc_pagetype[ sc_firstheappage ], sc_heappages*4 );
  589.     pagecount = 0;
  590.     for  (i = sc_firstheappage; i <= sc_lastheappage; i++)  {
  591.        if  (sc_pagegeneration[ i ] == sc_current_generation  ||
  592.         ~sc_pagegeneration[ i ] & 1)  {
  593.           if  (pagecount++ == 0)  firstpage = i;
  594.        }
  595.        else  if  (pagecount)  {
  596.           heapout( PAGE_ADDRESS( firstpage ), pagecount*PAGEBYTES );
  597.           pagecount = 0;
  598.        }
  599.     }
  600.     if  (pagecount)
  601.        heapout( PAGE_ADDRESS( firstpage ), pagecount*PAGEBYTES );
  602.     close( heapfile );
  603.     return( TRUEVALUE );
  604. #endif    AMIGA
  605. }
  606.  
  607. /* The following routine is called from a Scheme main program to determine
  608.    how the heap is to be constructed.  If the heap is being constructed from
  609.    a saved file, then this function will not return.  If there is no saved
  610.    heap, then sc__init will be called to initialize the heap.
  611. */
  612.  
  613. void  sc_restoreheap( desiredheap, argc, argv, mainproc )
  614.     int  desiredheap;
  615.     int  argc;
  616.     char  *argv[];
  617.     void  (*mainproc)();
  618. {
  619.     int  i,
  620.          pagecount,
  621.          firstpage;
  622.     char  *freebase;
  623.     TSCP  cl,
  624.           *address,
  625.           address_value;
  626.  
  627.     if  (module_initialized)  return;
  628.     if  (desiredheap)  {
  629.        defaultheap = desiredheap;
  630.        minheap = desiredheap;
  631.     }
  632.     decodearguments( argc, argv );
  633. #ifdef GGC
  634.         GGCcreateMemoryBoard();
  635. #endif
  636. #ifdef    AMIGA
  637.     /* We turn off buffering on stderr so we get reports when we want them */
  638.     setnbf(stderr) ;
  639.     setvbuf(stdout, NULL, _IOLBF, BUFSIZ) ;
  640. #endif
  641.     if  (heapfilename == NULL)  {
  642.        sc_newheap();
  643.        return;
  644.     }
  645. #ifdef    AMIGA
  646.     fprintf( stderr, "***** Heap save/restore not supported on the Amiga\n" );
  647. #else
  648.     /* Saved heap exists, open it and validate the header */
  649.     heapfile = open( heapfilename, O_RDONLY );
  650.     if  (heapfile == -1)  {
  651.        fprintf( stderr, "***** Can't open heap file: %d\n", errno );
  652.        exit( 1 );
  653.     }
  654.     heapin( &save, sizeof( save ) );
  655.     if  (strncmp( save.id, "S->C", 4)  ||  save.etext != ETEXT)  {
  656.        fprintf( stderr, "***** Incompatible heap file image\n" );
  657.        exit( 1 );
  658.     }
  659.     /* Initialize similar to sc__init */
  660.     if  (scheap < save.heappages/(ONEMB/PAGEBYTES))
  661.        scheap = save.heappages/(ONEMB/PAGEBYTES);
  662.     if  (sclimit < save.limit)  sclimit = save.limit;
  663. #ifdef sun
  664.     /* in SunOS, stderr is line buffered, which causes some unwanted */
  665.     /* malloc..  */
  666.     if (sc_gcinfo)
  667.         setbuf(stderr, (char*)0);
  668. #endif
  669.     if  (sc_gcinfo)
  670.        fprintf( stderr, "***** SCGCINFO = %d  SCHEAP = %d  SCLIMIT = %d\n",
  671.             sc_gcinfo, scheap, sclimit );
  672.     sc_limit = sclimit;
  673.     sc_heappages = scheap*(ONEMB/PAGEBYTES);
  674. #ifdef    AMIGA
  675.     /* Allocate the contiguous chunk of memory that everything else comes from */
  676.     amiga_heap_size = scheap*ONEMB + 16*sc_heappages + 2*PAGEBYTES - 32 ;
  677.     if ( ! ( amiga_heap = (char *) malloc( amiga_heap_size ) ) ) {
  678.            fprintf( stderr, "***** Memory allocation failed: malloc( %d )\n", 
  679.            amiga_heap_size ) ;
  680.        exit( 1 );
  681.     }
  682. #endif
  683.     sc_allocatedheappages = save.allocatedheappages;
  684.     freebase = getmem( scheap*ONEMB+PAGEBYTES-1 );
  685.     if  ((int)freebase & (PAGEBYTES-1))
  686.        freebase = freebase+(PAGEBYTES-((int)freebase & (PAGEBYTES-1)));
  687.     sc_firstheappage = ADDRESS_PAGE( freebase );
  688.     sc_lastheappage = sc_firstheappage+sc_heappages-1;
  689.     sc_firstheapp = (int*)freebase;
  690.     sc_lastheapp = sc_firstheapp+PAGEWORDS*sc_heappages-1;
  691.     sc_freepage = save.freepage;
  692.     sc_pagegeneration = ((int*)getmem( sc_heappages*4 ))-sc_firstheappage;
  693.     sc_current_generation = save.current_generation;
  694.     sc_next_generation = save.next_generation;
  695.     sc_constants =
  696.          (struct SCPTRS*)malloc( sizeofSCPTRS( save.sc_constants_limit ) );
  697.     heapin( sc_constants, sizeofSCPTRS( save.sc_constants_limit ) );
  698.     sc_globals =
  699.          (struct SCPTRS*)malloc( sizeofSCPTRS( save.sc_globals_limit ) );
  700.     heapin( sc_globals, sizeofSCPTRS( save.sc_globals_limit ) );
  701.     heapin( &sc_pagegeneration[ sc_firstheappage ], save.heappages*4 );
  702.     for  (i = save.firstheappage+save.heappages; i <= sc_lastheappage;
  703.           i++ )
  704.        sc_pagegeneration[ i ] = 1;
  705.     sc_pagetype = ((int*)getmem( sc_heappages*4 ))-sc_firstheappage;
  706.     heapin( &sc_pagetype[ sc_firstheappage ], save.heappages*4 );
  707.     sc_pagelock = ((int*)getmem( sc_heappages*4 ))-sc_firstheappage;
  708.     sc_genlist = -1;
  709.     sc_pagelink = ((int*)getmem( sc_heappages*4 ))-sc_firstheappage;
  710.     for  (i = sc_firstheappage; i <= sc_lastheappage; i++)  {
  711.        sc_pagelink[ i ] = 0;
  712.        sc_pagelock[ i ] = 0;
  713.     }
  714.     sc_initiallink = OKTOSET;
  715.     sc_conscnt = save.conscnt;
  716.     sc_consp = save.consp;
  717.     sc_extobjwords = save.extobjwords;
  718.     sc_extobjp = save.extobjp;
  719.     sc_extwaste = save.extwaste;
  720.     sc_mutex = 0;
  721.     sc_pendingsignals = 0;
  722.     sc_emptylist = EMPTYLIST;
  723.     emptyvector.tag = VECTORTAG;
  724.     emptystring[0].tag = STRINGTAG;
  725.     sc_emptyvector = U_T( &emptyvector, EXTENDEDTAG );
  726.     sc_emptystring = U_T( emptystring, EXTENDEDTAG );
  727.     sc_falsevalue = FALSEVALUE;
  728.     sc_truevalue = TRUEVALUE;
  729.     sc_eofobject = EOFOBJECT;
  730.     sc_undefined = UNDEFINED;
  731.     sc_stdin = stdin;
  732.     sc_stdout = stdout;
  733.     sc_stderr = stderr;
  734.     sc_maxdisplay = save.sc_maxdisplay;
  735.     sc_stackbase = save.sc_stackbase;
  736.     sc_whenfreed = save.sc_whenfreed;
  737.     sc_freed = EMPTYLIST;
  738.     sc_stacktrace = NULL;
  739.     /* Reload the heap and correct globals which point into it */
  740.     pagecount = 0;
  741.     for  (i = sc_firstheappage; i < sc_firstheappage+save.heappages;
  742.           i++)  {
  743.        if  (sc_pagegeneration[ i ] == sc_current_generation  ||
  744.         ~sc_pagegeneration[ i ] & 1)  {
  745.           if  (pagecount++ == 0)  firstpage = i;
  746.        }
  747.        else  if  (pagecount)  {
  748.           heapin( PAGE_ADDRESS( firstpage ), pagecount*PAGEBYTES );
  749.           pagecount = 0;
  750.        }
  751.     }
  752.     if  (pagecount)
  753.        heapin( PAGE_ADDRESS( firstpage ), pagecount*PAGEBYTES );
  754.     cl = save.correct;
  755.         for  (i = sc_globals->count-1; i >= 0 ; i--)  {
  756.        *(sc_globals->ptrs[ i ]) = PAIR_CAR( cl );
  757.        cl = PAIR_CDR( cl );
  758.     }
  759.     for  (i = sc_constants->count-1; i >= 0; i--)  {
  760.        *(sc_constants->ptrs[ i ]) = PAIR_CAR( cl );
  761.        cl = PAIR_CDR( cl );
  762.     }
  763.     sc_clink = EMPTYLIST;
  764.     close( heapfile );
  765. #ifdef GGC
  766.     for  (i = sc_firstheappage;  i <= sc_lastheappage;  i++)  {
  767.        if  (sc_pagegeneration[ i ] == sc_current_generation)
  768.           switch  (sc_pagetype[ i ])  {
  769.              case  PAIRTAG:
  770.             GGCmarkPair( i );
  771.             break;
  772.              case  EXTENDEDTAG:
  773.             GGCmarkExtended( i );
  774.             break;
  775.              case  BIGEXTENDEDTAG:
  776.             GGCmarkContinuations( i, 1 );
  777.             break;
  778.           }
  779.     }
  780. #endif
  781.     module_initialized = 1;
  782.     /* Start execution at the appropriate procedure */
  783.     if  (save.procedure != FALSEVALUE)
  784.        sc_apply_2dtwo( save.procedure,
  785.                      sc_cons( sc_clarguments( argc, argv ), EMPTYLIST ) );
  786.     else  if  (mainproc != NULL)  
  787.        (*mainproc)( sc_clarguments( argc, argv ) );
  788.     else
  789.        return;
  790. #endif    AMIGA
  791.     SCHEMEEXIT();
  792. }
  793.  
  794. /* This initialization function is provided to allow automatic initialization
  795.    from a Modula-2 program.
  796. */
  797.  
  798. sc__init()
  799. {
  800.     sc_restoreheap( 0, 0, NULL, NULL );
  801. }
  802.  
  803. /* Routines coded in C call the following function to access the Scheme ERROR
  804.    function.  SYMBOL is a string representing the function name.  FORMAT is a
  805.    string which is a format descriptor.  ARGC is the argument count which is
  806.    followed by the arguments.
  807. */
  808.  
  809. sc_error( va_alist )
  810.     va_dcl
  811. {
  812.     char  *symbol, *format;
  813.     int  argc;
  814.     TSCP  argl;
  815.     va_list  argp;
  816.  
  817.     va_start( argp );
  818.     symbol = va_arg( argp, char* );
  819.     format = va_arg( argp, char* );
  820.     argc = va_arg( argp, int );
  821.     argl = sc_emptylist;
  822.     while  (argc--)  argl = sc_cons( va_arg( argp, TSCP ), argl );
  823.     scrt6_error( sc_string_2d_3esymbol( sc_cstringtostring( symbol ) ),
  824.              sc_cstringtostring( format ),
  825.              scrt1_reverse( argl ) );
  826.     va_end( argp );
  827. }
  828.  
  829. /* The following function returns informations about the implementation.  The
  830.    form of the function follows a recent proposal on rrrs-authors.  The result
  831.    is a list of strings or #F's of the form:
  832.  
  833.       (<name> <version> <MACHINE> <CPU> <OS> <FS> . <supports>)
  834. */
  835.  
  836. TSCP  sc_implementation_v;
  837.  
  838. TSCP  sc_implementation()
  839. {
  840.     return(
  841.        sc_cons(
  842.           sc_cstringtostring( "Scheme->C" ),
  843.           sc_cons(
  844.              sc_cstringtostring( "28sep90jfb" ),
  845.              sc_cons(
  846. #ifdef MIPS
  847.             sc_cstringtostring( "DECstation3100" ),
  848. #endif
  849. #ifdef TITAN
  850.             sc_cstringtostring( "WRL-TITAN" ),
  851. #endif
  852. #ifdef VAX
  853.             sc_cstringtostring( "VAX" ),
  854. #endif
  855. #ifdef apollo
  856.             sc_cstringtostring( "Apollo" ),
  857. #endif
  858. #ifdef SPARC
  859.             sc_cstringtostring( "Sun4/SPARC" ),
  860. #endif
  861. #ifdef SUN3
  862.             sc_cstringtostring( "Sun3" ),
  863. #endif
  864. #ifdef    AMIGA
  865.             sc_cstringtostring( "Amiga" ),
  866. #endif
  867. #ifdef I386
  868.             sc_cstringtostring( "AT/386" ),
  869. #endif
  870.  
  871.             sc_cons(
  872. #ifdef MIPS
  873.                sc_cstringtostring( "R2000" ),
  874. #endif
  875. #ifdef TITAN
  876.                sc_cstringtostring( "BYTE-ADDRESSED" ),
  877. #endif
  878. #ifdef VAX
  879.                sc_cstringtostring( "VAX" ),
  880. #endif
  881. #ifdef APOLLO
  882.                sc_cstringtostring( "68K" ),
  883. #endif
  884. #ifdef PRISM
  885.                sc_cstringtostring( "PRISM" ),
  886. #endif
  887. #ifdef SPARC
  888.                sc_cstringtostring( "SPARC" ),
  889. #endif
  890. #ifdef SUN3
  891.                sc_cstringtostring( "68K" ),
  892. #endif
  893. #ifdef AMIGA
  894. #ifdef    MC68030        /* A kludge... */
  895.                sc_cstringtostring( "MC68030/68881" ),
  896. #else
  897. #ifdef    MC68020
  898.                sc_cstringtostring( "MC68020/68881" ),
  899. #else
  900. #ifdef    MC68010
  901.                sc_cstringtostring( "MC68010" ),
  902. #else
  903.                sc_cstringtostring( "MC68000" ),
  904. #endif /* MC68010 */
  905. #endif /* MC68020 */
  906. #endif /* MC68030 */
  907. #endif /* AMIGA */
  908. #ifdef I386
  909.                sc_cstringtostring( "Intel 386" ),
  910. #endif
  911.                sc_cons(
  912. #ifdef apollo
  913.                   sc_cstringtostring( "Domain/OS" ),
  914. #else /* ! apollo */
  915. #ifdef SPARC
  916. #ifdef sun
  917.               sc_cstringtostring( "SunOS" ),
  918. #else
  919.               sc_cstringtostring( "SparcOS" ),
  920. #endif /* sun */
  921. #else /* ! SPARC */
  922. #ifdef SUN3
  923.               sc_cstringtostring( "SunOS" ),
  924. #else
  925. #ifdef SYSV
  926.               sc_cstringtostring( "System V.3.2" ),
  927. #else
  928. #ifdef    AMIGA
  929.                   sc_cstringtostring( "AmigaDOS" ),
  930. #else
  931.                   sc_cstringtostring( "ULTRIX" ),
  932. #endif /* AMIGA */
  933. #endif /* SYSV */
  934. #endif /* SUN3 */
  935. #endif /* SPARC */
  936. #endif /* apollo */
  937.                   sc_cons(
  938.                   FALSEVALUE,
  939.                   EMPTYLIST
  940.                      )
  941.                   )
  942.                )
  943.                 )
  944.              )
  945.               )
  946.           );
  947. }
  948.