home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / hugs101.zip / hugs101sc.zip / hugsdist / src / storage.c < prev    next >
C/C++ Source or Header  |  1995-03-02  |  39KB  |  1,425 lines
  1. /* --------------------------------------------------------------------------
  2.  * storage.c:   Copyright (c) Mark P Jones 1991-1994.   All rights reserved.
  3.  *              See NOTICE for details and conditions of use etc...
  4.  *              Hugs version 1.0 August 1994, derived from Gofer 2.30a
  5.  *
  6.  * Primitives for manipulating global data structures
  7.  * ------------------------------------------------------------------------*/
  8.  
  9. #include "prelude.h"
  10. #include "storage.h"
  11. #include "connect.h"
  12. #include "errors.h"
  13. #include <setjmp.h>
  14.  
  15. static List local insertName        Args((Name,List));
  16. static Void local patternError        Args((String));
  17. static Bool local stringMatch        Args((String,String));
  18.  
  19. static Int  local hash            Args((String));
  20. static Int  local saveText        Args((Text));
  21. static Cell local markCell        Args((Cell));
  22. static Void local markSnd        Args((Cell));
  23. static Cell local indirectChain        Args((Cell));
  24. static Cell local lowLevelLastIn    Args((Cell));
  25. static Cell local lowLevelLastOut    Args((Cell));
  26. static Void local closeFile        Args((Int));
  27.  
  28. /* --------------------------------------------------------------------------
  29.  * Text storage:
  30.  *
  31.  * provides storage for the characters making up identifier and symbol
  32.  * names, string literals, character constants etc...
  33.  *
  34.  * All character strings are stored in a large character array, with textHw
  35.  * pointing to the next free position.    Lookup in the array is improved using
  36.  * a hash table.  Internally, text strings are represented by integer offsets
  37.  * from the beginning of the array to the string in question.
  38.  *
  39.  * Where memory permits, the use of multiple hashtables gives a significant
  40.  * increase in performance, particularly when large source files are used.
  41.  *
  42.  * Each string in the array is terminated by a zero byte.  No string is
  43.  * stored more than once, so that it is safe to test equality of strings by
  44.  * comparing the corresponding offsets.
  45.  *
  46.  * Special text values (beyond the range of the text array table) are used
  47.  * to generate unique `new variable names' as required.
  48.  *
  49.  * The same text storage is also used to hold text values stored in a saved
  50.  * expression.  This grows downwards from the top of the text table (and is
  51.  * not included in the hash table).
  52.  * ------------------------------------------------------------------------*/
  53.  
  54. #define TEXTHSZ 512            /* Size of Text hash table       */
  55. #define NOTEXT    ((Text)(~0))        /* Empty bucket in Text hash table */
  56. static    Text    textHw;            /* Next unused position           */
  57. static  Text    savedText = NUM_TEXT;    /* Start of saved portion of text  */
  58. static    Text    nextNewText;        /* Next new text value           */
  59. static  Text    nextNewDText;        /* Next new dict text value       */
  60. static    char    text[NUM_TEXT];        /* Storage of character strings       */
  61. static    Text    textHash[TEXTHSZ][NUM_TEXTH]; /* Hash table storage       */
  62.  
  63. String textToStr(t)               /* find string corresp to given Text*/
  64. Text t; {
  65.     static char newVar[16];
  66.  
  67.     if (0<=t && t<NUM_TEXT)            /* standard char string       */
  68.     return text + t;
  69.     if (t<0)
  70.     sprintf(newVar,"d%d",-t);        /* dictionary variable       */
  71.     else
  72.     sprintf(newVar,"v%d",t-NUM_TEXT);    /* normal variable       */
  73.     return newVar;
  74. }
  75.  
  76. Text inventText() {            /* return new unused variable name */
  77.     return nextNewText++;
  78. }
  79.  
  80. Text inventDictText() {            /* return new unused dictvar name  */
  81.     return nextNewDText--;
  82. }
  83.  
  84. static Int local hash(s)        /* Simple hash function on strings */
  85. String s; {
  86.     int v, j = 3;
  87.  
  88.     for (v=((int)(*s))*8; *s; s++)
  89.     v += ((int)(*s))*(j++);
  90.     if (v<0)
  91.     v = (-v);
  92.     return(v%TEXTHSZ);
  93. }
  94.  
  95. Text findText(s)               /* Locate string in Text array       */
  96. String s; {
  97.     int    h       = hash(s);
  98.     int    hashno  = 0;
  99.     Text   textPos = textHash[h][hashno];
  100.  
  101. #define TryMatch    {   Text   originalTextPos = textPos;           \
  102.                 String t;                       \
  103.                 for (t=s; *t==text[textPos]; textPos++,t++)       \
  104.                 if (*t=='\0')                   \
  105.                     return originalTextPos;           \
  106.             }
  107. #define Skip        while (text[textPos++]) ;
  108.  
  109.     while (textPos!=NOTEXT) {
  110.     TryMatch
  111.     if (++hashno<NUM_TEXTH)        /* look in next hashtable entry       */
  112.         textPos = textHash[h][hashno];
  113.     else {
  114.         Skip
  115.         while (textPos < textHw) {
  116.         TryMatch
  117.         Skip
  118.         }
  119.         break;
  120.     }
  121.     }
  122.  
  123. #undef TryMatch
  124. #undef Skip
  125.  
  126.     textPos = textHw;               /* if not found, save in array       */
  127.     if (textHw + strlen(s) + 1 > savedText) {
  128.     ERROR(0) "Character string storage space exhausted"
  129.     EEND;
  130.     }
  131.     while (text[textHw++] = *s++)
  132.     ;
  133.     if (hashno<NUM_TEXTH) {           /* updating hash table as necessary */
  134.     textHash[h][hashno] = textPos;
  135.     if (hashno<NUM_TEXTH-1)
  136.         textHash[h][hashno+1] = NOTEXT;
  137.     }
  138.  
  139.     return textPos;
  140. }
  141.  
  142. static Int local saveText(t)        /* Save text value in buffer       */
  143. Text t; {                /* at top of text table           */
  144.     String s = textToStr(t);
  145.     Int    l = strlen(s);
  146.  
  147.     if (textHw + strlen(s) + 1 > savedText) {
  148.     ERROR(0) "Character string storage space exhausted"
  149.     EEND;
  150.     }
  151.     savedText -= l+1;
  152.     strcpy(text+savedText,s);
  153.     return savedText;
  154. }
  155.  
  156. /* --------------------------------------------------------------------------
  157.  * Syntax storage:
  158.  *
  159.  * Operator declarations are stored in a table which associates Text values
  160.  * with Syntax values.
  161.  * ------------------------------------------------------------------------*/
  162.  
  163. static Int syntaxHw;               /* next unused syntax table entry   */
  164. static struct {                /* table of Text <-> Syntax values  */
  165.     Text   text;
  166.     Syntax syntax;
  167. } tabSyntax[NUM_SYNTAX];
  168.  
  169. Syntax syntaxOf(t)               /* look up syntax of operator symbol*/
  170. Text t; {
  171.     int i;
  172.  
  173.     for (i=0; i<syntaxHw; ++i)
  174.     if (tabSyntax[i].text==t)
  175.         return tabSyntax[i].syntax;
  176.     return defaultSyntax(t);
  177. }
  178.  
  179. Void addSyntax(line,t,sy)           /* add (t,sy) to syntax table       */
  180. Int    line;
  181. Text   t;
  182. Syntax sy; {
  183.     int i;
  184.  
  185.     for (i=0; i<syntaxHw; ++i)
  186.     if (tabSyntax[i].text==t) {
  187.         ERROR(line) "Attempt to redefine syntax of operator \"%s\"",
  188.             textToStr(t)
  189.         EEND;
  190.     }
  191.  
  192.     if (syntaxHw>=NUM_SYNTAX) {
  193.     ERROR(line) "Too many fixity declarations"
  194.     EEND;
  195.     }
  196.  
  197.     tabSyntax[syntaxHw].text   = t;
  198.     tabSyntax[syntaxHw].syntax = sy;
  199.     syntaxHw++;
  200. }
  201.  
  202. /* --------------------------------------------------------------------------
  203.  * Addr storage: records `next unused program location'
  204.  * ------------------------------------------------------------------------*/
  205.  
  206. static Addr addrHw;               /* next unused program location       */
  207.  
  208. Addr getMem(n)                   /* Get some more memory           */
  209. Int n; {
  210.     Addr newAddr = addrHw;
  211.     addrHw += n;
  212.     if (addrHw>=NUM_ADDRS) {
  213.     ERROR(0) "Program code storage space exhausted"
  214.     EEND;
  215.     }
  216.     return newAddr;
  217. }
  218.  
  219. /* --------------------------------------------------------------------------
  220.  * Tycon storage:
  221.  *
  222.  * A Tycon represents a user defined type constructor.    Tycons are indexed
  223.  * by Text values ... a very simple hash function is used to improve lookup
  224.  * times.  Tycon entries with the same hash code are chained together, with
  225.  * the most recent entry at the front of the list.
  226.  * ------------------------------------------------------------------------*/
  227.  
  228. #define TYCONHSZ 256            /* Size of Tycon hash table       */
  229. #define tHash(x) ((x)%TYCONHSZ)        /* Tycon hash function           */
  230. static    Tycon     tyconHw;        /* next unused Tycon           */
  231. static    Tycon     tyconHash[TYCONHSZ];    /* Hash table storage           */
  232.  
  233. struct    Tycon     tabTycon[NUM_TYCON];    /* Tycon storage            */
  234.  
  235. Tycon newTycon(t)            /* add new tycon to tycon table       */
  236. Text t; {
  237.     Int h = tHash(t);
  238.  
  239.     if (tyconHw-TYCMIN >= NUM_TYCON) {
  240.     ERROR(0) "Type constructor storage space exhausted"
  241.     EEND;
  242.     }
  243.     tycon(tyconHw).text      = t;    /* clear new tycon record       */
  244.     tycon(tyconHw).kind         = NIL;
  245.     tycon(tyconHw).defn      = NIL;
  246.     tycon(tyconHw).what         = NIL;
  247.     tycon(tyconHw).nextTyconHash = tyconHash[h];
  248.     tyconHash[h]         = tyconHw;
  249.  
  250.     return tyconHw++;
  251. }
  252.  
  253. Tycon findTycon(t)            /* locate Tycon in tycon table       */
  254. Text t; {
  255.     Tycon tc = tyconHash[tHash(t)];
  256.  
  257.     while (nonNull(tc) && tycon(tc).text!=t)
  258.     tc = tycon(tc).nextTyconHash;
  259.     return tc;
  260. }
  261.  
  262. Tycon addPrimTycon(s,kind,ar,what,defn) /* add new primitive type constr   */
  263. String s;
  264. Kind   kind;
  265. Int    ar;
  266. Cell   what;
  267. Cell   defn; {
  268.     Tycon tc        = newTycon(findText(s));
  269.     tycon(tc).line  = 0;
  270.     tycon(tc).kind  = kind;
  271.     tycon(tc).what  = what;
  272.     tycon(tc).defn  = defn;
  273.     tycon(tc).arity = ar;
  274.     return tc;
  275. }
  276.  
  277. /* --------------------------------------------------------------------------
  278.  * Name storage:
  279.  *
  280.  * A Name represents a top level binding of a value to an identifier.
  281.  * Such values may be any one of the following:
  282.  *    CFUN   constructor function
  283.  *    MFUN   member function in class
  284.  *    NIL    user defined (or machine generated) compiled function
  285.  *
  286.  * Names are indexed by Text values ... a very simple hash functions speeds
  287.  * access to the table of Names and Name entries with the same hash value
  288.  * are chained together, with the most recent entry at the front of the
  289.  * list.
  290.  * ------------------------------------------------------------------------*/
  291.  
  292. #define NAMEHSZ  256            /* Size of Name hash table       */
  293. #define nHash(x) ((x)%NAMEHSZ)        /* Name hash function :: Text->Int */
  294. static    Name     nameHw;        /* next unused name           */
  295. static    Name     nameHash[NAMEHSZ];    /* Hash table storage           */
  296.  
  297. struct    Name     tabName[NUM_NAME];    /* Name table storage           */
  298.  
  299. Name newName(t)                /* add new name to name table       */
  300. Text t; {
  301.     Int h = nHash(t);
  302.  
  303.     if (nameHw-NAMEMIN >= NUM_NAME) {
  304.     ERROR(0) "Name storage space exhausted"
  305.     EEND;
  306.     }
  307.     name(nameHw).text          = t;    /* clear new name record        */
  308.     name(nameHw).line          = 0;
  309.     name(nameHw).arity          = 0;
  310.     name(nameHw).number       = 0;
  311.     name(nameHw).defn          = NIL;
  312.     name(nameHw).type          = NIL;
  313.     name(nameHw).primDef      = 0;
  314.     name(nameHw).code          = 0;
  315.     name(nameHw).nextNameHash = nameHash[h];
  316.     nameHash[h]           = nameHw;
  317.  
  318.     return nameHw++;
  319. }
  320.  
  321. Name findName(t)            /* locate name in name table       */
  322. Text t; {
  323.     Name n = nameHash[nHash(t)];
  324.  
  325.     while (nonNull(n) && name(n).text!=t)
  326.     n = name(n).nextNameHash;
  327.     return n;
  328. }
  329.  
  330. Void addPrim(l,n,s,ty)            /* add primitive function value    */
  331. Int    l;
  332. Name   n;
  333. String s;
  334. Type   ty; {
  335.     Int  i;
  336.  
  337.     name(n).line = l;
  338.     name(n).defn = NIL;
  339.     name(n).type = ty;
  340.  
  341.     for (i=0; primitives[i].ref; ++i)
  342.         if (strcmp(s,primitives[i].ref)==0) {
  343.         name(n).arity   = primitives[i].arity;
  344.         name(n).number  = i;
  345.         name(n).primDef = primitives[i].imp;
  346.         return;
  347.     }
  348.     externalPrim(n,s);
  349. }
  350.  
  351. Name addPrimCfun(s,arity,no,type)    /* add primitive constructor func. */
  352. String s;
  353. Int    arity;
  354. Int    no;
  355. Cell   type; {
  356.     Name n        = newName(findText(s));
  357.     name(n).arity   = arity;
  358.     name(n).number  = no;
  359.     name(n).defn    = CFUN;
  360.     name(n).type    = type;
  361.     name(n).primDef = 0;
  362.     return n;
  363. }
  364.  
  365. static List local insertName(nm,ns)    /* insert name nm into sorted list */
  366. Name nm;                /* ns                   */
  367. List ns; {
  368.     Cell   prev = NIL;
  369.     Cell   curr = ns;
  370.     String s    = textToStr(name(nm).text);
  371.  
  372.     while (nonNull(curr) && strcmp(s,textToStr(name(hd(curr)).text))>=0) {
  373.     if (hd(curr)==nm)        /* just in case we get duplicates! */
  374.         return ns;
  375.     prev = curr;
  376.     curr = tl(curr);
  377.     }
  378.     if (nonNull(prev)) {
  379.     tl(prev) = cons(nm,curr);
  380.     return ns;
  381.     }
  382.     else
  383.     return cons(nm,curr);
  384. }
  385.  
  386. List addNamesMatching(pat,ns)        /* Add names matching pattern pat  */
  387. String pat;                /* to list of names ns           */
  388. List   ns; {                /* Null pattern matches every name */
  389.     Name nm;
  390.     for (nm=NAMEMIN; nm<nameHw; ++nm)
  391.     if (nonNull(name(nm).type) &&
  392.         (!pat || stringMatch(pat,textToStr(name(nm).text))))
  393.         ns = insertName(nm,ns);
  394.     return ns;
  395. }
  396.  
  397. /* --------------------------------------------------------------------------
  398.  * A simple string matching routine
  399.  *     `*'    matches any sequence of zero or more characters
  400.  *     `?'    matches any single character exactly 
  401.  *     `@str' matches the string str exactly (ignoring any special chars)
  402.  *     `\c'   matches the character c only (ignoring special chars)
  403.  *     c      matches the character c only
  404.  * ------------------------------------------------------------------------*/
  405.  
  406. static Void local patternError(s)    /* report error in pattern       */
  407. String s; {
  408.     ERROR(0) "%s in pattern", s
  409.     EEND;
  410. }
  411.  
  412. static Bool local stringMatch(pat,str)    /* match string against pattern       */
  413. String pat;
  414. String str; {
  415.  
  416.     for (;;)
  417.     switch (*pat) {
  418.         case '\0' : return (*str=='\0');
  419.  
  420.         case '*'  : do {
  421.                 if (stringMatch(pat+1,str))
  422.                 return TRUE;
  423.             } while (*str++);
  424.             return FALSE;
  425.  
  426.             case '?'  : if (*str++=='\0')
  427.                 return FALSE;
  428.             pat++;
  429.             break;
  430.  
  431.             case '['  : {   Bool found = FALSE;
  432.                 while (*++pat!='\0' && *pat!=']')
  433.                 if (!found && ( pat[0] == *str  ||
  434.                            (pat[1] == '-'   &&
  435.                         pat[2] != ']'   &&
  436.                         pat[2] != '\0'  &&
  437.                         pat[0] <= *str  &&
  438.                         pat[2] >= *str)))
  439.                                                
  440.                     found = TRUE;
  441.                 if (*pat != ']')
  442.                 patternError("missing `]'");
  443.                 if (!found)
  444.                 return FALSE;
  445.                 pat++;
  446.                 str++;
  447.             }
  448.                         break;
  449.  
  450.         case '\\' : if (*++pat == '\0')
  451.                 patternError("extra trailing `\\'");
  452.             /*fallthru!*/
  453.         default   : if (*pat++ != *str++)
  454.                 return FALSE;
  455.             break;
  456.     }
  457. }
  458.  
  459. /* --------------------------------------------------------------------------
  460.  * Storage of type classes, instances etc...:
  461.  * ------------------------------------------------------------------------*/
  462.  
  463. static Class classHw;               /* next unused class           */
  464. static Inst  instHw;               /* next unused instance record       */
  465. static Dict  dictHw;               /* next unused dictionary slot       */
  466.  
  467. struct Class    tabClass[NUM_CLASSES]; /* table of class records       */
  468. struct Inst far *tabInst;           /* (pointer to) table of instances  */
  469. Cell        far *tabDict;           /* (pointer to) table of dict slots */
  470.  
  471. Class newClass(t)               /* add new class to class table       */
  472. Text t; {
  473.     if (classHw-CLASSMIN >= NUM_CLASSES) {
  474.     ERROR(0) "Class storage space exhausted"
  475.     EEND;
  476.     }
  477.     class(classHw).text      = t;
  478.     class(classHw).sig         = NIL;
  479.     class(classHw).supers    = NIL;
  480.     class(classHw).members   = NIL;
  481.     class(classHw).defaults  = NIL;
  482.     class(classHw).instances = NIL;
  483.     return classHw++;
  484. }
  485.  
  486. Class findClass(t)               /* look for named class in table    */
  487. Text t; {
  488.     Class c;
  489.  
  490.     for (c=CLASSMIN; c<classHw; c++)
  491.     if (class(c).text==t)
  492.         return c;
  493.     return NIL;
  494. }
  495.  
  496. Inst newInst() {               /* add new instance to table       */
  497.     if (instHw-INSTMIN >= NUM_INSTS) {
  498.     ERROR(0) "Instance storage space exhausted"
  499.     EEND;
  500.     }
  501.     inst(instHw).specifics  = NIL;
  502.     inst(instHw).implements = NIL;
  503.     inst(instHw).dicts      = NIL;
  504.     inst(instHw).superBuild = NIL;
  505.  
  506.     return instHw++;
  507. }
  508.  
  509. Inst findInst(c,t)            /* find instance for specific C-T  */
  510. Class c;                /* where t is a Tycon (not synonym)*/
  511. Type  t; {                /* or TUPLE/UNIT/LIST/ARROW       */
  512.     List is = class(c).instances;
  513.     for (; nonNull(is); is=tl(is))
  514.     if (inst(hd(is)).t == t)
  515.         return hd(is);
  516.     return NIL;
  517. }
  518.  
  519. Inst findFirstInst(tc)            /* look for 1st instance involving */
  520. Tycon tc; {                /* the type constructor tc       */
  521.     Class c;
  522.     for (c=CLASSMIN; c<classHw; c++) {
  523.     Inst in = findInst(c,tc);
  524.     if (nonNull(in))
  525.         return in;
  526.     }
  527.     return NIL;
  528. }
  529.  
  530. Inst findNextInst(tc,in)        /* look for next instance involving*/
  531. Tycon tc;                /* the type constructor tc       */
  532. Inst  in; {                /* starting after instance in       */
  533.     Class c = inst(in).c + 1;
  534.     for (; c<classHw; c++) 
  535.     if (nonNull(in=findInst(c,tc)))
  536.         return in;
  537.     return NIL;
  538. }
  539.  
  540. Cell makeInstPred(in)            /* build predicate for instance in */
  541. Inst in; {
  542.     Cell r = inst(in).t;
  543.     Int  i = 0;
  544.     for (; i<inst(in).arity; ++i)
  545.     r = ap(r,mkOffset(i));
  546.     return ap(inst(in).c,r);
  547. }
  548.  
  549. Dict newDict(dictSize)               /* Allocate dictionary of given size*/
  550. Int dictSize; {
  551.     Dict dictStarts = dictHw;
  552.  
  553.     if ((dictHw+=dictSize) > NUM_DICTS) {
  554.     ERROR(0) "Dictionary storage space exhausted"
  555.     EEND;
  556.     }
  557.     return dictStarts;
  558. }
  559.  
  560. /* --------------------------------------------------------------------------
  561.  * Control stack:
  562.  *
  563.  * Various parts of the system use a stack of cells.  Most of the stack
  564.  * operations are defined as macros, expanded inline.
  565.  * ------------------------------------------------------------------------*/
  566.  
  567. Cell     cellStack[NUM_STACK];           /* Storage for cells on stack       */
  568. #ifndef  GLOBALsp
  569. StackPtr sp;                   /* stack pointer            */
  570. #endif
  571.  
  572. Void stackOverflow() {               /* Report stack overflow        */
  573.     ERROR(0) "Control stack overflow"
  574.     EEND;
  575. }
  576.  
  577. /* --------------------------------------------------------------------------
  578.  * Module storage:
  579.  *
  580.  * script files are read into the system one after another.  The state of
  581.  * the stored data structures (except the garbage-collected heap) is recorded
  582.  * before reading a new script.  In the event of being unable to read the
  583.  * script, or if otherwise requested, the system can be restored to its
  584.  * original state immediately before the file was read.
  585.  * ------------------------------------------------------------------------*/
  586.  
  587. typedef struct {               /* record of storage state prior to */
  588.     Text  textHw;               /* reading script/module        */
  589.     Text  nextNewText;
  590.     Text  nextNewDText;
  591.     Int   syntaxHw;
  592.     Addr  addrHw;
  593.     Tycon tyconHw;
  594.     Name  nameHw;
  595.     Class classHw;
  596.     Inst  instHw;
  597.     Dict  dictHw;
  598. } module;
  599.  
  600. static Module moduleHw;            /* next unused module number       */
  601. static module modules[NUM_MODULES];    /* storage for module records       */
  602.  
  603. Module startNewModule() {           /* start new module, keeping record */
  604.     if (moduleHw >= NUM_MODULES) {     /* of status for later restoration  */
  605.     ERROR(0) "Too many script/module files in use"
  606.     EEND;
  607.     }
  608.     modules[moduleHw].textHw       = textHw;
  609.     modules[moduleHw].nextNewText  = nextNewText;
  610.     modules[moduleHw].nextNewDText = nextNewDText;
  611.     modules[moduleHw].syntaxHw       = syntaxHw;
  612.     modules[moduleHw].addrHw       = addrHw;
  613.     modules[moduleHw].tyconHw       = tyconHw;
  614.     modules[moduleHw].nameHw       = nameHw;
  615.     modules[moduleHw].classHw       = classHw;
  616.     modules[moduleHw].instHw       = instHw;
  617.     modules[moduleHw].dictHw       = dictHw;
  618.     return moduleHw++;
  619. }
  620.  
  621. Bool nameThisModule(n)            /* Test if given name is defined in*/
  622. Name n; {                /* current module           */
  623.     return moduleHw<1 || n>=modules[moduleHw-1].nameHw;
  624. }
  625.  
  626. Module moduleThisName(nm)        /* find module number for name       */
  627. Name nm; {
  628.     Module m;
  629.  
  630.     for (m=0; m<moduleHw && nm>=modules[m].nameHw; m++)
  631.     ;
  632.     if (m>=moduleHw)
  633.     internal("moduleThisName");
  634.     return m;
  635. }
  636.  
  637. Void dropModulesFrom(mno)        /* Restore storage to state prior  */
  638. Module mno; {                /* to reading module mno        */
  639.     if (mno<moduleHw) {            /* is there anything to restore?   */
  640.     int i;
  641.     textHw         = modules[mno].textHw;
  642.     nextNewText  = modules[mno].nextNewText;
  643.     nextNewDText = modules[mno].nextNewDText;
  644.     syntaxHw     = modules[mno].syntaxHw;
  645.     addrHw         = modules[mno].addrHw;
  646.     tyconHw      = modules[mno].tyconHw;
  647.     nameHw         = modules[mno].nameHw;
  648.     classHw      = modules[mno].classHw;
  649.     instHw         = modules[mno].instHw;
  650.     dictHw         = modules[mno].dictHw;
  651.  
  652.     for (i=0; i<TEXTHSZ; ++i) {
  653.         int j = 0;
  654.         while (j<NUM_TEXTH && textHash[i][j]!=NOTEXT
  655.                    && textHash[i][j]<textHw)
  656.         ++j;
  657.         if (j<NUM_TEXTH)
  658.         textHash[i][j] = NOTEXT;
  659.     }
  660.  
  661.     for (i=0; i<TYCONHSZ; ++i) {
  662.         Tycon tc = tyconHash[i];
  663.         while (nonNull(tc) && tc>=tyconHw)
  664.         tc = tycon(tc).nextTyconHash;
  665.         tyconHash[i] = tc;
  666.     }
  667.  
  668.     for (i=0; i<NAMEHSZ; ++i) {
  669.         Name n = nameHash[i];
  670.         while (nonNull(n) && n>=nameHw)
  671.         n = name(n).nextNameHash;
  672.         nameHash[i] = n;
  673.     }
  674.  
  675.     for (i=CLASSMIN; i<classHw; i++) {
  676.         List in = class(i).instances;
  677.         List is = NIL;
  678.  
  679.         while (nonNull(in)) {
  680.         List temp = tl(in);
  681.         if (hd(in)<instHw) {
  682.             tl(in) = is;
  683.             is     = in;
  684.         }
  685.         in = temp;
  686.         }
  687.         class(i).instances = rev(is);
  688.     }
  689.  
  690.     for (i=INSTMIN; i<instHw; i++) {
  691.         List ds = inst(i).dicts;
  692.         List dn = NIL;
  693.  
  694.         while (nonNull(ds)) {
  695.         List temp = tl(ds);
  696.         if (dictOf(hd(ds))<dictHw) {
  697.             tl(ds) = dn;
  698.                     dn     = ds;
  699.         }
  700.         ds = temp;
  701.         }
  702.         inst(i).dicts = rev(dn);
  703.     }
  704.  
  705.     moduleHw = mno;
  706.     }
  707. }
  708.  
  709. /* --------------------------------------------------------------------------
  710.  * Heap storage:
  711.  * Provides a garbage collectable heap for storage of expressions etc.
  712.  * ------------------------------------------------------------------------*/
  713.  
  714. Int     heapSize = DEFAULTHEAP;        /* number of cells in heap       */
  715. Heap    heapFst;            /* array of fst component of pairs */
  716. Heap    heapSnd;            /* array of snd component of pairs */
  717. #ifndef GLOBALfst
  718. Heap    heapTopFst;
  719. #endif
  720. #ifndef GLOBALsnd
  721. Heap    heapTopSnd;
  722. #endif
  723. Long    numCells;
  724. Int     numberGcs;            /* number of garbage collections   */
  725. Int    cellsRecovered;            /* number of cells recovered       */
  726.  
  727. static  Cell freeList;            /* free list of unused cells       */
  728.  
  729. Cell pair(l,r)                /* Allocate pair (l, r) from       */
  730. Cell l, r; {                /* heap, garbage collecting first  */
  731.     Cell c = freeList;            /* if necessary ...           */
  732.  
  733.     if (isNull(c)) {
  734.     garbageCollect();
  735.     c = freeList;
  736.     }
  737.     freeList = snd(freeList);
  738.     fst(c)   = l;
  739.     snd(c)   = r;
  740.     numCells++;
  741.     return c;
  742. }
  743.  
  744. Void overwrite(dst,src)            /* overwrite dst cell with src cell*/
  745. Cell dst, src; {            /* both *MUST* be pairs            */
  746.     if (isPair(dst) && isPair(src)) {
  747.         fst(dst) = fst(src);
  748.         snd(dst) = snd(src);
  749.     }
  750.     else
  751.         internal("overwrite");
  752. }
  753.  
  754. static Int *marks;
  755. static Int marksSize;
  756.  
  757. Cell markExpr(c)            /* External interface to markCell  */
  758. Cell c; {
  759.     return markCell(c);
  760. }
  761.  
  762. static Cell local markCell(c)        /* Traverse part of graph marking  */
  763. Cell c; {                /* cells reachable from given root */
  764.  
  765. mc: if (!isPair(c))
  766.     return c;
  767.  
  768.     if (fst(c)==INDIRECT) {
  769.     c = indirectChain(c);
  770.     goto mc;
  771.     }
  772.  
  773.     {   register place = placeInSet(c);
  774.     register mask  = maskInSet(c);
  775.     if (marks[place]&mask)
  776.         return c;
  777.     else
  778.         marks[place] |= mask;
  779.     }
  780.  
  781.     if (isPair(fst(c))) {
  782.     fst(c) = markCell(fst(c));
  783.     markSnd(c);
  784.     }
  785.     else if (isNull(fst(c)) || fst(c)>=BCSTAG)
  786.     markSnd(c);
  787.  
  788.     return c;
  789. }
  790.  
  791. static Void local markSnd(c)        /* Variant of markCell used to     */
  792. Cell c; {                /* update snd component of cell    */
  793.     Cell t;                /* using tail recursion           */
  794.  
  795. ma: t = snd(c);
  796. mb: if (!isPair(t))
  797.     return;
  798.  
  799.     if (fst(t)==INDIRECT) {
  800.     snd(c) = t = indirectChain(t);
  801.     goto mb;
  802.     }
  803.     c = snd(c) = t;
  804.  
  805.     {   register place = placeInSet(c);
  806.     register mask  = maskInSet(c);
  807.     if (marks[place]&mask)
  808.         return;
  809.     else
  810.         marks[place] |= mask;
  811.     }
  812.  
  813.     if (isPair(fst(c))) {
  814.     fst(c) = markCell(fst(c));
  815.     goto ma;
  816.     }
  817.     else if (isNull(fst(c)) || fst(c)>=BCSTAG)
  818.     goto ma;
  819.     return;
  820. }
  821.  
  822. static Cell local indirectChain(c)    /* Scan chain of indirections       */
  823. Cell c; {                /* Detecting loops of indirections */
  824.     Cell is = c;            /* Uses pointer reversal ...       */
  825.     c       = snd(is);
  826.     snd(is) = NIL;
  827.     fst(is) = INDIRECT1;
  828.  
  829.     while (isPair(c) && fst(c)==INDIRECT) {
  830.     register Cell temp = snd(c);
  831.     snd(c)  = is;
  832.     is      = c;
  833.     c       = temp;
  834.     fst(is) = INDIRECT1;
  835.     }
  836.  
  837.     if (isPair(c) && fst(c)==INDIRECT1)
  838.     c = nameBlackHole;
  839.  
  840.     do {
  841.     register Cell temp = snd(is);
  842.     fst(is) = INDIRECT;
  843.     snd(is) = c;
  844.     is    = temp;
  845.     } while (nonNull(is));
  846.  
  847.     return c;
  848. }
  849.  
  850. Void markWithoutMove(n)            /* Garbage collect cell at n, as if*/
  851. Cell n; {                /* it was a cell ref, but don't    */
  852.                     /* move cell (i.e. retain INDIRECT */
  853.                     /* at top level) so we don't have  */
  854.                     /* to modify the stored value of n */
  855.     if (isGenPair(n)) {
  856.     if (fst(n)==INDIRECT) {        /* special case for indirections   */
  857.         register place = placeInSet(n);
  858.         register mask  = maskInSet(n);
  859.         marks[place]  |= mask;
  860.         markSnd(n);
  861.     }
  862.     else
  863.         markCell(n);        /* normal pairs don't move anyway  */
  864.     }
  865. }
  866.  
  867. Void garbageCollect() {            /* Run garbage collector ...       */
  868.     Bool breakStat = breakOn(FALSE);    /* disable break checking       */
  869.     Int i,j;
  870.     register Int mask;
  871.     register Int place;
  872.     Int      recovered;
  873.     jmp_buf  regs;            /* save registers on stack       */
  874.     setjmp(regs);
  875.  
  876.     gcStarted();
  877.     for (i=0; i<marksSize; ++i)        /* initialise mark set to empty    */
  878.     marks[i] = 0;
  879.     everybody(MARK);            /* mark all components of system   */
  880.  
  881.     /* Just in case garbageCollect is triggered when free list is non-empty*/
  882.     /* (called by openFile for example), scan the free list and unmark all */
  883.     /* cells - which otherwise might have been marked from the Cstack      */
  884.     for (; nonNull(freeList); freeList=snd(freeList))
  885.     marks[placeInSet(freeList)] &= ~(maskInSet(freeList));
  886.  
  887.     gcScanning();            /* scan mark set           */
  888.     mask      = 1;
  889.     place     = 0;
  890.     recovered = 0;
  891.     j         = 0;
  892.     for (i=1; i<=heapSize; i++) {
  893.     if ((marks[place] & mask) == 0) {
  894.         if (fst(-i)==FILECELL) {
  895.         closeFile(intValOf(-i));
  896.         fst(-i) = INTCELL;
  897.         }
  898.         snd(-i)  = freeList;
  899.         freeList = -i;
  900.         recovered++;
  901.     }
  902.     mask <<= 1;
  903.     if (++j == bitsPerWord) {
  904.         place++;
  905.         mask = 1;
  906.         j    = 0;
  907.     }
  908.     }
  909.     gcRecovered(recovered);
  910.  
  911.     breakOn(breakStat);            /* restore break trapping if nec.  */
  912.  
  913.     /* can only return if freeList is nonempty on return. */
  914.     if (recovered<minRecovery || isNull(freeList)) {
  915.     ERROR(0) "Garbage collection fails to reclaim sufficient space"
  916.     EEND;
  917.     }
  918.     numberGcs++;
  919.     cellsRecovered = recovered;
  920. }
  921.  
  922. /* --------------------------------------------------------------------------
  923.  * Code for saving last expression entered:
  924.  *
  925.  * This is a little tricky since some text values (e.g. strings or variable
  926.  * names) may not be defined or have the same value when the expression is
  927.  * recalled.  These text values are therefore saved in the top portion of
  928.  * the text table.
  929.  * ------------------------------------------------------------------------*/
  930.  
  931. static Cell lastExprSaved;        /* last expression to be saved       */
  932.  
  933. Void setLastExpr(e)            /* save expression for later recall*/
  934. Cell e; {
  935.     lastExprSaved = NIL;        /* in case attempt to save fails   */
  936.     savedText      = NUM_TEXT;
  937.     lastExprSaved = lowLevelLastIn(e);
  938. }
  939.  
  940. static Cell local lowLevelLastIn(c)    /* Duplicate expression tree (i.e. */
  941. Cell c; {                /* acyclic graph) for later recall */
  942.     if (isPair(c))            /* Duplicating any text strings    */
  943.     if (isBoxTag(fst(c)))        /* in case these are lost at some  */
  944.         switch (fst(c)) {        /* point before the expr is reused */
  945.         case VARIDCELL :
  946.         case VAROPCELL :
  947.         case DICTVAR   :
  948.         case CONIDCELL :
  949.         case CONOPCELL :
  950.         case STRCELL   : return pair(fst(c),saveText(textOf(c)));
  951.         default           : return pair(fst(c),snd(c));
  952.         }
  953.     else
  954.         return pair(lowLevelLastIn(fst(c)),lowLevelLastIn(snd(c)));
  955.     else
  956.     return c;
  957. }
  958.  
  959. Cell getLastExpr() {            /* recover previously saved expr   */
  960.     return lowLevelLastOut(lastExprSaved);
  961. }
  962.  
  963. static Cell local lowLevelLastOut(c)    /* As with lowLevelLastIn() above  */
  964. Cell c; {                /* except that Cells refering to   */
  965.     if (isPair(c))            /* Text values are restored to       */
  966.     if (isBoxTag(fst(c)))        /* appropriate values           */
  967.         switch (fst(c)) {
  968.         case VARIDCELL :
  969.         case VAROPCELL :
  970.         case DICTVAR   :
  971.         case CONIDCELL :
  972.         case CONOPCELL :
  973.         case STRCELL   : return pair(fst(c),
  974.                          findText(text+intValOf(c)));
  975.         default           : return pair(fst(c),snd(c));
  976.         }
  977.     else
  978.         return pair(lowLevelLastOut(fst(c)),lowLevelLastOut(snd(c)));
  979.     else
  980.     return c;
  981. }
  982.  
  983. /* --------------------------------------------------------------------------
  984.  * Miscellaneous operations on heap cells:
  985.  * ------------------------------------------------------------------------*/
  986.  
  987. /* profiling suggests that the number of calls to whatIs() is typically    */
  988. /* rather high.  The recoded version below attempts to improve the average */
  989. /* performance for whatIs() using a binary search for part of the analysis */
  990.  
  991. Cell whatIs(c)                   /* identify type of cell        */
  992. register Cell c; {
  993.     if (isPair(c)) {
  994.     register Cell fstc = fst(c);
  995.     return isTag(fstc) ? fstc : AP;
  996.     }
  997.     if (c<TUPMIN)    return c;
  998.     if (c>=INTMIN)   return INTCELL;
  999.  
  1000.     if (c>=SELMIN)  if (c>=CLASSMIN)    if (c>=CHARMIN) return CHARCELL;
  1001.                     else        return CLASS;
  1002.             else        if (c>=INSTMIN) return INSTANCE;
  1003.                     else        return SELECT;
  1004.     else        if (c>=TYCMIN)    if (c>=NAMEMIN)    return NAME;
  1005.                     else        return TYCON;
  1006.             else        if (c>=OFFMIN)    return OFFSET;
  1007.                     else        return TUPLE;
  1008.  
  1009. /*  if (c>=CHARMIN)  return CHARCELL;
  1010.     if (c>=CLASSMIN) return CLASS;
  1011.     if (c>=INSTMIN)  return INSTANCE;
  1012.     if (c>=SELMIN)   return SELECT;
  1013.     if (c>=NAMEMIN)  return NAME;
  1014.     if (c>=TYCMIN)   return TYCON;
  1015.     if (c>=OFFMIN)   return OFFSET;
  1016.     if (c>=TUPMIN)   return TUPLE;
  1017.     return c;*/
  1018. }
  1019.  
  1020. Bool isVar(c)                /* is cell a VARIDCELL/VAROPCELL ? */
  1021. Cell c; {                /* also recognises DICTVAR cells   */
  1022.     return isPair(c) &&
  1023.            (fst(c)==VARIDCELL || fst(c)==VAROPCELL || fst(c)==DICTVAR);
  1024. }
  1025.  
  1026. Bool isCon(c)                   /* is cell a CONIDCELL/CONOPCELL ?  */
  1027. Cell c; {
  1028.     return isPair(c) && (fst(c)==CONIDCELL || fst(c)==CONOPCELL);
  1029. }
  1030.  
  1031. Bool isInt(c)                   /* cell holds integer value?       */
  1032. Cell c; {
  1033.     return isSmall(c) || (isPair(c) && fst(c)==INTCELL);
  1034. }
  1035.  
  1036. Int intOf(c)                   /* find integer value of cell?       */
  1037. Cell c; {
  1038.     return isPair(c) ? (Int)(snd(c)) : (Int)(c-INTZERO);
  1039. }
  1040.  
  1041. Cell mkInt(n)                   /* make cell representing integer   */
  1042. Int n; {
  1043.     return isSmall(INTZERO+n) ? INTZERO+n : pair(INTCELL,n);
  1044. }
  1045.  
  1046. Bool isBignum(c)               /* cell holds bignum value?       */
  1047. Cell c; {
  1048.     return c==ZERONUM || (isPair(c) && (fst(c)==POSNUM || fst(c)==NEGNUM));
  1049. }
  1050.  
  1051. /* --------------------------------------------------------------------------
  1052.  * List operations:
  1053.  * ------------------------------------------------------------------------*/
  1054.  
  1055. Int length(xs)                   /* calculate length of list xs       */
  1056. List xs; {
  1057.     Int n = 0;
  1058.     for (n=0; nonNull(xs); ++n)
  1059.     xs = tl(xs);
  1060.     return n;
  1061. }
  1062.  
  1063. List appendOnto(xs,ys)               /* Destructively prepend xs onto    */
  1064. List xs, ys; {                   /* ys by modifying xs ...       */
  1065.     if (isNull(xs))
  1066.     return ys;
  1067.     else {
  1068.     List zs = xs;
  1069.     while (nonNull(tl(zs)))
  1070.         zs = tl(zs);
  1071.     tl(zs) = ys;
  1072.     return xs;
  1073.     }
  1074. }
  1075.  
  1076. List dupList(xs)               /* Duplicate spine of list xs       */
  1077. List xs; {
  1078.     List ys = NIL;
  1079.     for (; nonNull(xs); xs=tl(xs))
  1080.     ys = cons(hd(xs),ys);
  1081.     return rev(ys);
  1082. }
  1083.  
  1084. List revOnto(xs,ys)               /* Destructively reverse elements of*/
  1085. List xs, ys; {                   /* list xs onto list ys...       */
  1086.     Cell zs;
  1087.  
  1088.     while (nonNull(xs)) {
  1089.     zs     = tl(xs);
  1090.     tl(xs) = ys;
  1091.     ys     = xs;
  1092.     xs     = zs;
  1093.     }
  1094.     return ys;
  1095. }
  1096.  
  1097. Cell varIsMember(t,xs)               /* Test if variable is a member of  */
  1098. Text t;                    /* given list of variables       */
  1099. List xs; {
  1100.     for (; nonNull(xs); xs=tl(xs))
  1101.     if (t==textOf(hd(xs)))
  1102.         return hd(xs);
  1103.     return NIL;
  1104. }
  1105.  
  1106. Cell intIsMember(n,xs)               /* Test if integer n is member of   */
  1107. Int  n;                    /* given list of integers       */
  1108. List xs; {
  1109.     for (; nonNull(xs); xs=tl(xs))
  1110.     if (n==intOf(hd(xs)))
  1111.         return hd(xs);
  1112.     return NIL;
  1113. }
  1114.  
  1115. Cell cellIsMember(x,xs)            /* Test for membership of specific  */
  1116. Cell x;                    /* cell x in list xs           */
  1117. List xs; {
  1118.     for (; nonNull(xs); xs=tl(xs))
  1119.     if (x==hd(xs))
  1120.         return hd(xs);
  1121.     return NIL;
  1122. }
  1123.  
  1124. List copy(n,x)                   /* create list of n copies of x       */
  1125. Int n;
  1126. Cell x; {
  1127.     List xs=NIL;
  1128.     while (0<n--)
  1129.     xs = cons(x,xs);
  1130.     return xs;
  1131. }
  1132.  
  1133. List diffList(from,take)           /* list difference: from\take       */
  1134. List from, take; {               /* result contains all elements of  */
  1135.     List result = NIL;               /* `from' not appearing in `take'   */
  1136.  
  1137.     while (nonNull(from)) {
  1138.     List next = tl(from);
  1139.     if (!cellIsMember(hd(from),take)) {
  1140.         tl(from) = result;
  1141.         result   = from;
  1142.     }
  1143.     from = next;
  1144.     }
  1145.     return rev(result);
  1146. }
  1147.  
  1148. List take(n,xs)                /* destructively truncate list to  */
  1149. Int  n;                    /* specified length           */
  1150. List xs; {
  1151.     List start = xs;
  1152.  
  1153.     if (n==0)
  1154.     return NIL;
  1155.     while (1<n-- && nonNull(xs))
  1156.     xs = tl(xs);
  1157.     if (nonNull(xs))
  1158.     tl(xs) = NIL;
  1159.     return start;
  1160. }
  1161.  
  1162. List initSeg(xs)            /* destructively truncate list to  */
  1163. List xs; {                /* its initial segment           */
  1164.     if (isNull(xs) || isNull(tl(xs)))
  1165.     return NIL;
  1166.     else
  1167.     return take(length(xs)-1,xs);    /* not the best, but it'll do       */
  1168. }
  1169.  
  1170. List removeCell(x,xs)            /* destructively remove cell from  */
  1171. Cell x;                    /* list                   */
  1172. List xs; {
  1173.     if (nonNull(xs)) {
  1174.     if (hd(xs)==x)
  1175.         return tl(xs);        /* element at front of list       */
  1176.     else {
  1177.         List prev = xs;
  1178.         List curr = tl(xs);
  1179.         for (; nonNull(curr); prev=curr, curr=tl(prev))
  1180.         if (hd(curr)==x) {
  1181.             tl(prev) = tl(curr);
  1182.             return xs;        /* element in middle of list       */
  1183.         }
  1184.     }
  1185.     }
  1186.     return xs;                /* here if element not found       */
  1187. }
  1188.  
  1189. /* --------------------------------------------------------------------------
  1190.  * Operations on applications:
  1191.  * ------------------------------------------------------------------------*/
  1192.  
  1193. Int argCount;                   /* number of args in application    */
  1194.  
  1195. Cell getHead(e)                /* get head cell of application       */
  1196. Cell e; {                   /* set number of args in argCount   */
  1197.     for (argCount=0; isAp(e); e=fun(e))
  1198.     argCount++;
  1199.     return e;
  1200. }
  1201.  
  1202. List getArgs(e)                /* get list of arguments in function*/
  1203. Cell e; {                   /* application:               */
  1204.     List as;                   /* getArgs(f e1 .. en) = [e1,..,en] */
  1205.  
  1206.     for (as=NIL; isAp(e); e=fun(e))
  1207.     as = cons(arg(e),as);
  1208.     return as;
  1209. }
  1210.  
  1211. Cell nthArg(n,e)               /* return nth arg in application    */
  1212. Int  n;                       /* of function to m args (m>=n)     */
  1213. Cell e; {                              /* nthArg n (f x0 x1 ... xm) = xn   */
  1214.     for (n=numArgs(e)-n-1; n>0; n--)
  1215.     e = fun(e);
  1216.     return arg(e);
  1217. }
  1218.  
  1219. Int numArgs(e)                   /* find number of arguments to expr */
  1220. Cell e; {
  1221.     Int n;
  1222.     for (n=0; isAp(e); e=fun(e))
  1223.     n++;
  1224.     return n;
  1225. }
  1226.  
  1227. Cell applyToArgs(f,args)           /* destructively apply list of args */
  1228. Cell f;                       /* to function f               */
  1229. List args; {
  1230.     while (nonNull(args)) {
  1231.     Cell temp = tl(args);
  1232.     tl(args)  = hd(args);
  1233.     hd(args)  = f;
  1234.     f      = args;
  1235.     args      = temp;
  1236.     }
  1237.     return f;
  1238. }
  1239.  
  1240. /* --------------------------------------------------------------------------
  1241.  * File operations:
  1242.  * ------------------------------------------------------------------------*/
  1243.  
  1244. static FILE *infiles[NUM_FILES];    /* file pointers for input files   */
  1245.  
  1246. Cell openFile(s)            /* create FILECELL object for named*/
  1247. String s; {                /* input file               */
  1248.     Int i;
  1249.  
  1250.     for (i=0; i<NUM_FILES && infiles[i]; ++i)    /* look for unused file .. */
  1251.     ;
  1252.     if (i>=NUM_FILES) {                /* if at first we don't    */
  1253.     garbageCollect();            /* succeed, garbage collect*/
  1254.     for (i=0; i<NUM_FILES && infiles[i]; ++i)
  1255.         ;                    /* and try again ...       */
  1256.     }
  1257.     if (i>=NUM_FILES) {                /* ... before we give up   */
  1258.     ERROR(0) "Too many files open; cannot open %s", s
  1259.     EEND;
  1260.     }
  1261.  
  1262.     if (infiles[i]=fopen(s,"r"))
  1263.     return ap(FILECELL,i);
  1264.     else
  1265.     return NIL;
  1266. }
  1267.  
  1268. Void evalFile(f)                /* read char from given    */
  1269. Cell f; {                    /* input file -- ensure       */
  1270.     Int c;                    /* only 1 copy of FILECELL */
  1271.     if ((c = fgetc(infiles[intValOf(f)]))==EOF) {
  1272.     closeFile(intValOf(f));
  1273.     fst(f) = INDIRECT;
  1274.     snd(f) = nameNil;
  1275.     }
  1276.     else {
  1277.     snd(f) = ap(FILECELL,intValOf(f));
  1278.     fst(f) = NIL;    /* avoid having 2 copies of FILECELL, so that file */
  1279.             /* is not closed prematurely by garbage collector  */
  1280.     fst(f) = consChar(c);
  1281.     }
  1282. }
  1283.  
  1284. static Void local closeFile(n)            /* close input file n       */
  1285. Int n; {                    /* only permitted when the */
  1286.     if (0<=n && n<NUM_FILES && infiles[n]) {    /* end of file is read or  */
  1287.     fclose(infiles[n]);            /* when discarded during gc*/
  1288.     infiles[n] = 0;
  1289.     }
  1290. }
  1291.  
  1292. /* --------------------------------------------------------------------------
  1293.  * storage control:
  1294.  * ------------------------------------------------------------------------*/
  1295.  
  1296. Void storage(what)
  1297. Int what; {
  1298.     Int i;
  1299.  
  1300.     switch (what) {
  1301.     case RESET   : clearStack();
  1302.  
  1303.                /* the next 2 statements are particularly important
  1304.                 * if you are using GLOBALfst or GLOBALsnd since the
  1305.             * corresponding registers may be reset to their
  1306.             * uninitialised initial values by a longjump.
  1307.             */
  1308.                heapTopFst = heapFst + heapSize;
  1309.                heapTopSnd = heapSnd + heapSize;
  1310.  
  1311.                if (isNull(lastExprSaved))
  1312.                savedText = NUM_TEXT;
  1313.                break;
  1314.  
  1315.     case MARK    : for (i=TYCMIN; i<tyconHw; ++i) {
  1316.                mark(tycon(i).defn);
  1317.                mark(tycon(i).kind);
  1318.                mark(tycon(i).what);
  1319.                }
  1320.  
  1321.                for (i=NAMEMIN; i<nameHw; ++i) {
  1322.                mark(name(i).defn);
  1323.                mark(name(i).type);
  1324.                }
  1325.  
  1326.                for (i=CLASSMIN; i<classHw; ++i) {
  1327.                mark(class(i).sig);
  1328.                mark(class(i).supers);
  1329.                mark(class(i).members);
  1330.                mark(class(i).defaults);
  1331.                            mark(class(i).instances);
  1332.                }
  1333.  
  1334.                for (i=INSTMIN; i<instHw; ++i) {
  1335.                mark(inst(i).specifics);
  1336.                mark(inst(i).implements);
  1337.                mark(inst(i).dicts);
  1338.                mark(inst(i).superBuild);
  1339.                }
  1340.  
  1341.                for (i=0; i<=sp; ++i)
  1342.                mark(stack(i));
  1343.  
  1344.                for (i=0; i<dictHw; ++i)
  1345.                mark(dict(i));
  1346.  
  1347.                mark(lastExprSaved);
  1348.  
  1349.                        gcCStack();
  1350.  
  1351.                break;
  1352.  
  1353.     case INSTALL : clearStack();
  1354.  
  1355.                for (i=0; i<NUM_FILES; i++)
  1356.                infiles[i] = 0;
  1357.  
  1358.                heapFst = heapAlloc(heapSize);
  1359.                heapSnd = heapAlloc(heapSize);
  1360.  
  1361.                if (heapFst==(Heap)0 || heapSnd==(Heap)0) {
  1362.                ERROR(0) "Cannot allocate heap storage (%d cells)",
  1363.                     heapSize
  1364.                EEND;
  1365.                }
  1366.  
  1367.                heapTopFst = heapFst + heapSize;
  1368.                heapTopSnd = heapSnd + heapSize;
  1369.  
  1370.                for (i=1; i<heapSize; ++i)
  1371.                snd(-i) = -(i+1);
  1372.                snd(-heapSize) = NIL;
  1373.                freeList       = -1;
  1374.                numberGcs      = 0;
  1375.  
  1376.                marksSize  = bitArraySize(heapSize);
  1377.                if ((marks=(Int *)calloc(marksSize, sizeof(Int)))==0) {
  1378.                ERROR(0) "Unable to allocate gc markspace"
  1379.                EEND;
  1380.                }
  1381.  
  1382.                textHw         = 0;
  1383.                nextNewText   = NUM_TEXT;
  1384.                nextNewDText  = (-1);
  1385.                lastExprSaved = NIL;
  1386.                savedText     = NUM_TEXT;
  1387.                for (i=0; i<TEXTHSZ; ++i)
  1388.                textHash[i][0] = NOTEXT;
  1389.  
  1390.                syntaxHw = 0;
  1391.  
  1392.                addrHw    = 0;
  1393.  
  1394.                tyconHw    = TYCMIN;
  1395.                for (i=0; i<TYCONHSZ; ++i)
  1396.                tyconHash[i] = NIL;
  1397.  
  1398.                nameHw = NAMEMIN;
  1399.                for (i=0; i<NAMEHSZ; ++i)
  1400.                nameHash[i] = NIL;
  1401.  
  1402.                classHw    = CLASSMIN;
  1403.  
  1404.                instHw    = INSTMIN;
  1405.  
  1406.                dictHw    = 0;
  1407.  
  1408.                tabInst    = (struct Inst far *)
  1409.                     farCalloc(NUM_INSTS,sizeof(struct Inst));
  1410.                tabDict    = (Cell far *)
  1411.                     farCalloc(NUM_DICTS,sizeof(Cell));
  1412.  
  1413.                if (tabInst==0 || tabDict==0) {
  1414.                ERROR(0) "Cannot allocate instance tables"
  1415.                EEND;
  1416.                }
  1417.  
  1418.                moduleHw = 0;
  1419.  
  1420.                break;
  1421.     }
  1422. }
  1423.  
  1424. /*-------------------------------------------------------------------------*/
  1425.