ghc/interpreter/storage.c

   1 /* -*- mode: hugs-c; -*- */
   2 /* --------------------------------------------------------------------------
   3  * Primitives for manipulating global data structures
   4  *
   5  * Copyright (c) The University of Nottingham and Yale University, 1994-1997.
   6  * All rights reserved. See NOTICE for details and conditions of use etc...
   7  * Hugs version 1.4, December 1997
   8  *
   9  * $RCSfile: storage.c,v $
  10  * $Revision: 1.2 $
  11  * $Date: 1998/12/02 13:22:41 $
  12  * ------------------------------------------------------------------------*/
  13
  14 #include "prelude.h"
  15 #include "storage.h"
  16 #include "connect.h"
  17 #include "charset.h"
  18 #include "errors.h"
  19 #include "link.h"    /* for nameCons         */
  20 #include <setjmp.h>
  21
  22 #include "machdep.h" /* gc-related functions */
  23
  24 /*#define DEBUG_SHOWUSE*/
  25
  26 /* --------------------------------------------------------------------------
  27  * local function prototypes:
  28  * ------------------------------------------------------------------------*/
  29
  30 static Int  local hash                  Args((String));
  31 static Int  local saveText              Args((Text));
  32 static Module local findQualifier       Args((Text));
  33 static Void local hashTycon             Args((Tycon));
  34 static List local insertTycon           Args((Tycon,List));
  35 static Void local hashName              Args((Name));
  36 static List local insertName            Args((Name,List));
  37 static Void local patternError          Args((String));
  38 static Bool local stringMatch           Args((String,String));
  39 static Bool local typeInvolves          Args((Type,Type));
  40 static Cell local markCell              Args((Cell));
  41 static Void local markSnd               Args((Cell));
  42 static Cell local lowLevelLastIn        Args((Cell));
  43 static Cell local lowLevelLastOut       Args((Cell));
  44 static Module local moduleOfScript      Args((Script));
  45 static Script local scriptThisFile      Args((Text));
  46
  47
  48 /* --------------------------------------------------------------------------
  49  * Text storage:
  50  *
  51  * provides storage for the characters making up identifier and symbol
  52  * names, string literals, character constants etc...
  53  *
  54  * All character strings are stored in a large character array, with textHw
  55  * pointing to the next free position.  Lookup in the array is improved using
  56  * a hash table.  Internally, text strings are represented by integer offsets
  57  * from the beginning of the array to the string in question.
  58  *
  59  * Where memory permits, the use of multiple hashtables gives a significant
  60  * increase in performance, particularly when large source files are used.
  61  *
  62  * Each string in the array is terminated by a zero byte.  No string is
  63  * stored more than once, so that it is safe to test equality of strings by
  64  * comparing the corresponding offsets.
  65  *
  66  * Special text values (beyond the range of the text array table) are used
  67  * to generate unique `new variable names' as required.
  68  *
  69  * The same text storage is also used to hold text values stored in a saved
  70  * expression.  This grows downwards from the top of the text table (and is
  71  * not included in the hash table).
  72  * ------------------------------------------------------------------------*/
  73
  74 #define TEXTHSZ 512                     /* Size of Text hash table         */
  75 #define NOTEXT  ((Text)(~0))            /* Empty bucket in Text hash table */
  76 static  Text    textHw;                 /* Next unused position            */
  77 static  Text    savedText = NUM_TEXT;   /* Start of saved portion of text  */
  78 static  Text    nextNewText;            /* Next new text value             */
  79 static  Text    nextNewDText;           /* Next new dict text value        */
  80 static  char    DEFTABLE(text,NUM_TEXT);/* Storage of character strings    */
  81 static  Text    textHash[TEXTHSZ][NUM_TEXTH]; /* Hash table storage        */
  82
  83 String textToStr(t)                    /* find string corresp to given Text*/
  84 Text t; {
  85     static char newVar[16];
  86
  87     if (0<=t && t<NUM_TEXT)                     /* standard char string    */
  88         return text + t;
  89     if (t<0)
  90         sprintf(newVar,"d%d",-t);               /* dictionary variable     */
  91     else
  92         sprintf(newVar,"v%d",t-NUM_TEXT);       /* normal variable         */
  93     return newVar;
  94 }
  95
  96 String identToStr(v) /*find string corresp to given ident or qualified name*/
  97 Cell v; {
  98     static char newVar[33];
  99
 100     assert(isPair(v));
 101     switch (fst(v)) {
 102         case VARIDCELL  :
 103         case VAROPCELL  :
 104         case CONIDCELL  :
 105         case CONOPCELL  : return text+textOf(v);
 106
 107         case QUALIDENT  : sprintf(newVar,"%s.%s",
 108                                   text+qmodOf(v),text+qtextOf(v));
 109                           return newVar;
 110     }
 111     internal("identToStr 2");
 112 }
 113
 114 Syntax identSyntax(v)           /* find syntax of ident or qualified ident */
 115 Cell v; {
 116     assert(isPair(v));
 117     switch (fst(v)) {
 118         case VARIDCELL  :
 119         case VAROPCELL  :
 120         case CONIDCELL  :
 121         case CONOPCELL  : return syntaxOf(textOf(v));
 122
 123         case QUALIDENT  : return syntaxOf(qtextOf(v));
 124     }
 125     internal("identSyntax 2");
 126 }
 127
 128 Text inventText()     {                 /* return new unused variable name */
 129     return nextNewText++;
 130 }
 131
 132 Text inventDictText() {                 /* return new unused dictvar name  */
 133     return nextNewDText--;
 134 }
 135
 136 Bool inventedText(t)                    /* Signal TRUE if text has been    */
 137 Text t; {                               /* generated internally            */
 138     return (t<0 || t>=NUM_TEXT);
 139 }
 140
 141 static Int local hash(s)                /* Simple hash function on strings */
 142 String s; {
 143     int v, j = 3;
 144
 145     for (v=((int)(*s))*8; *s; s++)
 146         v += ((int)(*s))*(j++);
 147     if (v<0)
 148         v = (-v);
 149     return(v%TEXTHSZ);
 150 }
 151
 152 Text findText(s)                       /* Locate string in Text array      */
 153 String s; {
 154     int    h       = hash(s);
 155     int    hashno  = 0;
 156     Text   textPos = textHash[h][hashno];
 157
 158 #define TryMatch        {   Text   originalTextPos = textPos;              \
 159                             String t;                                      \
 160                             for (t=s; *t==text[textPos]; textPos++,t++)    \
 161                                 if (*t=='\0')                              \
 162                                     return originalTextPos;                \
 163                         }
 164 #define Skip            while (text[textPos++]) ;
 165
 166     while (textPos!=NOTEXT) {
 167         TryMatch
 168         if (++hashno<NUM_TEXTH)         /* look in next hashtable entry    */
 169             textPos = textHash[h][hashno];
 170         else {
 171             Skip
 172             while (textPos < textHw) {
 173                 TryMatch
 174                 Skip
 175             }
 176             break;
 177         }
 178     }
 179
 180 #undef TryMatch
 181 #undef Skip
 182
 183     textPos = textHw;                  /* if not found, save in array      */
 184     if (textHw + (Int)strlen(s) + 1 > savedText) {
 185         ERRMSG(0) "Character string storage space exhausted"
 186         EEND;
 187     }
 188     while ((text[textHw++] = *s++) != 0) {
 189     }
 190     if (hashno<NUM_TEXTH) {            /* updating hash table as necessary */
 191         textHash[h][hashno] = textPos;
 192         if (hashno<NUM_TEXTH-1)
 193             textHash[h][hashno+1] = NOTEXT;
 194     }
 195
 196     return textPos;
 197 }
 198
 199 static Int local saveText(t)            /* Save text value in buffer       */
 200 Text t; {                               /* at top of text table            */
 201     String s = textToStr(t);
 202     Int    l = strlen(s);
 203
 204     if (textHw + l + 1 > savedText) {
 205         ERRMSG(0) "Character string storage space exhausted"
 206         EEND;
 207     }
 208     savedText -= l+1;
 209     strcpy(text+savedText,s);
 210     return savedText;
 211 }
 212
 213 /* --------------------------------------------------------------------------
 214  * Syntax storage:
 215  *
 216  * Operator declarations are stored in a table which associates Text values
 217  * with Syntax values.
 218  * ------------------------------------------------------------------------*/
 219
 220 static Int syntaxHw;                   /* next unused syntax table entry   */
 221 static struct strSyntax {              /* table of Text <-> Syntax values  */
 222     Text   text;
 223     Syntax syntax;
 224 } DEFTABLE(tabSyntax,NUM_SYNTAX);
 225
 226 Syntax defaultSyntax(t)                /* Find default syntax of var named */
 227 Text t; {                              /* by t ...                         */
 228     String s = textToStr(t);
 229     return isIn(s[0],SYMBOL) ? DEF_OPSYNTAX : APPLIC;
 230 }
 231
 232 Syntax syntaxOf(t)                     /* look up syntax of operator symbol*/
 233 Text t; {
 234     int i;
 235
 236     for (i=0; i<syntaxHw; ++i)
 237         if (tabSyntax[i].text==t)
 238             return tabSyntax[i].syntax;
 239     return defaultSyntax(t);
 240 }
 241
 242 Void addSyntax(line,t,sy)              /* add (t,sy) to syntax table       */
 243 Int    line;
 244 Text   t;
 245 Syntax sy; {
 246     int i;
 247
 248     for (i=0; i<syntaxHw; ++i)
 249         if (tabSyntax[i].text==t) {
 250             /* There's no problem with multiple identical fixity declarations.
 251              * - but note that it's not allowed by the Haskell report.  ADR
 252              */
 253             if (tabSyntax[i].syntax == sy) return;
 254             ERRMSG(line) "Attempt to redefine syntax of operator \"%s\"",
 255                          textToStr(t)
 256             EEND;
 257         }
 258
 259     if (syntaxHw>=NUM_SYNTAX) {
 260         ERRMSG(line) "Too many fixity declarations"
 261         EEND;
 262     }
 263
 264     tabSyntax[syntaxHw].text   = t;
 265     tabSyntax[syntaxHw].syntax = sy;
 266     syntaxHw++;
 267 }
 268
 269 /* --------------------------------------------------------------------------
 270  * Ext storage:
 271  *
 272  * Currently, the only attributes that we store for each Ext value is the
 273  * corresponding Text label.  At some later stage, we may decide to cache
 274  * types, predicates, etc. here as a space saving gesture.  Given that Text
 275  * comparison is cheap, and that this is an experimental implementation, we
 276  * will use a straightforward linear search to locate Ext values from their
 277  * corresponding Text labels; a hashing scheme can be introduced later if
 278  * this turns out to be a problem.
 279  * ------------------------------------------------------------------------*/
 280
 281 #if TREX
 282 Text  DEFTABLE(tabExt,NUM_EXT);         /* Storage for Ext names           */
 283 Ext   extHw;
 284
 285 Ext mkExt(t)                            /* Allocate or find an Ext value   */
 286 Text t; {
 287     Ext e = EXTMIN;
 288     for (; e<extHw; e++)
 289         if (t==extText(e))
 290             return e;
 291     if (extHw-EXTMIN >= NUM_EXT) {
 292         ERRMSG(0) "Ext storage space exhausted"
 293         EEND;
 294     }
 295     extText(extHw) = t;
 296     return extHw++;
 297 }
 298 #endif
 299
 300 /* --------------------------------------------------------------------------
 301  * Tycon storage:
 302  *
 303  * A Tycon represents a user defined type constructor.  Tycons are indexed
 304  * by Text values ... a very simple hash function is used to improve lookup
 305  * times.  Tycon entries with the same hash code are chained together, with
 306  * the most recent entry at the front of the list.
 307  * ------------------------------------------------------------------------*/
 308
 309 #define TYCONHSZ 256                            /* Size of Tycon hash table*/
 310 #define tHash(x) ((x)%TYCONHSZ)                 /* Tycon hash function     */
 311 static  Tycon    tyconHw;                       /* next unused Tycon       */
 312 static  Tycon    DEFTABLE(tyconHash,TYCONHSZ);  /* Hash table storage      */
 313 struct  strTycon DEFTABLE(tabTycon,NUM_TYCON);  /* Tycon storage           */
 314
 315 Tycon newTycon(t)                       /* add new tycon to tycon table    */
 316 Text t; {
 317     Int h = tHash(t);
 318
 319     if (tyconHw-TYCMIN >= NUM_TYCON) {
 320         ERRMSG(0) "Type constructor storage space exhausted"
 321         EEND;
 322     }
 323     tycon(tyconHw).text          = t;   /* clear new tycon record          */
 324     tycon(tyconHw).kind          = NIL;
 325     tycon(tyconHw).defn          = NIL;
 326     tycon(tyconHw).what          = NIL;
 327     tycon(tyconHw).conToTag      = NIL;
 328     tycon(tyconHw).tagToCon      = NIL;
 329     tycon(tyconHw).mod           = currentModule;
 330     module(currentModule).tycons = cons(tyconHw,module(currentModule).tycons);
 331     tycon(tyconHw).nextTyconHash = tyconHash[h];
 332     tyconHash[h]                 = tyconHw;
 333
 334     return tyconHw++;
 335 }
 336
 337 Tycon findTycon(t)                      /* locate Tycon in tycon table     */
 338 Text t; {
 339     Tycon tc = tyconHash[tHash(t)];
 340
 341     while (nonNull(tc) && tycon(tc).text!=t)
 342         tc = tycon(tc).nextTyconHash;
 343     return tc;
 344 }
 345
 346 Tycon addTycon(tc)  /* Insert Tycon in tycon table - if no clash is caused */
 347 Tycon tc; {
 348     Tycon oldtc = findTycon(tycon(tc).text);
 349     if (isNull(oldtc)) {
 350         hashTycon(tc);
 351         module(currentModule).tycons=cons(tc,module(currentModule).tycons);
 352         return tc;
 353     } else
 354         return oldtc;
 355 }
 356
 357 static Void local hashTycon(tc)         /* Insert Tycon into hash table    */
 358 Tycon tc; {
 359     Text  t = tycon(tc).text;
 360     Int   h = tHash(t);
 361     tycon(tc).nextTyconHash = tyconHash[h];
 362     tyconHash[h]            = tc;
 363 }
 364
 365 Tycon findQualTycon(id) /*locate (possibly qualified) Tycon in tycon table */
 366 Cell id; {
 367     assert(isPair(id));
 368     switch (fst(id)) {
 369         case CONIDCELL :
 370         case CONOPCELL :
 371             return findTycon(textOf(id));
 372         case QUALIDENT : {
 373             Text   t  = qtextOf(id);
 374             Module m  = findQualifier(qmodOf(id));
 375             List   es = NIL;
 376             if (isNull(m))
 377                 return NIL;
 378             if (m==currentModule) {
 379                 /* The Haskell report (rightly) forbids this.
 380                  * We added it to let the Prelude refer to itself
 381                  * without having to import itself.
 382                  */
 383                 return findTycon(t);
 384             }
 385             for(es=module(m).exports; nonNull(es); es=tl(es)) {
 386                 Cell e = hd(es);
 387                 if (isPair(e) && isTycon(fst(e)) && tycon(fst(e)).text==t)
 388                     return fst(e);
 389             }
 390             return NIL;
 391         }
 392         default : internal("findQualTycon2");
 393     }
 394 }
 395
 396 Tycon addPrimTycon(t,kind,ar,what,defn) /* add new primitive type constr   */
 397 Text   t;
 398 Kind   kind;
 399 Int    ar;
 400 Cell   what;
 401 Cell   defn; {
 402     Tycon tc        = newTycon(t);
 403     tycon(tc).line  = 0;
 404     tycon(tc).kind  = kind;
 405     tycon(tc).what  = what;
 406     tycon(tc).defn  = defn;
 407     tycon(tc).arity = ar;
 408     return tc;
 409 }
 410
 411 static List local insertTycon(tc,ts)    /* insert tycon tc into sorted list*/
 412 Tycon tc;                               /* ts                              */
 413 List  ts; {
 414     Cell   prev = NIL;
 415     Cell   curr = ts;
 416     String s    = textToStr(tycon(tc).text);
 417
 418     while (nonNull(curr) && strCompare(s,textToStr(tycon(hd(curr)).text))>=0) {
 419         if (hd(curr)==tc)               /* just in case we get duplicates! */
 420             return ts;
 421         prev = curr;
 422         curr = tl(curr);
 423     }
 424     if (nonNull(prev)) {
 425         tl(prev) = cons(tc,curr);
 426         return ts;
 427     }
 428     else
 429         return cons(tc,curr);
 430 }
 431
 432 List addTyconsMatching(pat,ts)          /* Add tycons matching pattern pat */
 433 String pat;                             /* to list of Tycons ts            */
 434 List   ts; {                            /* Null pattern matches every tycon*/
 435     Tycon tc;                           /* (Tycons with NIL kind excluded) */
 436     for (tc=TYCMIN; tc<tyconHw; ++tc)
 437         if (!pat || stringMatch(pat,textToStr(tycon(tc).text)))
 438             if (nonNull(tycon(tc).kind))
 439                 ts = insertTycon(tc,ts);
 440     return ts;
 441 }
 442
 443 /* --------------------------------------------------------------------------
 444  * Name storage:
 445  *
 446  * A Name represents a top level binding of a value to an identifier.
 447  * Such values may be a constructor function, a member function in a
 448  * class, a user-defined or primitive value/function.
 449  *
 450  * Names are indexed by Text values ... a very simple hash functions speeds
 451  * access to the table of Names and Name entries with the same hash value
 452  * are chained together, with the most recent entry at the front of the
 453  * list.
 454  * ------------------------------------------------------------------------*/
 455
 456 #define NAMEHSZ  256                            /* Size of Name hash table */
 457 #define nHash(x) ((x)%NAMEHSZ)                  /* hash fn :: Text->Int    */
 458 /*static*/Name   nameHw;                      /* next unused name        */
 459 static  Name     DEFTABLE(nameHash,NAMEHSZ);    /* Hash table storage      */
 460 struct  strName  DEFTABLE(tabName,NUM_NAME);    /* Name table storage      */
 461
 462 Name newName(t)                         /* add new name to name table      */
 463 Text t; {
 464     if (nameHw-NAMEMIN >= NUM_NAME) {
 465         ERRMSG(0) "Name storage space exhausted"
 466         EEND;
 467     }
 468     name(nameHw).text         = t;      /* clear new name record           */
 469     name(nameHw).line         = 0;
 470     name(nameHw).arity        = 0;
 471     name(nameHw).number       = EXECNAME;
 472     name(nameHw).defn         = NIL;
 473     name(nameHw).stgVar       = NIL;
 474     name(nameHw).type         = NIL;
 475     name(nameHw).primop       = 0;
 476     name(nameHw).mod          = currentModule;
 477     hashName(nameHw);
 478     module(currentModule).names=cons(nameHw,module(currentModule).names);
 479     return nameHw++;
 480 }
 481
 482 Name findName(t)                        /* locate name in name table       */
 483 Text t; {
 484     Name n = nameHash[nHash(t)];
 485
 486     while (nonNull(n) && name(n).text!=t) {
 487         n = name(n).nextNameHash;
 488     }
 489     assert(isNull(n) || (isName(n) && n < nameHw));
 490     return n;
 491 }
 492
 493 Name addName(nm)      /* Insert Name in name table - if no clash is caused */
 494 Name nm; {
 495     Name oldnm = findName(name(nm).text);
 496     if (isNull(oldnm)) {
 497         hashName(nm);
 498         module(currentModule).names=cons(nm,module(currentModule).names);
 499         return nm;
 500     } else {
 501         return oldnm;
 502     }
 503 }
 504
 505 static Void local hashName(nm)          /* Insert Name into hash table       */
 506 Name nm; {
 507     Text t = name(nm).text;
 508     Int  h = nHash(t);
 509     name(nm).nextNameHash = nameHash[h];
 510     nameHash[h]           = nm;
 511 }
 512
 513 Name findQualName(line,id) /* locate (possibly qualified) name in name table */
 514 Int  line;
 515 Cell id; {
 516     assert(isPair(id));
 517     switch (fst(id)) {
 518         case VARIDCELL :
 519         case VAROPCELL :
 520         case CONIDCELL :
 521         case CONOPCELL :
 522             return findName(textOf(id));
 523         case QUALIDENT : {
 524             Text   t  = qtextOf(id);
 525             Module m  = findQualifier(qmodOf(id));
 526             List   es = NIL;
 527             if (isNull(m)) return NIL;
 528             if (m==currentModule) {
 529                 /* The Haskell report (rightly) forbids this.
 530                  * We added it to let the Prelude refer to itself
 531                  * without having to import itself.
 532                  */
 533                 return findName(t);
 534             }
 535             for(es=module(m).exports; nonNull(es); es=tl(es)) {
 536                 Cell e = hd(es);
 537                 if (isName(e) && name(e).text==t)
 538                     return e;
 539                 else if (isPair(e) && DOTDOT==snd(e)) {
 540                     List subentities = NIL;
 541                     Cell c = fst(e);
 542                     if (isTycon(c)
 543                         && (tycon(c).what == DATATYPE
 544                             || tycon(c).what == NEWTYPE))
 545                         subentities = tycon(c).defn;
 546                     else if (isClass(c))
 547                         subentities = cclass(c).members;
 548                     for(; nonNull(subentities); subentities=tl(subentities)) {
 549                         assert(isName(hd(subentities)));
 550                         if (name(hd(subentities)).text == t)
 551                             return hd(subentities);
 552                     }
 553                 }
 554             }
 555             return NIL;
 556         }
 557         default : internal("findQualName2");
 558     }
 559 }
 560
 561 /* --------------------------------------------------------------------------
 562  * Primitive functions:
 563  * ------------------------------------------------------------------------*/
 564
 565 Name addPrimCfun(t,arity,no,rep)        /* add primitive constructor func  */
 566 Text t;
 567 Int  arity;
 568 Int  no;
 569 Int  rep; { /* Really AsmRep */
 570     Name n          = newName(t);
 571     name(n).arity   = arity;
 572     name(n).number  = cfunNo(no);
 573     name(n).type    = NIL;
 574     name(n).primop  = (void*)rep;
 575     return n;
 576 }
 577
 578 Int sfunPos(s,c)                        /* Find position of field with     */
 579 Name s;                                 /* selector s in constructor c.    */
 580 Name c; {
 581     List cns;
 582     cns = name(s).defn;
 583     for (; nonNull(cns); cns=tl(cns)) {
 584         if (fst(hd(cns))==c)
 585             return intOf(snd(hd(cns)));
 586     }
 587     internal("sfunPos");
 588     return 0;/*NOTREACHED*/
 589 }
 590
 591 static List local insertName(nm,ns)     /* insert name nm into sorted list */
 592 Name nm;                                /* ns                              */
 593 List ns; {
 594     Cell   prev = NIL;
 595     Cell   curr = ns;
 596     String s    = textToStr(name(nm).text);
 597
 598     while (nonNull(curr) && strCompare(s,textToStr(name(hd(curr)).text))>=0) {
 599         if (hd(curr)==nm)               /* just in case we get duplicates! */
 600             return ns;
 601         prev = curr;
 602         curr = tl(curr);
 603     }
 604     if (nonNull(prev)) {
 605         tl(prev) = cons(nm,curr);
 606         return ns;
 607     }
 608     else
 609         return cons(nm,curr);
 610 }
 611
 612 List addNamesMatching(pat,ns)           /* Add names matching pattern pat  */
 613 String pat;                             /* to list of names ns             */
 614 List   ns; {                            /* Null pattern matches every name */
 615     Name nm;                            /* (Names with NIL type, or hidden */
 616     for (nm=NAMEMIN; nm<nameHw; ++nm)   /* or invented names are excluded) */
 617         if (!inventedText(name(nm).text) && nonNull(name(nm).type)) {
 618             String str = textToStr(name(nm).text);
 619             if (str[0]!='_' && (!pat || stringMatch(pat,str)))
 620                 ns = insertName(nm,ns);
 621         }
 622     return ns;
 623 }
 624
 625 /* --------------------------------------------------------------------------
 626  * A simple string matching routine
 627  *     `*'    matches any sequence of zero or more characters
 628  *     `?'    matches any single character exactly
 629  *     `@str' matches the string str exactly (ignoring any special chars)
 630  *     `\c'   matches the character c only (ignoring special chars)
 631  *     c      matches the character c only
 632  * ------------------------------------------------------------------------*/
 633
 634 static Void local patternError(s)       /* report error in pattern         */
 635 String s; {
 636     ERRMSG(0) "%s in pattern", s
 637     EEND;
 638 }
 639
 640 static Bool local stringMatch(pat,str)  /* match string against pattern    */
 641 String pat;
 642 String str; {
 643
 644     for (;;)
 645         switch (*pat) {
 646             case '\0' : return (*str=='\0');
 647
 648             case '*'  : do {
 649                             if (stringMatch(pat+1,str))
 650                                 return TRUE;
 651                         } while (*str++);
 652                         return FALSE;
 653
 654             case '?'  : if (*str++=='\0')
 655                             return FALSE;
 656                         pat++;
 657                         break;
 658
 659             case '['  : {   Bool found = FALSE;
 660                             while (*++pat!='\0' && *pat!=']')
 661                                 if (!found && ( pat[0] == *str  ||
 662                                                (pat[1] == '-'   &&
 663                                                 pat[2] != ']'   &&
 664                                                 pat[2] != '\0'  &&
 665                                                 pat[0] <= *str  &&
 666                                                 pat[2] >= *str)))
 667
 668                                     found = TRUE;
 669                             if (*pat != ']')
 670                                 patternError("missing `]'");
 671                             if (!found)
 672                                 return FALSE;
 673                             pat++;
 674                             str++;
 675                         }
 676                         break;
 677
 678             case '\\' : if (*++pat == '\0')
 679                             patternError("extra trailing `\\'");
 680                         /*fallthru!*/
 681             default   : if (*pat++ != *str++)
 682                             return FALSE;
 683                         break;
 684         }
 685 }
 686
 687 /* --------------------------------------------------------------------------
 688  * Storage of type classes, instances etc...:
 689  * ------------------------------------------------------------------------*/
 690
 691 static Class classHw;                  /* next unused class                */
 692 static List  classes;                  /* list of classes in current scope */
 693 static Inst  instHw;                   /* next unused instance record      */
 694 #if USE_DICTHW
 695 static Int   dictHw;                   /* next unused dictionary number    */
 696 #endif
 697
 698 struct strClass DEFTABLE(tabClass,NUM_CLASSES); /* table of class records  */
 699 struct strInst far *tabInst;           /* (pointer to) table of instances  */
 700
 701 Class newClass(t)                      /* add new class to class table     */
 702 Text t; {
 703     if (classHw-CLASSMIN >= NUM_CLASSES) {
 704         ERRMSG(0) "Class storage space exhausted"
 705         EEND;
 706     }
 707     cclass(classHw).text      = t;
 708     cclass(classHw).arity     = 0;
 709     cclass(classHw).kinds     = NIL;
 710     cclass(classHw).head      = NIL;
 711     cclass(classHw).dcon      = NIL;
 712     cclass(classHw).supers    = NIL;
 713     cclass(classHw).dsels     = NIL;
 714     cclass(classHw).members   = NIL;
 715     cclass(classHw).dbuild    = NIL;
 716     cclass(classHw).defaults  = NIL;
 717     cclass(classHw).instances = NIL;
 718     classes=cons(classHw,classes);
 719     cclass(classHw).mod       = currentModule;
 720     module(currentModule).classes=cons(classHw,module(currentModule).classes);
 721     return classHw++;
 722 }
 723
 724 Class classMax() {                      /* Return max Class in use ...     */
 725     return classHw;                     /* This is a bit ugly, but it's not*/
 726 }                                       /* worth a lot of effort right now */
 727
 728 Class findClass(t)                     /* look for named class in table    */
 729 Text t; {
 730     Class cl;
 731     List cs;
 732     for (cs=classes; nonNull(cs); cs=tl(cs)) {
 733         cl=hd(cs);
 734         if (cclass(cl).text==t)
 735             return cl;
 736     }
 737     return NIL;
 738 }
 739
 740 Class addClass(c)        /* Insert Class in class list - if no clash caused */
 741 Class c; {
 742     Class oldc = findClass(cclass(c).text);
 743     if (isNull(oldc)) {
 744         classes=cons(c,classes);
 745         module(currentModule).classes=cons(c,module(currentModule).classes);
 746         return c;
 747     } else
 748         return oldc;
 749 }
 750
 751 Class findQualClass(c) /* look for (possibly qualified) class in class list */
 752 Cell c; {
 753     if (!isQualIdent(c)) {
 754         return findClass(textOf(c));
 755     } else {
 756         Text   t = qtextOf(c);
 757         Module m = findQualifier(qmodOf(c));
 758         List   es = NIL;
 759         if (isNull(m)) return NIL;
 760         for(es=module(m).exports; nonNull(es); es=tl(es)) {
 761             Cell e = hd(es);
 762             if (isPair(e) && isClass(fst(e)) && cclass(fst(e)).text==t)
 763                 return fst(e);
 764         }
 765     }
 766     return NIL;
 767 }
 768
 769 Inst newInst() {                       /* add new instance to table        */
 770     if (instHw-INSTMIN >= NUM_INSTS) {
 771         ERRMSG(0) "Instance storage space exhausted"
 772         EEND;
 773     }
 774     inst(instHw).kinds      = NIL;
 775     inst(instHw).head       = NIL;
 776     inst(instHw).specifics  = NIL;
 777     inst(instHw).implements = NIL;
 778     inst(instHw).builder    = NIL;
 779     inst(instHw).mod        = currentModule;
 780
 781     return instHw++;
 782 }
 783
 784 Inst findFirstInst(tc)                  /* look for 1st instance involving */
 785 Tycon tc; {                             /* the type constructor tc         */
 786     return findNextInst(tc,INSTMIN-1);
 787 }
 788
 789 Inst findNextInst(tc,in)                /* look for next instance involving*/
 790 Tycon tc;                               /* the type constructor tc         */
 791 Inst  in; {                             /* starting after instance in      */
 792     while (++in < instHw) {
 793         Cell pi = inst(in).head;
 794         for (; isAp(pi); pi=fun(pi))
 795             if (typeInvolves(arg(pi),tc))
 796                 return in;
 797     }
 798     return NIL;
 799 }
 800
 801 static Bool local typeInvolves(ty,tc)   /* Test to see if type ty involves */
 802 Type ty;                                /* type constructor/tuple tc.      */
 803 Type tc; {
 804     return (ty==tc)
 805         || (isAp(ty) && (typeInvolves(fun(ty),tc)
 806                          || typeInvolves(arg(ty),tc)));
 807 }
 808
 809 /* --------------------------------------------------------------------------
 810  * Control stack:
 811  *
 812  * Various parts of the system use a stack of cells.  Most of the stack
 813  * operations are defined as macros, expanded inline.
 814  * ------------------------------------------------------------------------*/
 815
 816 Cell DEFTABLE(cellStack,NUM_STACK); /* Storage for cells on stack          */
 817 StackPtr sp;                        /* stack pointer                       */
 818
 819 Void hugsStackOverflow() {          /* Report stack overflow               */
 820     ERRMSG(0) "Control stack overflow"
 821     EEND;
 822 }
 823
 824 /* --------------------------------------------------------------------------
 825  * Module storage:
 826  *
 827  * A Module represents a user defined module.
 828  *
 829  * Note: there are now two lookup mechanisms in the system:
 830  *
 831  * 1) The exports from a module are stored in a big list.
 832  *    We resolve qualified names, and import lists by linearly scanning
 833  *    through this list.
 834  *
 835  * 2) Unqualified imports and local definitions for the current module
 836  *    are stored in hash tables (tyconHash and nameHash) or linear lists
 837  *    (classes).
 838  *
 839  * ------------------------------------------------------------------------*/
 840
 841 static  Module   moduleHw;              /* next unused Module              */
 842 struct  Module   DEFTABLE(tabModule,NUM_MODULE); /* Module storage         */
 843 Module  currentModule;                  /* Module currently being processed*/
 844
 845 Bool isValidModule(m)                  /* is m a legitimate module id?     */
 846 Module m; {
 847     return (MODMIN <= m && m < moduleHw);
 848 }
 849
 850 Module newModule(t)                     /* add new module to module table  */
 851 Text t; {
 852     if (moduleHw-MODMIN >= NUM_MODULE) {
 853         ERRMSG(0) "Module storage space exhausted"
 854         EEND;
 855     }
 856     module(moduleHw).text          = t; /* clear new module record         */
 857     module(moduleHw).qualImports   = NIL;
 858     module(moduleHw).exports       = NIL;
 859     module(moduleHw).tycons        = NIL;
 860     module(moduleHw).names         = NIL;
 861     module(moduleHw).classes       = NIL;
 862     module(moduleHw).objectFile    = 0;
 863     return moduleHw++;
 864 }
 865
 866 Module findModule(t)                    /* locate Module in module table  */
 867 Text t; {
 868     Module m;
 869     for(m=MODMIN; m<moduleHw; ++m) {
 870         if (module(m).text==t) {
 871             return m;
 872         }
 873     }
 874     return NIL;
 875 }
 876
 877 Module findModid(c)                    /* Find module by name or filename  */
 878 Cell c; {
 879     switch (whatIs(c)) {
 880         case STRCELL   : { Script s = scriptThisFile(snd(c));
 881                            return (s==-1) ? NIL : moduleOfScript(s);
 882                          }
 883         case CONIDCELL : return findModule(textOf(c));
 884         default        : internal("findModid");
 885     }
 886 }
 887
 888 static local Module findQualifier(t)    /* locate Module in import list   */
 889 Text t; {
 890     Module ms;
 891     if (t==module(modulePreludeHugs).text) {
 892         /* The Haskell report (rightly) forbids this.
 893          * We added it to let the Prelude refer to itself
 894          * without having to import itself.
 895          */
 896         return modulePreludeHugs;
 897     }
 898     for (ms=module(currentModule).qualImports; nonNull(ms); ms=tl(ms)) {
 899         if (textOf(fst(hd(ms)))==t) {
 900             return snd(hd(ms));
 901         }
 902     }
 903     return NIL;
 904 }
 905
 906 Void setCurrModule(m)              /* set lookup tables for current module */
 907 Module m; {
 908     Int i;
 909     if (m!=currentModule) {
 910         currentModule = m; /* This is the only assignment to currentModule */
 911         for (i=0; i<TYCONHSZ; ++i) {
 912             tyconHash[i] = NIL;
 913         }
 914         mapProc(hashTycon,module(m).tycons);
 915         for (i=0; i<NAMEHSZ; ++i) {
 916             nameHash[i] = NIL;
 917         }
 918         mapProc(hashName,module(m).names);
 919         classes = module(m).classes;
 920     }
 921 }
 922
 923 /* --------------------------------------------------------------------------
 924  * Script file storage:
 925  *
 926  * script files are read into the system one after another.  The state of
 927  * the stored data structures (except the garbage-collected heap) is recorded
 928  * before reading a new script.  In the event of being unable to read the
 929  * script, or if otherwise requested, the system can be restored to its
 930  * original state immediately before the file was read.
 931  * ------------------------------------------------------------------------*/
 932
 933 typedef struct {                       /* record of storage state prior to */
 934     Text  file;                        /* reading script/module            */
 935     Text  textHw;
 936     Text  nextNewText;
 937     Text  nextNewDText;
 938     Int   syntaxHw;
 939     Module moduleHw;
 940     Tycon tyconHw;
 941     Name  nameHw;
 942     Class classHw;
 943     Inst  instHw;
 944 #if USE_DICTHW
 945     Int   dictHw;
 946 #endif
 947 #if TREX
 948     Ext   extHw;
 949 #endif
 950 } script;
 951
 952 #ifdef  DEBUG_SHOWUSE
 953 static Void local showUse(msg,val,mx)
 954 String msg;
 955 Int val, mx; {
 956     Printf("%6s : %d of %d (%d%%)\n",msg,val,mx,(100*val)/mx);
 957 }
 958 #endif
 959
 960 static Script scriptHw;                 /* next unused script number       */
 961 static script scripts[NUM_SCRIPTS];     /* storage for script records      */
 962
 963 Script startNewScript(f)                /* start new script, keeping record */
 964 String f; {                             /* of status for later restoration  */
 965     if (scriptHw >= NUM_SCRIPTS) {
 966         ERRMSG(0) "Too many script files in use"
 967         EEND;
 968     }
 969 #ifdef DEBUG_SHOWUSE
 970     showUse("Text",   textHw,           NUM_TEXT);
 971     showUse("Syntax", syntaxHw,         NUM_SYNTAX);
 972     showUse("Module", moduleHw-MODMIN,  NUM_MODULE);
 973     showUse("Tycon",  tyconHw-TYCMIN,   NUM_TYCON);
 974     showUse("Name",   nameHw-NAMEMIN,   NUM_NAME);
 975     showUse("Class",  classHw-CLASSMIN, NUM_CLASSES);
 976     showUse("Inst",   instHw-INSTMIN,   NUM_INSTS);
 977 #if TREX
 978     showUse("Ext",    extHw-EXTMIN,     NUM_EXT);
 979 #endif
 980 #endif
 981
 982     scripts[scriptHw].file         = findText( f ? f : "<nofile>" );
 983     scripts[scriptHw].textHw       = textHw;
 984     scripts[scriptHw].nextNewText  = nextNewText;
 985     scripts[scriptHw].nextNewDText = nextNewDText;
 986     scripts[scriptHw].syntaxHw     = syntaxHw;
 987     scripts[scriptHw].moduleHw     = moduleHw;
 988     scripts[scriptHw].tyconHw      = tyconHw;
 989     scripts[scriptHw].nameHw       = nameHw;
 990     scripts[scriptHw].classHw      = classHw;
 991     scripts[scriptHw].instHw       = instHw;
 992 #if USE_DICTHW
 993     scripts[scriptHw].dictHw       = dictHw;
 994 #endif
 995 #if TREX
 996     scripts[scriptHw].extHw        = extHw;
 997 #endif
 998     return scriptHw++;
 999 }
