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