1 /* -*- mode: hugs-c; -*- */
2 /* --------------------------------------------------------------------------
3 * Defines storage datatypes: Text, Name, Module, Tycon, Cell, List, Pair,
6 * Copyright (c) The University of Nottingham and Yale University, 1994-1997.
7 * All rights reserved. See NOTICE for details and conditions of use etc...
8 * Hugs version 1.4, December 1997
10 * $RCSfile: storage.h,v $
12 * $Date: 1998/12/02 13:22:43 $
13 * ------------------------------------------------------------------------*/
15 /* --------------------------------------------------------------------------
16 * Typedefs for main data types:
17 * Many of these type names are used to indicate the intended us of a data
18 * item, rather than for type checking purposes. Sadly (although sometimes,
19 * fortunately), the C compiler cannot distinguish between the use of two
20 * different names defined to be synonyms for the same types.
21 * ------------------------------------------------------------------------*/
23 typedef Int Text; /* text string */
24 typedef Word Syntax; /* syntax (assoc,preced) */
25 typedef Int Cell; /* general cell value */
26 typedef Cell far *Heap; /* storage of heap */
27 typedef Cell Pair; /* pair cell */
28 typedef Int StackPtr; /* stack pointer */
29 typedef Cell Offset; /* offset/generic variable*/
30 typedef Int Script; /* script file number */
31 typedef Int Module; /* module */
32 typedef Cell Tycon; /* type constructor */
33 typedef Cell Type; /* type expression */
34 typedef Cell Kind; /* kind expression */
35 typedef Cell Kinds; /* list of kinds */
36 typedef Cell Constr; /* constructor expression */
37 typedef Cell Name; /* named value */
38 typedef Cell Class; /* type class */
39 typedef Cell Inst; /* instance of type class */
40 typedef Cell Triple; /* triple of cell values */
41 typedef Cell List; /* list of cells */
42 typedef Cell Bignum; /* integer literal */
43 typedef Cell Float; /* floating pt literal */
45 typedef Cell Ext; /* extension label */
48 /* --------------------------------------------------------------------------
50 * provides storage for the characters making up identifier and symbol
51 * names, string literals, character constants etc...
52 * ------------------------------------------------------------------------*/
54 extern String textToStr Args((Text));
55 extern Text findText Args((String));
56 extern Text inventText Args((Void));
57 extern Text inventDictText Args((Void));
58 extern Bool inventedText Args((Text));
60 /* Variants of textToStr and syntaxOf which work for idents, ops whether
61 * qualified or unqualified.
63 extern String identToStr Args((Cell));
64 extern Syntax identSyntax Args((Cell));
65 extern Syntax defaultSyntax Args((Text));
67 /* --------------------------------------------------------------------------
68 * Specification of syntax (i.e. default written form of application)
69 * ------------------------------------------------------------------------*/
71 #define MIN_PREC 0 /* weakest binding operator */
72 #define MAX_PREC 9 /* strongest binding operator */
73 #define FUN_PREC (MAX_PREC+2) /* binding of function symbols */
74 #define DEF_PREC MAX_PREC
75 #define APPLIC 00000 /* written applicatively */
76 #define LEFT_ASS 02000 /* left associative infix */
77 #define RIGHT_ASS 04000 /* right associative infix */
78 #define NON_ASS 06000 /* non associative infix */
79 #define DEF_ASS NON_ASS
81 #define assocOf(x) ((x)&NON_ASS)
82 #define precOf(x) ((x)&(~NON_ASS))
83 #define mkSyntax(a,p) ((a)|(p))
84 #define DEF_OPSYNTAX mkSyntax(DEF_ASS,DEF_PREC)
86 extern Void addSyntax Args((Int,Text,Syntax));
87 extern Syntax syntaxOf Args((Text));
89 /* --------------------------------------------------------------------------
91 * Provides a garbage collectable heap for storage of expressions etc.
92 * ------------------------------------------------------------------------*/
94 #define heapAlloc(s) (Heap)(farCalloc(s,sizeof(Cell)))
95 #define heapBuilt() (heapFst)
97 extern Heap heapFst, heapSnd;
98 extern Heap heapTopFst;
99 extern Heap heapTopSnd;
100 extern Bool consGC; /* Set to FALSE to turn off gc from*/
101 /* C stack; use with extreme care! */
102 extern Int cellsRecovered; /* cells recovered by last gc */
104 #define fst(c) heapTopFst[c]
105 #define snd(c) heapTopSnd[c]
107 extern Pair pair Args((Cell,Cell));
108 extern Void garbageCollect Args((Void));
110 extern Void overwrite Args((Pair,Pair));
111 extern Void overwrite2 Args((Pair,Cell,Cell));
112 extern Cell markExpr Args((Cell));
113 extern Void markWithoutMove Args((Cell));
115 #define mark(v) v=markExpr(v)
117 #define isPair(c) ((c)<0)
118 #define isGenPair(c) ((c)<0 && -heapSize<=(c))
120 extern Cell whatIs Args((Cell));
122 /* --------------------------------------------------------------------------
123 * Box cell tags are used as the fst element of a pair to indicate that
124 * the snd element of the pair is to be treated in some special way, other
125 * than as a Cell. Examples include holding integer values, variable name
126 * and string text etc.
127 * ------------------------------------------------------------------------*/
129 #define TAGMIN 1 /* Box and constructor cell tag values */
130 #define BCSTAG 20 /* Box=TAGMIN..BCSTAG-1 */
131 #define isTag(c) (TAGMIN<=(c) && (c)<SPECMIN) /* Tag cell values */
132 #define isBoxTag(c) (TAGMIN<=(c) && (c)<BCSTAG) /* Box cell tag values */
133 #define isConTag(c) (BCSTAG<=(c) && (c)<SPECMIN) /* Constr cell tag values*/
135 #define FREECELL 3 /* Free list cell: snd :: Cell */
136 #define VARIDCELL 4 /* Identifier variable: snd :: Text */
137 #define VAROPCELL 5 /* Operator variable: snd :: Text */
138 #define DICTVAR 6 /* Dictionary variable: snd :: Text */
139 #define CONIDCELL 7 /* Identifier constructor: snd :: Text */
140 #define CONOPCELL 8 /* Operator constructor: snd :: Text */
141 #define STRCELL 9 /* String literal: snd :: Text */
142 #define INTCELL 10 /* Int literal: snd :: Int */
143 #define FLOATCELL 15 /* Floating Pt literal: snd :: Text */
144 #define BIGCELL 16 /* Integer literal: snd :: Text */
146 #define PTRCELL 17 /* C Heap Pointer snd :: Ptr */
149 #define EXTCOPY 18 /* Copy of an Ext: snd :: Text */
152 #define textOf(c) ((Text)(snd(c))) /* c :: (VAR|CON)(ID|OP) */
153 #define qmodOf(c) (textOf(fst(snd(c)))) /* c :: QUALIDENT */
154 #define qtextOf(c) (textOf(snd(snd(c)))) /* c :: QUALIDENT */
155 #define mkVar(t) ap(VARIDCELL,t)
156 #define mkVarop(t) ap(VAROPCELL,t)
157 #define mkCon(t) ap(CONIDCELL,t)
158 #define mkConop(t) ap(CONOPCELL,t)
159 #define mkQVar(m,t) ap(QUALIDENT,pair(mkCon(m),mkVar(t)))
160 #define mkQCon(m,t) ap(QUALIDENT,pair(mkCon(m),mkCon(t)))
161 #define mkQVarOp(m,t) ap(QUALIDENT,pair(mkCon(m),mkVarop(t)))
162 #define mkQConOp(m,t) ap(QUALIDENT,pair(mkCon(m),mkConop(t)))
163 #define intValOf(c) (snd(c))
164 #define inventVar() mkVar(inventText())
165 #define mkDictVar(t) ap(DICTVAR,t)
166 #define inventDictVar() mkDictVar(inventDictText())
167 #define mkStr(t) ap(STRCELL,t)
168 extern Bool isVar Args((Cell));
169 extern Bool isCon Args((Cell));
170 extern Bool isQVar Args((Cell));
171 extern Bool isQCon Args((Cell));
172 extern Bool isQualIdent Args((Cell));
173 extern Bool isIdent Args((Cell));
175 extern String stringNegate Args((String));
177 #define intEq(x,y) (intOf(x) == intOf(y))
178 #define intNegate(x) mkInt(-intOf(x))
180 #define isFloat(c) (isPair(c) && fst(c)==FLOATCELL)
181 #define stringToFloat(s) pair(FLOATCELL,findText(s))
182 #define floatToString(f) textToStr(snd(f))
183 #define floatEq(f1,f2) (snd(f1) == snd(f2))
184 #define floatNegate(f) stringToFloat(stringNegate(floatToString(f)))
185 #define floatOf(f) atof(floatToString(f))
187 #define isBignum(c) (isPair(c) && fst(c)==BIGCELL)
188 #define stringToBignum(s) pair(BIGCELL,findText(s))
189 #define bignumToString(b) textToStr(snd(b))
190 #define bignumEq(b1,b2) (snd(b1) == snd(b2))
191 #define bignumNegate(b) stringToBignum(stringNegate(bignumToString(b)))
192 #define bignumOf(b) atoi(bignumToString(b)) /* ToDo: overflow check */
195 #define isPtr(c) (isPair(c) && fst(c)==PTRCELL)
196 extern Cell mkPtr Args((Ptr));
197 extern Ptr ptrOf Args((Cell));
200 /* --------------------------------------------------------------------------
201 * Constructor cell tags are used as the fst element of a pair to indicate
202 * a particular syntactic construct described by the snd element of the
204 * Note that a cell c will not be treated as an application (AP/isAp) node
205 * if its first element is a constructor cell tag, whereas a cell whose fst
206 * element is a special cell will be treated as an application node.
207 * ------------------------------------------------------------------------*/
209 #define LETREC 20 /* LETREC snd :: ([Decl],Exp) */
210 #define COND 21 /* COND snd :: (Exp,Exp,Exp) */
211 #define LAMBDA 22 /* LAMBDA snd :: Alt */
212 #define FINLIST 23 /* FINLIST snd :: [Exp] */
213 #define DOCOMP 24 /* DOCOMP snd :: (Exp,[Qual]) */
214 #define BANG 25 /* BANG snd :: Type */
215 #define COMP 26 /* COMP snd :: (Exp,[Qual]) */
216 #define ASPAT 27 /* ASPAT snd :: (Var,Exp) */
217 #define ESIGN 28 /* ESIGN snd :: (Exp,Type) */
218 #define CASE 29 /* CASE snd :: (Exp,[Alt]) */
219 #define NUMCASE 30 /* NUMCASE snd :: (Exp,Disc,Rhs) */
220 #define FATBAR 31 /* FATBAR snd :: (Exp,Exp) */
221 #define LAZYPAT 32 /* LAZYPAT snd :: Exp */
222 #define DERIVE 35 /* DERIVE snd :: Cell */
224 #define ADDPAT 36 /* (_+k) pattern discr: snd :: Cell */
227 #define BOOLQUAL 39 /* BOOLQUAL snd :: Exp */
228 #define QWHERE 40 /* QWHERE snd :: [Decl] */
229 #define FROMQUAL 41 /* FROMQUAL snd :: (Exp,Exp) */
230 #define DOQUAL 42 /* DOQUAL snd :: Exp */
232 #define GUARDED 44 /* GUARDED snd :: [guarded exprs] */
234 #define ARRAY 45 /* Array: snd :: (Bounds,[Values]) */
235 #define MUTVAR 46 /* Mutvar: snd :: Cell */
237 #define POLYTYPE 50 /* POLYTYPE snd :: (Kind,Type) */
238 #define QUAL 51 /* QUAL snd :: ([Classes],Type) */
239 #define RANK2 52 /* RANK2 snd :: (Int,Type) */
240 #define EXIST 53 /* EXIST snd :: (Int,Type) */
241 #define POLYREC 54 /* POLYREC: snd :: (Int,Type) */
242 #define BIGLAM 55 /* BIGLAM: snd :: (vars,patterns) */
244 #define LABC 60 /* LABC: snd :: (con,[(Vars,Type)]) */
245 #define CONFLDS 61 /* CONFLDS: snd :: (con,[Field]) */
246 #define UPDFLDS 62 /* UPDFLDS: snd :: (Exp,[con],[Field]) */
248 #define RECORD 63 /* RECORD: snd :: [Val] */
249 #define EXTCASE 64 /* EXTCASE: snd :: (Exp,Disc,Rhs) */
250 #define RECSEL 65 /* RECSEL: snd :: Ext */
253 #define QUALIDENT 70 /* Qualified identifier snd :: (Id,Id) */
254 #define HIDDEN 71 /* hiding import list snd :: [Entity] */
255 #define MODULEENT 72 /* module in export list snd :: con */
257 #define ONLY 75 /* ONLY: snd :: Exp (used in parser)*/
258 #define NEG 76 /* NEG: snd :: Exp (used in parser)*/
260 #define IMPDEPS 78 /* IMPDEFS: snd :: [Binding] */
262 #define STGVAR 80 /* STGVAR snd :: (StgRhs,info) */
263 #define STGAPP 81 /* STGAPP snd :: (StgVar,[Arg]) */
264 #define STGPRIM 82 /* STGPRIM snd :: (PrimOp,[Arg]) */
265 #define STGCON 83 /* STGCON snd :: (StgCon,[Arg]) */
266 #define PRIMCASE 84 /* PRIMCASE snd :: (Expr,[PrimAlt]) */
268 /* Used when parsing GHC interface files */
269 #define DICTAP 85 /* DICTTYPE snd :: (QClassId,[Type]) */
271 /* Last constructor tag must be less than SPECMIN */
273 /* --------------------------------------------------------------------------
274 * Special cell values:
275 * ------------------------------------------------------------------------*/
278 #define isSpec(c) (SPECMIN<=(c) && (c)<TUPMIN)/* Special cell values */
280 #define NONE 101 /* Dummy stub */
281 #define STAR 102 /* Representing the kind of types */
283 #define ROW 103 /* Representing the kind of rows */
285 #define WILDCARD 104 /* Wildcard pattern */
286 #define SKOLEM 105 /* Skolem constant */
288 #define DOTDOT 106 /* ".." in import/export list */
290 #define NAME 110 /* whatIs code for isName */
291 #define TYCON 111 /* whatIs code for isTycon */
292 #define CLASS 112 /* whatIs code for isClass */
293 #define MODULE 113 /* whatIs code for isModule */
294 #define INSTANCE 114 /* whatIs code for isInst */
295 #define TUPLE 115 /* whatIs code for tuple constructor */
296 #define OFFSET 116 /* whatis code for offset */
297 #define AP 117 /* whatIs code for application node */
298 #define CHARCELL 118 /* whatIs code for isChar */
300 #define EXT 119 /* whatIs code for isExt */
303 #define SIGDECL 120 /* Signature declaration */
304 #define PREDEFINED 121 /* predefined name, not yet filled */
306 #define DATATYPE 130 /* datatype type constructor */
307 #define NEWTYPE 131 /* newtype type constructor */
308 #define SYNONYM 132 /* synonym type constructor */
309 #define RESTRICTSYN 133 /* synonym with restricted scope */
311 #define NODEPENDS 135 /* stop calculation of deps in type check*/
313 /* --------------------------------------------------------------------------
314 * Tuple data/type constructors:
315 * ------------------------------------------------------------------------*/
319 #define isTuple(c) (TUPMIN<=(c) && (c)<EXTMIN)
321 #define isTuple(c) (TUPMIN<=(c) && (c)<OFFMIN)
323 #define mkTuple(n) (TUPMIN+(n))
324 #define tupleOf(n) ((Int)((n)-TUPMIN))
327 #define EXTMIN (TUPMIN+NUM_TUPLES)
328 #define isExt(c) (EXTMIN<=(c) && (c)<OFFMIN)
329 #define extText(e) tabExt[(e)-EXTMIN]
330 #define extField(c) arg(fun(c))
331 #define extRow(c) arg(c)
333 extern Text DECTABLE(tabExt);
334 extern Ext mkExt Args((Text));
339 /* --------------------------------------------------------------------------
340 * Offsets: (generic types/stack offsets)
341 * ------------------------------------------------------------------------*/
344 #define OFFMIN (EXTMIN+NUM_EXT)
346 #define OFFMIN (TUPMIN+NUM_TUPLES)
348 #define isOffset(c) (OFFMIN<=(c) && (c)<MODMIN)
349 #define offsetOf(c) ((c)-OFFMIN)
350 #define mkOffset(o) (OFFMIN+(o))
352 /* --------------------------------------------------------------------------
354 * ------------------------------------------------------------------------*/
356 #define MODMIN (OFFMIN+NUM_OFFSETS)
358 #define isModule(c) (MODMIN<=(c) && (c)<TYCMIN)
359 #define mkModule(n) (MODMIN+(n))
360 #define module(n) tabModule[(n)-MODMIN]
362 /* Under Haskell 1.3, the list of qualified imports is always a subset
363 * of the list of unqualified imports. For simplicity and flexibility,
364 * we do not attempt to exploit this fact - when a module is imported
365 * unqualified, it is added to both the qualified and unqualified
367 * Similarily, Haskell 1.3 does not allow a constructor to be imported
368 * or exported without exporting the type it belongs to but the export
369 * list is just a flat list of Texts (before static analysis) or
370 * Tycons, Names and Classes (after static analysis).
374 /* Lists of top level objects (local defns + imports) */
378 List exports; /* [ Entity | (Entity, NIL|DOTDOT) ] */
379 /* List of qualified imports. Used both during compilation and when
380 * evaluating an expression in the context of the current module.
383 ObjectFile objectFile; /* usually unused */
386 extern Module currentModule; /* Module currently being processed */
387 extern struct Module DECTABLE(tabModule);
389 extern Bool isValidModule Args((Module));
390 extern Module newModule Args((Text));
391 extern Module findModule Args((Text));
392 extern Module findModid Args((Cell));
393 extern Void setCurrModule Args((Module));
395 /* --------------------------------------------------------------------------
396 * Type constructor names:
397 * ------------------------------------------------------------------------*/
399 #define TYCMIN (MODMIN+NUM_MODULE)
400 #define isTycon(c) (TYCMIN<=(c) && (c)<NAMEMIN)
401 #define mkTycon(n) (TCMIN+(n))
402 #define tycon(n) tabTycon[(n)-TYCMIN]
407 Module mod; /* module that defines it */
409 Kind kind; /* kind (includes arity) of Tycon */
410 Cell what; /* DATATYPE/SYNONYM/RESTRICTSYN... */
412 Name conToTag; /* used in derived code */
417 extern struct strTycon DECTABLE(tabTycon);
419 extern Tycon newTycon Args((Text));
420 extern Tycon findTycon Args((Text));
421 extern Tycon addTycon Args((Tycon));
422 extern Tycon findQualTycon Args((Cell));
423 extern Tycon addPrimTycon Args((Text,Kind,Int,Cell,Cell));
425 #define isSynonym(h) (isTycon(h) && tycon(h).what==SYNONYM)
426 #define mkPolyType(n,t) pair(POLYTYPE,pair(n,t))
427 #define isPolyType(t) (isPair(t) && fst(t)==POLYTYPE)
428 #define polySigOf(t) fst(snd(t))
429 #define monotypeOf(t) snd(snd(t))
431 /* --------------------------------------------------------------------------
432 * Globally defined name values:
433 * ------------------------------------------------------------------------*/
435 #define NAMEMIN (TYCMIN+NUM_TYCON)
436 #define isName(c) (NAMEMIN<=(c) && (c)<INSTMIN)
437 #define mkName(n) (NAMEMIN+(n))
438 #define name(n) tabName[(n)-NAMEMIN]
443 Module mod; /* module that defines it */
448 Cell stgVar; /* really StgVar */
449 const void* primop; /* really StgPrim* */
453 extern int numNames Args(( Void ));
455 extern struct strName DECTABLE(tabName);
457 /* The number field in a name is used to distinguish various kinds of name:
458 * mfunNo(i) = code for member function, offset i
459 * members that are sole elements of dict use mfunNo(0)
460 * members of dicts with more than one elem use mfunNo(n), n>=1
461 * EXECNAME = code for executable name (bytecodes or primitive)
462 * SELNAME = code for selector function
463 * DFUNNAME = code for dictionary builder or selector
464 * cfunNo(i) = code for data constructor
465 * datatypes with only one constructor uses cfunNo(0)
466 * datatypes with multiple constructors use cfunNo(n), n>=1
474 #define isSfun(n) (name(n).number==SELNAME)
475 #define isDfun(n) (name(n).number==DFUNNAME)
477 #define isCfun(n) (name(n).number>=CFUNNAME)
478 #define cfunOf(n) (name(n).number-CFUNNAME)
479 #define cfunNo(i) ((i)+CFUNNAME)
480 #define hasCfun(cs) (nonNull(cs) && isCfun(hd(cs)))
482 #define isMfun(n) (name(n).number<0)
483 #define mfunOf(n) ((-1)-name(n).number)
484 #define mfunNo(i) ((-1)-(i))
486 extern Name newName Args((Text));
487 extern Name findName Args((Text));
488 extern Name addName Args((Name));
489 extern Name findQualName Args((Int,Cell));
490 extern Name addPrimCfun Args((Text,Int,Int,Int));
491 extern Int sfunPos Args((Name,Name));
493 /* --------------------------------------------------------------------------
495 * ------------------------------------------------------------------------*/
497 #define INSTMIN (NAMEMIN+NUM_NAME) /* instances */
498 #define isInst(c) (INSTMIN<=(c) && (c)<CLASSMIN)
499 #define mkInst(n) (INSTMIN+(n))
500 #define instOf(c) ((Int)((c)-INSTMIN))
501 #define inst(in) tabInst[(in)-INSTMIN]
504 Class c; /* class C */
506 Module mod; /* module that defines it */
507 Kinds kinds; /* Kinds of variables in head */
508 Cell head; /* :: Pred */
509 List specifics; /* :: [Pred] */
510 Int numSpecifics; /* length(specifics) */
512 Name builder; /* Dictionary constructor function */
515 /* a predicate (an element :: Pred) is an application of a Class to one or
516 * more type expressions
519 #define CLASSMIN (INSTMIN+NUM_INSTS)
520 #define isClass(c) (CLASSMIN<=(c) && (c)<CHARMIN)
521 #define mkClass(n) (CLASSMIN+(n))
522 #define cclass(n) tabClass[(n)-CLASSMIN]
525 Text text; /* Name of class */
526 Int line; /* Line where declaration begins */
527 Module mod; /* module that defines it */
528 Int level; /* Level in class hierarchy */
529 Int arity; /* Number of arguments */
530 Kinds kinds; /* Kinds of constructors in class */
531 Cell head; /* Head of class */
532 Name dcon; /* Dictionay constructor function */
533 List supers; /* :: [Pred] */
534 Int numSupers; /* length(supers) */
535 List dsels; /* Superclass dictionary selectors */
536 List members; /* :: [Name] */
537 Int numMembers; /* length(members) */
538 Name dbuild; /* Default dictionary builder */
539 List defaults; /* :: [Name] */
540 List instances; /* :: [Inst] */
543 extern struct strClass DECTABLE(tabClass);
544 extern struct strInst far *tabInst;
546 extern Class newClass Args((Text));
547 extern Class classMax Args((Void));
548 extern Class findClass Args((Text));
549 extern Class addClass Args((Class));
550 extern Class findQualClass Args((Cell));
551 extern Inst newInst Args((Void));
552 extern Inst findFirstInst Args((Tycon));
553 extern Inst findNextInst Args((Tycon,Inst));
555 /* --------------------------------------------------------------------------
557 * ------------------------------------------------------------------------*/
559 #define CHARMIN (CLASSMIN+NUM_CLASSES)
560 #define MAXCHARVAL (NUM_CHARS-1)
561 #define isChar(c) (CHARMIN<=(c) && (c)<INTMIN)
562 #define charOf(c) ((Char)(c-CHARMIN))
563 #define mkChar(c) ((Cell)(CHARMIN+((unsigned)((c)%NUM_CHARS))))
565 /* --------------------------------------------------------------------------
566 * Small Integer values:
567 * ------------------------------------------------------------------------*/
569 #define INTMIN (CHARMIN+NUM_CHARS)
570 #define INTMAX MAXPOSINT
571 #define isSmall(c) (INTMIN<=(c))
572 #define INTZERO (INTMIN/2 + INTMAX/2)
573 #define mkDigit(c) ((Cell)((c)+INTMIN))
574 #define digitOf(c) ((Int)((c)-INTMIN))
576 extern Bool isInt Args((Cell));
577 extern Int intOf Args((Cell));
578 extern Cell mkInt Args((Int));
580 /* --------------------------------------------------------------------------
581 * Implementation of triples:
582 * ------------------------------------------------------------------------*/
584 #define triple(x,y,z) pair(x,pair(y,z))
585 #define fst3(c) fst(c)
586 #define snd3(c) fst(snd(c))
587 #define thd3(c) snd(snd(c))
589 /* --------------------------------------------------------------------------
590 * Implementation of lists:
591 * ------------------------------------------------------------------------*/
594 #define isNull(c) ((c)==NIL)
595 #define nonNull(c) (c)
596 #define cons(x,xs) pair(x,xs)
597 #define singleton(x) cons(x,NIL)
598 #define doubleton(x,y) cons(x,cons(y,NIL))
599 #define tripleton(x,y,z) cons(x,cons(y,cons(z,NIL)))
603 extern Int length Args((List));
604 extern List appendOnto Args((List,List)); /* destructive */
605 extern List revDupOnto Args((List,List)); /* non-destructive */
606 extern List dupListOnto Args((List,List)); /* non-destructive */
607 extern List revOnto Args((List,List)); /* destructive */
608 #define reverse(xs) revDupOnto((xs),NIL) /* non-destructive */
609 #define dupList(xs) dupListOnto((xs),NIL) /* non-destructive */
610 #define rev(xs) revOnto((xs),NIL) /* destructive */
611 extern Cell cellIsMember Args((Cell,List));
612 extern Cell cellAssoc Args((Cell,List));
613 extern Cell cellRevAssoc Args((Cell,List));
614 extern Bool eqList Args((List,List));
615 extern Cell varIsMember Args((Text,List));
616 extern Cell intIsMember Args((Int,List));
617 extern List replicate Args((Int,Cell));
618 extern List diffList Args((List,List)); /* destructive */
619 extern List deleteCell Args((List,Cell)); /* non-destructive */
620 extern List take Args((Int,List)); /* destructive */
621 extern List splitAt Args((Int,List)); /* non-destructive */
622 extern Cell nth Args((Int,List));
623 extern List removeCell Args((Cell,List)); /* destructive */
625 /* The following macros provide `inline expansion' of some common ways of
626 * traversing, using and modifying lists:
628 * N.B. We use the names _f, _a, _xs, Zs, in an attempt to avoid clashes
629 * with identifiers used elsewhere.
632 #define mapBasic(_init,_step) {List Zs=(_init);\
633 for(;nonNull(Zs);Zs=tl(Zs)) \
635 #define mapModify(_init,_step) mapBasic(_init,hd(Zs)=_step)
637 #define mapProc(_f,_xs) mapBasic(_xs,_f(hd(Zs)))
638 #define map1Proc(_f,_a,_xs) mapBasic(_xs,_f(_a,hd(Zs)))
639 #define map2Proc(_f,_a,_b,_xs) mapBasic(_xs,_f(_a,_b,hd(Zs)))
640 #define map3Proc(_f,_a,_b,_c,_xs) mapBasic(_xs,_f(_a,_b,_c,hd(Zs)))
642 #define mapOver(_f,_xs) mapModify(_xs,_f(hd(Zs)))
643 #define map1Over(_f,_a,_xs) mapModify(_xs,_f(_a,hd(Zs)))
644 #define map2Over(_f,_a,_b,_xs) mapModify(_xs,_f(_a,_b,hd(Zs)))
645 #define map3Over(_f,_a,_b,_c,_xs) mapModify(_xs,_f(_a,_b,_c,hd(Zs)))
647 /* This is just what you want for functions with accumulating parameters */
648 #define mapAccum(_f,_acc,_xs) mapBasic(_xs,_acc=_f(_acc,hd(Zs)))
649 #define map1Accum(_f,_acc,_a,_xs) mapBasic(_xs,_acc=_f(_acc,_a,hd(Zs)))
650 #define map2Accum(_f,_acc,_a,_b,_xs) mapBasic(_xs,_acc=_f(_acc,_a,_b,hd(Zs)))
651 #define map3Accum(_f,_acc,_a,_b,_c,_xs) mapBasic(_xs,_acc=_f(_acc,_a,_b,_c,hd(Zs)))
653 /* --------------------------------------------------------------------------
654 * Implementation of function application nodes:
655 * ------------------------------------------------------------------------*/
657 #define ap(f,x) pair(f,x)
658 #define ap1(f,x) ap(f,x)
659 #define ap2(f,x,y) ap(ap(f,x),y)
660 #define ap3(f,x,y,z) ap(ap(ap(f,x),y),z)
661 #define fun(c) fst(c)
662 #define arg(c) snd(c)
663 #define isAp(c) (isPair(c) && !isTag(fst(c)))
664 extern Cell getHead Args((Cell));
665 extern List getArgs Args((Cell));
667 extern Cell nthArg Args((Int,Cell));
668 extern Int numArgs Args((Cell));
669 extern Cell applyToArgs Args((Cell,List));
671 /* --------------------------------------------------------------------------
672 * Stack implementation:
674 * NB: Use of macros makes order of evaluation hard to predict.
675 * For example, "push(1+pop());" doesn't increment TOS.
676 * ------------------------------------------------------------------------*/
678 extern Cell DECTABLE(cellStack);
681 #define clearStack() sp=(-1)
682 #define stackEmpty() (sp==(-1))
683 #define stack(p) cellStack[p]
684 #define chkStack(n) if (sp>=NUM_STACK-(n)) hugsStackOverflow()
690 #define onto(c) stack(++sp)=(c)
691 #define pop() stack(sp--)
693 #define top() stack(sp)
694 #define pushed(n) stack(sp-(n))
696 extern Void hugsStackOverflow Args((Void));
698 /* --------------------------------------------------------------------------
699 * Script file control:
700 * The implementation of script file storage is hidden.
701 * ------------------------------------------------------------------------*/
703 extern Script startNewScript Args((String));
704 extern Module lastModule Args((Void));
705 extern Script scriptThisName Args((Name));
706 extern Script scriptThisTycon Args((Tycon));
707 extern Script scriptThisInst Args((Inst));
708 extern Script scriptThisClass Args((Class));
709 extern String fileOfModule Args((Module));
710 extern Void dropScriptsFrom Args((Script));
712 /* --------------------------------------------------------------------------
714 * ------------------------------------------------------------------------*/
716 extern Void setLastExpr Args((Cell));
717 extern Cell getLastExpr Args((Void));
718 extern List addTyconsMatching Args((String,List));
719 extern List addNamesMatching Args((String,List));
721 /*-------------------------------------------------------------------------*/