1000
1001 #define scriptThis(nm,t,tag)            Script nm(x)                       \
1002                                         t x; {                             \
1003                                             Script s=0;                    \
1004                                             while (s<scriptHw              \
1005                                                    && x>=scripts[s].tag)   \
1006                                                 s++;                       \
1007                                             return s;                      \
1008                                         }
1009 scriptThis(scriptThisName,Name,nameHw)
1010 scriptThis(scriptThisTycon,Tycon,tyconHw)
1011 scriptThis(scriptThisInst,Inst,instHw)
1012 scriptThis(scriptThisClass,Class,classHw)
1013 #undef scriptThis
1014
1015 Module lastModule() {              /* Return module in current script file */
1016     return (moduleHw-1);
1017 }
1018
1019 static Module local moduleOfScript(s)
1020 Script s; {
1021     return scripts[s-1].moduleHw;
1022 }
1023
1024 String fileOfModule(m)
1025 Module m; {
1026     Script s;
1027     for(s=0; s<scriptHw; ++s) {
1028         if (scripts[s].moduleHw == m) {
1029             return textToStr(scripts[s].file);
1030         }
1031     }
1032     return 0;
1033 }
1034
1035 static Script local scriptThisFile(f)
1036 Text f; {
1037     Script s;
1038     for (s=0; s < scriptHw; ++s) {
1039         if (scripts[s].file == f) {
1040             return s+1;
1041         }
1042     }
1043     return (-1);
1044 }
1045
1046 Void dropScriptsFrom(sno)               /* Restore storage to state prior  */
1047 Script sno; {                           /* to reading script sno           */
1048     if (sno<scriptHw) {                 /* is there anything to restore?   */
1049         int i;
1050         textHw       = scripts[sno].textHw;
1051         nextNewText  = scripts[sno].nextNewText;
1052         nextNewDText = scripts[sno].nextNewDText;
1053         syntaxHw     = scripts[sno].syntaxHw;
1054         tyconHw      = scripts[sno].tyconHw;
1055         nameHw       = scripts[sno].nameHw;
1056         classHw      = scripts[sno].classHw;
1057         instHw       = scripts[sno].instHw;
1058 #if USE_DICTHW
1059         dictHw       = scripts[sno].dictHw;
1060 #endif
1061 #if TREX
1062         extHw        = scripts[sno].extHw;
1063 #endif
1064
1065         for (i=moduleHw; i >= scripts[sno].moduleHw; --i) {
1066             if (module(i).objectFile) {
1067                 printf("closing objectFile for module %d\n",i);
1068                 dlclose(module(i).objectFile);
1069             }
1070         }
1071         moduleHw = scripts[sno].moduleHw;
1072
1073         for (i=0; i<TEXTHSZ; ++i) {
1074             int j = 0;
1075             while (j<NUM_TEXTH && textHash[i][j]!=NOTEXT
1076                                && textHash[i][j]<textHw)
1077                 ++j;
1078             if (j<NUM_TEXTH)
1079                 textHash[i][j] = NOTEXT;
1080         }
1081
1082         currentModule=NIL;
1083         for (i=0; i<TYCONHSZ; ++i) {
1084             tyconHash[i] = NIL;
1085         }
1086         for (i=0; i<NAMEHSZ; ++i) {
1087             nameHash[i] = NIL;
1088         }
1089
1090         for (i=CLASSMIN; i<classHw; i++) {
1091             List ins = cclass(i).instances;
1092             List is  = NIL;
1093
1094             while (nonNull(ins)) {
1095                 List temp = tl(ins);
1096                 if (hd(ins)<instHw) {
1097                     tl(ins) = is;
1098                     is      = ins;
1099                 }
1100                 ins = temp;
1101             }
1102             cclass(i).instances = rev(is);
1103         }
1104
1105         scriptHw = sno;
1106     }
1107 }
1108
1109 /* --------------------------------------------------------------------------
1110  * Heap storage:
1111  *
1112  * Provides a garbage collectable heap for storage of expressions etc.
1113  *
1114  * Now incorporates a flat resource:  A two-space collected extension of
1115  * the heap that provides storage for contiguous arrays of Cell storage,
1116  * cooperating with the garbage collection mechanisms for the main heap.
1117  * ------------------------------------------------------------------------*/
1118
1119 Int     heapSize = DEFAULTHEAP;         /* number of cells in heap         */
1120 Heap    heapFst;                        /* array of fst component of pairs */
1121 Heap    heapSnd;                        /* array of snd component of pairs */
1122 Heap    heapTopFst;
1123 Heap    heapTopSnd;
1124 Bool    consGC = TRUE;                  /* Set to FALSE to turn off gc from*/
1125                                         /* C stack; use with extreme care! */
1126 Int     cellsRecovered;                 /* number of cells recovered       */
1127
1128 static  Cell freeList;                  /* free list of unused cells       */
1129 static  Cell lsave, rsave;              /* save components of pair         */
1130
1131 #if GC_STATISTICS
1132
1133 static Int markCount, stackRoots;
1134
1135 #define initStackRoots() stackRoots = 0
1136 #define recordStackRoot() stackRoots++
1137
1138 #define startGC()       \
1139     if (gcMessages) {   \
1140         printf("\n");   \
1141         fflush(stdout); \
1142     }
1143 #define endGC()         \
1144     if (gcMessages) {   \
1145         printf("\n");   \
1146         fflush(stdout); \
1147     }
1148
1149 #define start()      markCount = 0
1150 #define end(thing,rs) \
1151     if (gcMessages) { \
1152         printf("GC: %-18s: %4d cells, %4d roots.\n", thing, markCount, rs); \
1153         fflush(stdout); \
1154     }
1155 #define recordMark() markCount++
1156
1157 #else /* !GC_STATISTICS */
1158
1159 #define startGC()
1160 #define endGC()
1161
1162 #define initStackRoots()
1163 #define recordStackRoot()
1164
1165 #define start()
1166 #define end(thing,root)
1167 #define recordMark()
1168
1169 #endif /* !GC_STATISTICS */
1170
1171 Cell pair(l,r)                          /* Allocate pair (l, r) from       */
1172 Cell l, r; {                            /* heap, garbage collecting first  */
1173     Cell c = freeList;                  /* if necessary ...                */
1174
1175     if (isNull(c)) {
1176         lsave = l;
1177         rsave = r;
1178         garbageCollect();
1179         l     = lsave;
1180         lsave = NIL;
1181         r     = rsave;
1182         rsave = NIL;
1183         c     = freeList;
1184     }
1185     freeList = snd(freeList);
1186     fst(c)   = l;
1187     snd(c)   = r;
1188     return c;
1189 }
1190
1191 Void overwrite(dst,src)                 /* overwrite dst cell with src cell*/
1192 Pair dst, src; {                        /* both *MUST* be pairs            */
1193     assert(isPair(dst) && isPair(src));
1194     fst(dst) = fst(src);
1195     snd(dst) = snd(src);
1196 }
1197
1198 Void overwrite2(dst,src1,src2)          /* overwrite dst cell with src cell*/
1199 Pair dst;
1200 Cell src1, src2; {
1201     assert(isPair(dst));
1202     fst(dst) = src1;
1203     snd(dst) = src2;
1204 }
1205
1206 static Int *marks;
1207 static Int marksSize;
1208
1209 Cell markExpr(c)                        /* External interface to markCell  */
1210 Cell c; {
1211     return isGenPair(c) ? markCell(c) : c;
1212 }
1213
1214 static Cell local markCell(c)           /* Traverse part of graph marking  */
1215 Cell c; {                               /* cells reachable from given root */
1216                                         /* markCell(c) is only called if c */
1217                                         /* is a pair                       */
1218     {   register place = placeInSet(c);
1219         register mask  = maskInSet(c);
1220         if (marks[place]&mask)
1221             return c;
1222         else {
1223             marks[place] |= mask;
1224             recordMark();
1225         }
1226     }
1227
1228     if (isGenPair(fst(c))) {
1229         fst(c) = markCell(fst(c));
1230         markSnd(c);
1231     }
1232     else if (isNull(fst(c)) || fst(c)>=BCSTAG)
1233         markSnd(c);
1234
1235     return c;
1236 }
1237
1238 static Void local markSnd(c)            /* Variant of markCell used to     */
1239 Cell c; {                               /* update snd component of cell    */
1240     Cell t;                             /* using tail recursion            */
1241
1242 ma: t = c;                              /* Keep pointer to original pair   */
1243     c = snd(c);
1244 mb: if (!isPair(c))
1245         return;
1246
1247     {   register place = placeInSet(c);
1248         register mask  = maskInSet(c);
1249         if (marks[place]&mask)
1250             return;
1251         else {
1252             marks[place] |= mask;
1253             recordMark();
1254         }
1255     }
1256
1257     if (isGenPair(fst(c))) {
1258         fst(c) = markCell(fst(c));
1259         goto ma;
1260     }
1261     else if (isNull(fst(c)) || fst(c)>=BCSTAG)
1262         goto ma;
1263     return;
1264 }
1265
1266 Void markWithoutMove(n)                 /* Garbage collect cell at n, as if*/
1267 Cell n; {                               /* it was a cell ref, but don't    */
1268                                         /* move cell so we don't have      */
1269                                         /* to modify the stored value of n */
1270     if (isGenPair(n)) {
1271         recordStackRoot();
1272         markCell(n);
1273     }
1274 }
1275
1276 Void garbageCollect()     {             /* Run garbage collector ...       */
1277     Bool breakStat = breakOn(FALSE);    /* disable break checking          */
1278     Int i,j;
1279     register Int mask;
1280     register Int place;
1281     Int      recovered;
1282     jmp_buf  regs;                      /* save registers on stack         */
1283     setjmp(regs);
1284
1285     gcStarted();
1286     for (i=0; i<marksSize; ++i)         /* initialise mark set to empty    */
1287         marks[i] = 0;
1288
1289     everybody(MARK);                    /* Mark all components of system   */
1290
1291     gcScanning();                       /* scan mark set                   */
1292     mask      = 1;
1293     place     = 0;
1294     recovered = 0;
1295     j         = 0;
1296     freeList = NIL;
1297     for (i=1; i<=heapSize; i++) {
1298         if ((marks[place] & mask) == 0) {
1299             snd(-i)  = freeList;
1300             fst(-i)  = FREECELL;
1301             freeList = -i;
1302             recovered++;
1303         }
1304         mask <<= 1;
1305         if (++j == bitsPerWord) {
1306             place++;
1307             mask = 1;
1308             j    = 0;
1309         }
1310     }
1311
1312     gcRecovered(recovered);
1313     breakOn(breakStat);                 /* restore break trapping if nec.  */
1314
1315     /* can only return if freeList is nonempty on return. */
1316     if (recovered<minRecovery || isNull(freeList)) {
1317         ERRMSG(0) "Garbage collection fails to reclaim sufficient space"
1318         EEND;
1319     }
1320     cellsRecovered = recovered;
1321 }
1322
1323 /* --------------------------------------------------------------------------
1324  * Code for saving last expression entered:
1325  *
1326  * This is a little tricky because some text values (e.g. strings or variable
1327  * names) may not be defined or have the same value when the expression is
1328  * recalled.  These text values are therefore saved in the top portion of
1329  * the text table.
1330  * ------------------------------------------------------------------------*/
1331
1332 static Cell lastExprSaved;              /* last expression to be saved     */
1333
1334 Void setLastExpr(e)                     /* save expression for later recall*/
1335 Cell e; {
1336     lastExprSaved = NIL;                /* in case attempt to save fails   */
1337     savedText     = NUM_TEXT;
1338     lastExprSaved = lowLevelLastIn(e);
1339 }
1340
1341 static Cell local lowLevelLastIn(c)     /* Duplicate expression tree (i.e. */
1342 Cell c; {                               /* acyclic graph) for later recall */
1343     if (isPair(c))                      /* Duplicating any text strings    */
1344         if (isBoxTag(fst(c)))           /* in case these are lost at some  */
1345             switch (fst(c)) {           /* point before the expr is reused */
1346                 case VARIDCELL :
1347                 case VAROPCELL :
1348                 case DICTVAR   :
1349                 case CONIDCELL :
1350                 case CONOPCELL :
1351                 case STRCELL   : return pair(fst(c),saveText(textOf(c)));
1352                 default        : return pair(fst(c),snd(c));
1353             }
1354         else
1355             return pair(lowLevelLastIn(fst(c)),lowLevelLastIn(snd(c)));
1356 #if TREX
1357     else if (isExt(c))
1358         return pair(EXTCOPY,saveText(extText(c)));
1359 #endif
1360     else
1361         return c;
1362 }
1363
1364 Cell getLastExpr() {                    /* recover previously saved expr   */
1365     return lowLevelLastOut(lastExprSaved);
1366 }
1367
1368 static Cell local lowLevelLastOut(c)    /* As with lowLevelLastIn() above  */
1369 Cell c; {                               /* except that Cells refering to   */
1370     if (isPair(c))                      /* Text values are restored to     */
1371         if (isBoxTag(fst(c)))           /* appropriate values              */
1372             switch (fst(c)) {
1373                 case VARIDCELL :
1374                 case VAROPCELL :
1375                 case DICTVAR   :
1376                 case CONIDCELL :
1377                 case CONOPCELL :
1378                 case STRCELL   : return pair(fst(c),
1379                                              findText(text+intValOf(c)));
1380 #if TREX
1381                 case EXTCOPY   : return mkExt(findText(text+intValOf(c)));
1382 #endif
1383                 default        : return pair(fst(c),snd(c));
1384             }
1385         else
1386             return pair(lowLevelLastOut(fst(c)),lowLevelLastOut(snd(c)));
1387     else
1388         return c;
1389 }
1390
1391 /* --------------------------------------------------------------------------
1392  * Miscellaneous operations on heap cells:
1393  * ------------------------------------------------------------------------*/
1394
1395 /* profiling suggests that the number of calls to whatIs() is typically    */
1396 /* rather high.  The recoded version below attempts to improve the average */
1397 /* performance for whatIs() using a binary search for part of the analysis */
1398
1399 Cell whatIs(c)                         /* identify type of cell            */
1400 register Cell c; {
1401     if (isPair(c)) {
1402         register Cell fstc = fst(c);
1403         return isTag(fstc) ? fstc : AP;
1404     }
1405     if (c<TUPMIN)    return c;
1406     if (c>=INTMIN)   return INTCELL;
1407
1408     if (c>=NAMEMIN) if (c>=CLASSMIN)    if (c>=CHARMIN) return CHARCELL;
1409                                         else            return CLASS;
1410                     else                if (c>=INSTMIN) return INSTANCE;
1411                                         else            return NAME;
1412     else            if (c>=MODMIN)      if (c>=TYCMIN)  return TYCON;
1413                                         else            return MODULE;
1414                     else                if (c>=OFFMIN)  return OFFSET;
1415 #if TREX
1416                                         else if (c>=EXTMIN) return EXT;
1417 #endif
1418                                         else                return TUPLE;
1419
1420 /*  if (isPair(c)) {
1421         register Cell fstc = fst(c);
1422         return isTag(fstc) ? fstc : AP;
1423     }
1424     if (c>=CHARMIN)  return CHARCELL;
1425     if (c>=CLASSMIN) return CLASS;
1426     if (c>=INSTMIN)  return INSTANCE;
1427     if (c>=NAMEMIN)  return NAME;
1428     if (c>=TYCMIN)   return TYCON;
1429     if (c>=MODMIN)   return MODULE;
1430     if (c>=OFFMIN)   return OFFSET;
1431 #if TREX
1432     if (c>=EXTMIN)   return EXT;
1433 #endif
1434     if (c>=TUPMIN)   return TUPLE;
1435     return c;*/
1436 }
1437
1438 #if DEBUG_PRINTER
1439 /* A very, very simple printer.
1440  * Output is uglier than from printExp - but the printer is more
1441  * robust and can be used on any data structure irrespective of
1442  * its type.
1443  */
1444 Void print Args((Cell, Int));
1445 Void print(c, depth)
1446 Cell c;
1447 Int  depth; {
1448     if (0 == depth) {
1449         Printf("...");
1450     } else {
1451         Int tag = whatIs(c);
1452         switch (tag) {
1453         case AP:
1454                 Putchar('(');
1455                 print(fst(c), depth-1);
1456                 Putchar(',');
1457                 print(snd(c), depth-1);
1458                 Putchar(')');
1459                 break;
1460         case FREECELL:
1461                 Printf("free(%d)", c);
1462                 break;
1463         case INTCELL:
1464                 Printf("int(%d)", intOf(c));
1465                 break;
1466         case BIGCELL:
1467                 Printf("bignum(%s)", bignumToString(c));
1468                 break;
1469         case CHARCELL:
1470                 Printf("char('%c')", charOf(c));
1471                 break;
1472         case PTRCELL:
1473                 Printf("ptr(%p)",ptrOf(c));
1474                 break;
1475         case CLASS:
1476                 Printf("class(%d)", c-CLASSMIN);
1477                 if (CLASSMIN <= c && c < classHw) {
1478                     Printf("=\"%s\"", textToStr(cclass(c).text));
1479                 }
1480                 break;
1481         case INSTANCE:
1482                 Printf("instance(%d)", c - INSTMIN);
1483                 break;
1484         case NAME:
1485                 Printf("name(%d)", c-NAMEMIN);
1486                 if (NAMEMIN <= c && c < nameHw) {
1487                     Printf("=\"%s\"", textToStr(name(c).text));
1488                 }
1489                 break;
1490         case TYCON:
1491                 Printf("tycon(%d)", c-TYCMIN);
1492                 if (TYCMIN <= c && c < tyconHw)
1493                     Printf("=\"%s\"", textToStr(tycon(c).text));
1494                 break;
1495         case MODULE:
1496                 Printf("module(%d)", c - MODMIN);
1497                 break;
1498         case OFFSET:
1499                 Printf("Offset %d", offsetOf(c));
1500                 break;
1501         case TUPLE:
1502                 Printf("Tuple %d", tupleOf(c));
1503                 break;
1504         case POLYTYPE:
1505                 Printf("Polytype");
1506                 print(snd(c),depth-1);
1507                 break;
1508         case RANK2:
1509                 Printf("Rank2(");
1510                 if (isPair(snd(c)) && isInt(fst(snd(c)))) {
1511                     Printf("%d ", intOf(fst(snd(c))));
1512                     print(snd(snd(c)),depth-1);
1513                 } else {
1514                     print(snd(c),depth-1);
1515                 }
1516                 Printf(")");
1517                 break;
1518         case NIL:
1519                 Printf("NIL");
1520                 break;
1521         case WILDCARD:
1522                 Printf("_");
1523                 break;
1524         case STAR:
1525                 Printf("STAR");
1526                 break;
1527         case DOTDOT:
1528                 Printf("DOTDOT");
1529                 break;
1530         case DICTVAR:
1531                 Printf("{dict %d}",textOf(c));
1532                 break;
1533         case VARIDCELL:
1534         case VAROPCELL:
1535         case CONIDCELL:
1536         case CONOPCELL:
1537                 Printf("{id %s}",textToStr(textOf(c)));
1538                 break;
1539         case QUALIDENT:
1540                 Printf("{qid %s.%s}",textToStr(qmodOf(c)),textToStr(qtextOf(c)));
1541                 break;
1542         case LETREC:
1543                 Printf("LetRec(");
1544                 print(fst(snd(c)),depth-1);
1545                 Putchar(',');
1546                 print(snd(snd(c)),depth-1);
1547                 Putchar(')');
1548                 break;
1549         case LAMBDA:
1550                 Printf("Lambda(");
1551                 print(snd(c),depth-1);
1552                 Putchar(')');
1553                 break;
1554         case FINLIST:
1555                 Printf("FinList(");
1556                 print(snd(c),depth-1);
1557                 Putchar(')');
1558                 break;
1559         case COMP:
1560                 Printf("Comp(");
1561                 print(fst(snd(c)),depth-1);
1562                 Putchar(',');
1563                 print(snd(snd(c)),depth-1);
1564                 Putchar(')');
1565                 break;
1566         case ASPAT:
1567                 Printf("AsPat(");
1568                 print(fst(snd(c)),depth-1);
1569                 Putchar(',');
1570                 print(snd(snd(c)),depth-1);
1571                 Putchar(')');
1572                 break;
1573         case FROMQUAL:
1574                 Printf("FromQual(");
1575                 print(fst(snd(c)),depth-1);
1576                 Putchar(',');
1577                 print(snd(snd(c)),depth-1);
1578                 Putchar(')');
1579                 break;
1580         case STGVAR:
1581                 Printf("StgVar%d=",-c);
1582                 print(snd(c), depth-1);
1583                 break;
1584         case STGAPP:
1585                 Printf("StgApp(");
1586                 print(fst(snd(c)),depth-1);
1587                 Putchar(',');
1588                 print(snd(snd(c)),depth-1);
1589                 Putchar(')');
1590                 break;
1591         case STGPRIM:
1592                 Printf("StgPrim(");
1593                 print(fst(snd(c)),depth-1);
1594                 Putchar(',');
1595                 print(snd(snd(c)),depth-1);
1596                 Putchar(')');
1597                 break;
1598         case STGCON:
1599                 Printf("StgCon(");
1600                 print(fst(snd(c)),depth-1);
1601                 Putchar(',');
1602                 print(snd(snd(c)),depth-1);
1603                 Putchar(')');
1604                 break;
1605         case PRIMCASE:
1606                 Printf("PrimCase(");
1607                 print(fst(snd(c)),depth-1);
1608                 Putchar(',');
1609                 print(snd(snd(c)),depth-1);
1610                 Putchar(')');
1611                 break;
1612         default:
1613                 if (isBoxTag(tag)) {
1614                     Printf("Tag(%d)=%d", c, tag);
1615                 } else if (isConTag(tag)) {
1616                     Printf("%d@(%d,",c,tag);
1617                     print(snd(c), depth-1);
1618                     Putchar(')');
1619                     break;
1620                 } else if (c == tag) {
1621                     Printf("Tag(%d)", c);
1622                 } else {
1623                     Printf("Tag(%d)=%d", c, tag);
1624                 }
1625                 break;
1626         }
1627     }
1628     FlushStdout();
1629 }
1630 #endif
1631
1632 Bool isVar(c)                           /* is cell a VARIDCELL/VAROPCELL ? */
1633 Cell c; {                               /* also recognises DICTVAR cells   */
1634     return isPair(c) &&
1635                (fst(c)==VARIDCELL || fst(c)==VAROPCELL || fst(c)==DICTVAR);
1636 }
1637
1638 Bool isCon(c)                          /* is cell a CONIDCELL/CONOPCELL ?  */
1639 Cell c; {
1640     return isPair(c) && (fst(c)==CONIDCELL || fst(c)==CONOPCELL);
1641 }
1642
1643 Bool isQVar(c)                        /* is cell a [un]qualified varop/id? */
1644 Cell c; {
1645     if (!isPair(c)) return FALSE;
1646     switch (fst(c)) {
1647         case VARIDCELL  :
1648         case VAROPCELL  : return TRUE;
1649
1650         case QUALIDENT  : return isVar(snd(snd(c)));
1651
1652         default         : return FALSE;
1653     }
1654 }
1655
1656 Bool isQCon(c)                         /*is cell a [un]qualified conop/id? */
1657 Cell c; {
1658     if (!isPair(c)) return FALSE;
1659     switch (fst(c)) {
1660         case CONIDCELL  :
1661         case CONOPCELL  : return TRUE;
1662
1663         case QUALIDENT  : return isCon(snd(snd(c)));
1664
1665         default         : return FALSE;
1666     }
1667 }
1668
1669 Bool isQualIdent(c)                    /* is cell a qualified identifier?  */
1670 Cell c; {
1671     return isPair(c) && (fst(c)==QUALIDENT);
1672 }
1673
1674 Bool isIdent(c)                        /* is cell an identifier?           */
1675 Cell c; {
1676     if (!isPair(c)) return FALSE;
1677     switch (fst(c)) {
1678         case VARIDCELL  :
1679         case VAROPCELL  :
1680         case CONIDCELL  :
1681         case CONOPCELL  : return TRUE;
1682
1683         case QUALIDENT  : return TRUE;
1684
1685         default         : return FALSE;
1686     }
1687 }
1688
1689 Bool isInt(c)                          /* cell holds integer value?        */
1690 Cell c; {
1691     return isSmall(c) || (isPair(c) && fst(c)==INTCELL);
1692 }
1693
1694 Int intOf(c)                           /* find integer value of cell?      */
1695 Cell c; {
1696     assert(isInt(c));
1697     return isPair(c) ? (Int)(snd(c)) : (Int)(c-INTZERO);
1698 }
1699
1700 Cell mkInt(n)                          /* make cell representing integer   */
1701 Int n; {
1702     return isSmall(INTZERO+n) ? INTZERO+n : pair(INTCELL,n);
1703 }
1704
1705 #if PTR_ON_HEAP
1706 #if SIZEOF_INTP == SIZEOF_INT
1707 typedef union {Int i; Ptr p;} IntOrPtr;
1708 Cell mkPtr(p)
1709 Ptr p;
1710 {
1711     IntOrPtr x;
1712     x.p = p;
1713     return pair(PTRCELL,x.i);
1714 }
1715
1716 Ptr ptrOf(c)
1717 Cell c;
1718 {
1719     IntOrPtr x;
1720     assert(isPtr(c));
1721     x.i = snd(c);
1722     return x.p;
1723 }
1724 #else
1725 /* For 8 byte addresses (used on the Alpha), we'll have to work harder */
1726 #error "PTR_ON_HEAP not supported on this architecture"
1727 #endif
1728 #endif
1729
1730 String stringNegate( s )
1731 String s;
1732 {
1733     if (s[0] == '-') {
1734         return &s[1];
1735     } else {
1736         static char t[100];
1737         t[0] = '-';
1738         strcpy(&t[1],s);  /* ToDo: use strncpy instead */
1739         return t;
1740     }
1741 }
1742
1743 /* --------------------------------------------------------------------------
1744  * List operations:
1745  * ------------------------------------------------------------------------*/
1746
1747 Int length(xs)                         /* calculate length of list xs      */
1748 List xs; {
1749     Int n = 0;
1750     for (n=0; nonNull(xs); ++n)
1751         xs = tl(xs);
1752     return n;
1753 }
1754
1755 List appendOnto(xs,ys)                 /* Destructively prepend xs onto    */
1756 List xs, ys; {                         /* ys by modifying xs ...           */
1757     if (isNull(xs))
1758         return ys;
1759     else {
1760         List zs = xs;
1761         while (nonNull(tl(zs)))
1762             zs = tl(zs);
1763         tl(zs) = ys;
1764         return xs;
1765     }
1766 }
1767
1768 List revDupOnto(xs,ys)   /* non-destructively prepend xs backwards onto ys */
1769 List xs;
1770 List ys; {
1771     for( ; nonNull(xs); xs=tl(xs)) {
1772         ys = cons(hd(xs),ys);
1773     }
1774     return ys;
1775 }
1776
1777 List dupListOnto(xs,ys)              /* Duplicate spine of list xs onto ys */
1778 List xs;
1779 List ys; {
1780     return revOnto(revDupOnto(xs,NIL),ys);
1781 }
1782
1783 List revOnto(xs,ys)                    /* Destructively reverse elements of*/
1784 List xs, ys; {                         /* list xs onto list ys...          */
1785     Cell zs;
1786
1787     while (nonNull(xs)) {
1788         zs     = tl(xs);
1789         tl(xs) = ys;
1790         ys     = xs;
1791         xs     = zs;
1792     }
1793     return ys;
1794 }
1795
1796 Bool eqList(as,bs)
1797 List as;
1798 List bs; {
1799     while (nonNull(as) && nonNull(bs) && hd(as)==hd(bs)) {
1800         as=tl(as);
1801         bs=tl(bs);
1802     }
1803     return (isNull(as) && isNull(bs));
1804 }
1805
1806 Cell varIsMember(t,xs)                 /* Test if variable is a member of  */
1807 Text t;                                /* given list of variables          */
1808 List xs; {
1809     for (; nonNull(xs); xs=tl(xs))
1810         if (t==textOf(hd(xs)))
1811             return hd(xs);
1812     return NIL;
1813 }
1814
1815 Cell intIsMember(n,xs)                 /* Test if integer n is member of   */
1816 Int  n;                                /* given list of integers           */
1817 List xs; {
1818     for (; nonNull(xs); xs=tl(xs))
1819         if (n==intOf(hd(xs)))
1820             return hd(xs);
1821     return NIL;
1822 }
1823
1824 Cell cellIsMember(x,xs)                /* Test for membership of specific  */
1825 Cell x;                                /* cell x in list xs                */
1826 List xs; {
1827     for (; nonNull(xs); xs=tl(xs))
1828         if (x==hd(xs))
1829             return hd(xs);
1830     return NIL;
1831 }
1832
1833 Cell cellAssoc(c,xs)                   /* Lookup cell in association list  */
1834 Cell c;
1835 List xs; {
1836     for (; nonNull(xs); xs=tl(xs))
1837         if (c==fst(hd(xs)))
1838             return hd(xs);
1839     return NIL;
1840 }
1841
1842 Cell cellRevAssoc(c,xs)                /* Lookup cell in range of          */
1843 Cell c;                                /* association lists                */
1844 List xs; {
1845     for (; nonNull(xs); xs=tl(xs))
1846         if (c==snd(hd(xs)))
1847             return hd(xs);
1848     return NIL;
1849 }
1850
1851 List replicate(n,x)                    /* create list of n copies of x     */
1852 Int n;
1853 Cell x; {
1854     List xs=NIL;
1855     assert(n>=0);
1856     while (0<n--) {
1857         xs = cons(x,xs);
1858     }
1859     return xs;
1860 }
1861
1862 List diffList(xs,ys)                   /* list difference: xs\ys           */
1863 List xs, ys; {                         /* result contains all elements of  */
1864     List result = NIL;                 /* `xs' not appearing in `ys'       */
1865     while (nonNull(xs)) {
1866         List next = tl(xs);
1867         if (!cellIsMember(hd(xs),ys)) {
1868             tl(xs) = result;
1869             result = xs;
1870         }
1871         xs = next;
1872     }
1873     return rev(result);
1874 }
1875
1876 List deleteCell(xs, y)                  /* copy xs deleting pointers to y  */
1877 List xs;
1878 Cell y; {
1879     List result = NIL;
1880     for(;nonNull(xs);xs=tl(xs)) {
1881         Cell x = hd(xs);
1882         if (x != y) {
1883             result=cons(x,result);
1884         }
1885     }
1886     return rev(result);
1887 }
1888
1889 List take(n,xs)                         /* destructively truncate list to  */
1890 Int  n;                                 /* specified length                */
1891 List xs; {
1892     List ys = xs;
1893
1894     assert(n>=0);
1895     if (n==0)
1896         return NIL;
1897     while (1<n-- && nonNull(xs))
1898         xs = tl(xs);
1899     if (nonNull(xs))
1900         tl(xs) = NIL;
1901     return ys;
1902 }
1903
1904 List splitAt(n,xs)                    /* drop n things from front of list */
1905 Int  n;
1906 List xs; {
1907     assert(n>=0);
1908     for(; n>0; --n) {
1909         xs = tl(xs);
1910     }
1911     return xs;
1912 }
1913
1914 Cell nth(n,xs)                         /* extract n'th element of list    */
1915 Int  n;
1916 List xs; {
1917     assert(n>=0);
1918     for(; n>0 && nonNull(xs); --n, xs=tl(xs)) {
1919     }
1920     assert(nonNull(xs));
1921     return hd(xs);
1922 }
1923
1924 List removeCell(x,xs)                   /* destructively remove cell from  */
1925 Cell x;                                 /* list                            */
1926 List xs; {
1927     if (nonNull(xs)) {
1928         if (hd(xs)==x)
1929             return tl(xs);              /* element at front of list        */
1930         else {
1931             List prev = xs;
1932             List curr = tl(xs);
1933             for (; nonNull(curr); prev=curr, curr=tl(prev))
1934                 if (hd(curr)==x) {
1935                     tl(prev) = tl(curr);
1936                     return xs;          /* element in middle of list       */
1937                 }
1938         }
1939     }
1940     return xs;                          /* here if element not found       */
1941 }
1942
1943 /* --------------------------------------------------------------------------
1944  * Operations on applications:
1945  * ------------------------------------------------------------------------*/
1946
1947 Int argCount;                          /* number of args in application    */
1948
1949 Cell getHead(e)                        /* get head cell of application     */
1950 Cell e; {                              /* set number of args in argCount   */
1951     for (argCount=0; isAp(e); e=fun(e))
1952         argCount++;
1953     return e;
1954 }
1955
1956 List getArgs(e)                        /* get list of arguments in function*/
1957 Cell e; {                              /* application:                     */
1958     List as;                           /* getArgs(f e1 .. en) = [e1,..,en] */
1959
1960     for (as=NIL; isAp(e); e=fun(e))
1961         as = cons(arg(e),as);
1962     return as;
1963 }
1964
1965 Cell nthArg(n,e)                       /* return nth arg in application    */
1966 Int  n;                                /* of function to m args (m>=n)     */
1967 Cell e; {                              /* nthArg n (f x0 x1 ... xm) = xn   */
1968     assert(n>=0);
1969     for (n=numArgs(e)-n-1; n>0; n--)
1970         e = fun(e);
1971     return arg(e);
1972 }
1973
1974 Int numArgs(e)                         /* find number of arguments to expr */
1975 Cell e; {
1976     Int n;
1977     for (n=0; isAp(e); e=fun(e))
1978         n++;
1979     return n;
1980 }
1981
1982 Cell applyToArgs(f,args)               /* destructively apply list of args */
1983 Cell f;                                /* to function f                    */
1984 List args; {
1985     while (nonNull(args)) {
1986         Cell temp = tl(args);
1987         tl(args)  = hd(args);
1988         hd(args)  = f;
1989         f         = args;
1990         args      = temp;
1991     }
1992     return f;
1993 }
1994
1995 /* --------------------------------------------------------------------------
1996  * storage control:
1997  * ------------------------------------------------------------------------*/
1998
1999 #if DYN_TABLES
2000 static void far* safeFarCalloc Args((Int,Int));
2001 static void far* safeFarCalloc(n,s)     /* allocate table storage and check*/
2002 Int n, s; {                             /* for non-null return             */
2003     void far* tab = farCalloc(n,s);
2004     if (tab==0) {
2005         ERRMSG(0) "Cannot allocate run-time tables"
2006         EEND;
2007     }
2008     return tab;
2009 }
2010 #define TABALLOC(v,t,n)                 v=(t far*)safeFarCalloc(n,sizeof(t));
2011 #else
2012 #define TABALLOC(v,t,n)
2013 #endif
2014
2015 Void storage(what)
2016 Int what; {
2017     Int i;
2018
2019     switch (what) {
2020         case RESET   : clearStack();
2021
2022                        consGC = TRUE;
2023                        lsave  = NIL;
2024                        rsave  = NIL;
2025                        if (isNull(lastExprSaved))
2026                            savedText = NUM_TEXT;
2027                        break;
2028
2029         case MARK    :
2030                        start();
2031                        for (i=NAMEMIN; i<nameHw; ++i) {
2032                            mark(name(i).defn);
2033                            mark(name(i).stgVar);
2034                            mark(name(i).type);
2035                        }
2036                        end("Names", nameHw-NAMEMIN);
2037
2038                        start();
2039                        for (i=MODMIN; i<moduleHw; ++i) {
2040                            mark(module(i).tycons);
2041                            mark(module(i).names);
2042                            mark(module(i).classes);
2043                            mark(module(i).exports);
2044                            mark(module(i).qualImports);
2045                        }
2046                        end("Modules", moduleHw-MODMIN);
2047
2048                        start();
2049                        for (i=TYCMIN; i<tyconHw; ++i) {
2050                            mark(tycon(i).defn);
2051                            mark(tycon(i).kind);
2052                            mark(tycon(i).what);
2053                        }
2054                        end("Type constructors", tyconHw-TYCMIN);
2055
2056                        start();
2057                        for (i=CLASSMIN; i<classHw; ++i) {
2058                            mark(cclass(i).head);
2059                            mark(cclass(i).kinds);
2060                            mark(cclass(i).dsels);
2061                            mark(cclass(i).supers);
2062                            mark(cclass(i).members);
2063                            mark(cclass(i).defaults);
2064                            mark(cclass(i).instances);
2065                        }
2066                        mark(classes);
2067                        end("Classes", classHw-CLASSMIN);
2068
2069                        start();
2070                        for (i=INSTMIN; i<instHw; ++i) {
2071                            mark(inst(i).kinds);
2072                            mark(inst(i).head);
2073                            mark(inst(i).specifics);
2074                            mark(inst(i).implements);
2075                        }
2076                        end("Instances", instHw-INSTMIN);
2077
2078                        start();
2079                        for (i=0; i<=sp; ++i)
2080                            mark(stack(i));
2081                        end("Stack", sp+1);
2082
2083                        start();
2084                        mark(lastExprSaved);
2085                        mark(lsave);
2086                        mark(rsave);
2087                        end("Last expression", 3);
2088
2089                        if (consGC) {
2090                            start();
2091                            gcCStack();
2092                            end("C stack", stackRoots);
2093                        }
2094
2095                        break;
2096
2097         case INSTALL : heapFst = heapAlloc(heapSize);
2098                        heapSnd = heapAlloc(heapSize);
2099
2100                        if (heapFst==(Heap)0 || heapSnd==(Heap)0) {
2101                            ERRMSG(0) "Cannot allocate heap storage (%d cells)",
2102                                      heapSize
2103                            EEND;
2104                        }
2105
2106                        heapTopFst = heapFst + heapSize;
2107                        heapTopSnd = heapSnd + heapSize;
2108                        for (i=1; i<heapSize; ++i) {
2109                            fst(-i) = FREECELL;
2110                            snd(-i) = -(i+1);
2111                        }
2112                        snd(-heapSize) = NIL;
2113                        freeList  = -1;
2114                        consGC    = TRUE;
2115                        lsave     = NIL;
2116                        rsave     = NIL;
2117
2118                        marksSize  = bitArraySize(heapSize);
2119                        if ((marks=(Int *)calloc(marksSize, sizeof(Int)))==0) {
2120                            ERRMSG(0) "Unable to allocate gc markspace"
2121                            EEND;
2122                        }
2123
2124                        TABALLOC(text,      char,             NUM_TEXT)
2125                        TABALLOC(tabSyntax, struct strSyntax, NUM_SYNTAX)
2126                        TABALLOC(tyconHash, Tycon,            TYCONHSZ)
2127                        TABALLOC(tabTycon,  struct strTycon,  NUM_TYCON)
2128                        TABALLOC(nameHash,  Name,             NAMEHSZ)
2129                        TABALLOC(tabName,   struct strName,   NUM_NAME)
2130                        TABALLOC(tabClass,  struct strClass,  NUM_CLASSES)
2131                        TABALLOC(cellStack, Cell,             NUM_STACK)
2132                        TABALLOC(tabModule, struct Module,    NUM_SCRIPTS)
2133 #if TREX
2134                        TABALLOC(tabExt,    Text,             NUM_EXT)
2135 #endif
2136                        clearStack();
2137
2138                        textHw        = 0;
2139                        nextNewText   = NUM_TEXT;
2140                        nextNewDText  = (-1);
2141                        lastExprSaved = NIL;
2142                        savedText     = NUM_TEXT;
2143                        for (i=0; i<TEXTHSZ; ++i)
2144                            textHash[i][0] = NOTEXT;
2145
2146                        syntaxHw = 0;
2147
2148                        moduleHw = MODMIN;
2149
2150                        tyconHw  = TYCMIN;
2151                        for (i=0; i<TYCONHSZ; ++i)
2152                            tyconHash[i] = NIL;
2153
2154 #if TREX
2155                        extHw    = EXTMIN;
2156 #endif
2157
2158                        nameHw   = NAMEMIN;
2159                        for (i=0; i<NAMEHSZ; ++i)
2160                            nameHash[i] = NIL;
2161
2162                        classHw  = CLASSMIN;
2163
2164                        instHw   = INSTMIN;
2165
2166 #if USE_DICTHW
2167                        dictHw   = 0;
2168 #endif
2169
2170                        tabInst  = (struct strInst far *)
2171                                     farCalloc(NUM_INSTS,sizeof(struct strInst));
2172
2173                        if (tabInst==0) {
2174                            ERRMSG(0) "Cannot allocate instance tables"
2175                            EEND;
2176                        }
2177
2178                        scriptHw = 0;
2179
2180                        break;
2181     }
2182 }
2183
2184 /*-------------------------------------------------------------------------*/