ghc/interpreter/storage.c

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