ghc/interpreter/derive.c

   1
   2 /* --------------------------------------------------------------------------
   3  * Deriving
   4  *
   5  * Copyright (c) The University of Nottingham and Yale University, 1994-1997.
   6  * All rights reserved. See NOTICE for details and conditions of use etc...
   7  * Hugs version 1.4, December 1997
   8  *
   9  * $RCSfile: derive.c,v $
  10  * $Revision: 1.4 $
  11  * $Date: 1999/03/01 14:46:44 $
  12  * ------------------------------------------------------------------------*/
  13
  14 #include "prelude.h"
  15 #include "storage.h"
  16 #include "backend.h"
  17 #include "connect.h"
  18 #include "errors.h"
  19 #include "Assembler.h"
  20 #include "link.h"
  21
  22 static Cell varTrue;
  23 static Cell varFalse;
  24 #if DERIVE_ORD
  25 static Cell varCompAux;                /* auxiliary function for compares */
  26 static Cell varCompare;
  27 static Cell varEQ;
  28 #endif
  29 #if DERIVE_IX
  30 static Cell varRangeSize;              /* calculate size of index range   */
  31 static Cell varInRange;
  32 static Cell varRange;
  33 static Cell varIndex;
  34 static Cell varMult;
  35 static Cell qvarPlus;
  36 static Cell varMap;
  37 static Cell qvarMinus;
  38 static Cell varError;
  39 #endif
  40 #if DERIVE_ENUM
  41 static Cell varToEnum;
  42 static Cell varFromEnum;
  43 static Cell varEnumFromTo;
  44 static Cell varEnumFromThenTo;
  45 #endif
  46 #if DERIVE_BOUNDED
  47 static Cell varMinBound;
  48 static Cell varMaxBound;
  49 #endif
  50 #if DERIVE_SHOW
  51        Cell conCons;
  52 static Cell varShowField;              /* display single field            */
  53 static Cell varShowParen;              /* wrap with parens                */
  54 static Cell varCompose;                /* function composition            */
  55 static Cell varShowsPrec;
  56 static Cell varLe;
  57 #endif
  58 #if DERIVE_READ
  59 static Cell varReadField;              /* read single field               */
  60 static Cell varReadParen;              /* unwrap from parens              */
  61 static Cell varLex;                    /* lexer                           */
  62 static Cell varReadsPrec;
  63 static Cell varGt;
  64 #endif
  65 #if DERIVE_SHOW || DERIVE_READ
  66 static Cell varAppend;                 /* list append                     */
  67 List cfunSfuns;                        /* List of (Cfun,[SelectorVar])    */
  68 #endif
  69 #if DERIVE_EQ || DERIVE_IX
  70 static Cell varAnd;                    /* built-in logical connectives    */
  71 #endif
  72 #if DERIVE_EQ || DERIVE_ORD
  73 static Cell varEq;
  74 #endif
  75
  76
  77 /* --------------------------------------------------------------------------
  78  * local function prototypes:
  79  * ------------------------------------------------------------------------*/
  80
  81 static List  local getDiVars            Args((Int));
  82 static Cell  local mkBind               Args((String,List));
  83 static Cell  local mkVarAlts            Args((Int,Cell));
  84
  85 #if DERIVE_EQ || DERIVE_ORD
  86 static List  local makeDPats2           Args((Cell,Int));
  87 #endif
  88 #if DERIVE_ORD || DERIVE_ENUM || DERIVE_IX || DERIVE_BOUNDED
  89 static Bool  local isEnumType           Args((Tycon));
  90 #endif
  91
  92 static Pair   local mkAltEq             Args((Int,List));
  93 static Pair   local mkAltOrd            Args((Int,List));
  94 static Cell   local prodRange           Args((Int,List,Cell,Cell,Cell));
  95 static Cell   local prodIndex           Args((Int,List,Cell,Cell,Cell));
  96 static Cell   local prodInRange         Args((Int,List,Cell,Cell,Cell));
  97 static List   local mkIxBinds           Args((Int,Cell,Int));
  98 static Cell   local mkAltShow           Args((Int,Cell,Int));
  99 static Cell   local showsPrecRhs        Args((Cell,Cell,Int));
 100 static Cell   local mkReadCon           Args((Name,Cell,Cell));
 101 static Cell   local mkReadPrefix        Args((Cell));
 102 static Cell   local mkReadInfix         Args((Cell));
 103 static Cell   local mkReadTuple         Args((Cell));
 104 static Cell   local mkReadRecord        Args((Cell,List));
 105 static List   local mkBndBinds          Args((Int,Cell,Int));
 106
 107
 108
 109 /* --------------------------------------------------------------------------
 110  * Deriving Utilities
 111  * ------------------------------------------------------------------------*/
 112
 113 List diVars = NIL;                      /* Acts as a cache of invented vars*/
 114 Int  diNum  = 0;
 115
 116 static List local getDiVars(n)          /* get list of at least n vars for */
 117 Int n; {                                /* derived instance generation     */
 118     for (; diNum<n; diNum++) {
 119         diVars = cons(inventVar(),diVars);
 120     }
 121     return diVars;
 122 }
 123
 124 static Cell local mkBind(s,alts)        /* make a binding for a variable   */
 125 String s;
 126 List   alts; {
 127     return pair(mkVar(findText(s)),pair(NIL,alts));
 128 }
 129
 130 static Cell local mkVarAlts(line,r)     /* make alts for binding a var to  */
 131 Int  line;                              /* a simple expression             */
 132 Cell r; {
 133     return singleton(pair(NIL,pair(mkInt(line),r)));
 134 }
 135
 136 #if DERIVE_EQ || DERIVE_ORD
 137 static List local makeDPats2(h,n)       /* generate pattern list           */
 138 Cell h;                                 /* by putting two new patterns with*/
 139 Int  n; {                               /* head h and new var components   */
 140     List us = getDiVars(2*n);
 141     List vs = NIL;
 142     Cell p;
 143     Int  i;
 144
 145     for (i=0, p=h; i<n; ++i) {          /* make first version of pattern   */
 146         p  = ap(p,hd(us));
 147         us = tl(us);
 148     }
 149     vs = cons(p,vs);
 150
 151     for (i=0, p=h; i<n; ++i) {          /* make second version of pattern  */
 152         p  = ap(p,hd(us));
 153         us = tl(us);
 154     }
 155     return cons(p,vs);
 156 }
 157 #endif
 158
 159 #if DERIVE_ORD || DERIVE_ENUM || DERIVE_IX || DERIVE_BOUNDED
 160 static Bool local isEnumType(t) /* Determine whether t is an enumeration   */
 161 Tycon t; {                      /* type (i.e. all constructors arity == 0) */
 162     if (isTycon(t) && (tycon(t).what==DATATYPE || tycon(t).what==NEWTYPE)) {
 163         List cs = tycon(t).defn;
 164         for (; hasCfun(cs); cs=tl(cs)) {
 165             if (name(hd(cs)).arity!=0) {
 166                 return FALSE;
 167             }
 168         }
 169         /* ToDo: correct?  addCfunTable(t); */
 170         return TRUE;
 171     }
 172     return FALSE;
 173 }
 174 #endif
 175
 176 /* --------------------------------------------------------------------------
 177  * Given a datatype:   data T a b = A a b | B Int | C  deriving (Eq, Ord)
 178  * The derived definitions of equality and ordering are given by:
 179  *
 180  *   A a b == A x y  =  a==x && b==y
 181  *   B a   == B x    =  a==x
 182  *   C     == C      =  True
 183  *   _     == _      =  False
 184  *
 185  *   compare (A a b) (A x y) =  primCompAux a x (compare b y)
 186  *   compare (B a)   (B x)   =  compare a x
 187  *   compare C       C       =  EQ
 188  *   compare a       x       =  cmpConstr a x
 189  *
 190  * In each case, the last line is only needed if there are multiple
 191  * constructors in the datatype definition.
 192  * ------------------------------------------------------------------------*/
 193
 194 #if DERIVE_EQ
 195
 196 static Pair  local mkAltEq              Args((Int,List));
 197
 198 List deriveEq(t)                        /* generate binding for derived == */
 199 Type t; {                               /* for some TUPLE or DATATYPE t    */
 200     List alts = NIL;
 201     if (isTycon(t)) {                   /* deal with type constrs          */
 202         List cs = tycon(t).defn;
 203         for (; hasCfun(cs); cs=tl(cs)) {
 204             alts = cons(mkAltEq(tycon(t).line,
 205                                 makeDPats2(hd(cs),name(hd(cs)).arity)),
 206                         alts);
 207         }
 208         if (cfunOf(hd(tycon(t).defn))!=0) {
 209             alts = cons(pair(cons(WILDCARD,cons(WILDCARD,NIL)),
 210                              pair(mkInt(tycon(t).line),varFalse)),alts);
 211         }
 212         alts = rev(alts);
 213     } else {                            /* special case for tuples         */
 214         alts = singleton(mkAltEq(0,makeDPats2(t,tupleOf(t))));
 215     }
 216     return singleton(mkBind("==",alts));
 217 }
 218
 219 static Pair local mkAltEq(line,pats)    /* make alt for an equation for == */
 220 Int  line;                              /* using patterns in pats for lhs  */
 221 List pats; {                            /* arguments                       */
 222     Cell p = hd(pats);
 223     Cell q = hd(tl(pats));
 224     Cell e = varTrue;
 225
 226     if (isAp(p)) {
 227         e = ap2(varEq,arg(p),arg(q));
 228         for (p=fun(p), q=fun(q); isAp(p); p=fun(p), q=fun(q)) {
 229             e = ap2(varAnd,ap2(varEq,arg(p),arg(q)),e);
 230         }
 231     }
 232     return pair(pats,pair(mkInt(line),e));
 233 }
 234 #endif /* DERIVE_EQ */
 235
 236 #if DERIVE_ORD
 237
 238 static Pair  local mkAltOrd             Args((Int,List));
 239
 240 List deriveOrd(t)                       /* make binding for derived compare*/
 241 Type t; {                               /* for some TUPLE or DATATYPE t    */
 242     List alts = NIL;
 243     if (isEnumType(t)) {                /* special case for enumerations   */
 244         Cell u = inventVar();
 245         Cell w = inventVar();
 246         Cell rhs = NIL;
 247         if (cfunOf(hd(tycon(t).defn))!=0) {
 248             implementConToTag(t);
 249             rhs = ap2(varCompare,
 250                       ap(tycon(t).conToTag,u),
 251                       ap(tycon(t).conToTag,w));
 252         } else {
 253             rhs = varEQ;
 254         }
 255         alts = singleton(pair(doubleton(u,w),pair(mkInt(tycon(t).line),rhs)));
 256     } else if (isTycon(t)) {            /* deal with type constrs          */
 257         List cs = tycon(t).defn;
 258         for (; hasCfun(cs); cs=tl(cs)) {
 259             alts = cons(mkAltOrd(tycon(t).line,
 260                                  makeDPats2(hd(cs),name(hd(cs)).arity)),
 261                         alts);
 262         }
 263         if (cfunOf(hd(tycon(t).defn))!=0) {
 264             Cell u = inventVar();
 265             Cell w = inventVar();
 266             implementConToTag(t);
 267             alts   = cons(pair(doubleton(u,w),
 268                                pair(mkInt(tycon(t).line),
 269                                     ap2(varCompare,
 270                                         ap(tycon(t).conToTag,u),
 271                                         ap(tycon(t).conToTag,w)))),
 272                           alts);
 273         }
 274         alts = rev(alts);
 275     } else {                            /* special case for tuples         */
 276         alts = singleton(mkAltOrd(0,makeDPats2(t,tupleOf(t))));
 277     }
 278     return singleton(mkBind("compare",alts));
 279 }
 280
 281 static Pair local mkAltOrd(line,pats)   /* make alt for eqn for compare    */
 282 Int  line;                              /* using patterns in pats for lhs  */
 283 List pats; {                            /* arguments                       */
 284     Cell p = hd(pats);
 285     Cell q = hd(tl(pats));
 286     Cell e = varEQ;
 287
 288     if (isAp(p)) {
 289         e = ap2(varCompare,arg(p),arg(q));
 290         for (p=fun(p), q=fun(q); isAp(p); p=fun(p), q=fun(q)) {
 291             e = ap3(varCompAux,arg(p),arg(q),e);
 292         }
 293     }
 294
 295     return pair(pats,pair(mkInt(line),e));
 296 }
 297 #endif /* DERIVE_ORD */
 298
 299
 300 /* --------------------------------------------------------------------------
 301  * Deriving Ix and Enum:
 302  * ------------------------------------------------------------------------*/
 303
 304 #if DERIVE_ENUM
 305 List deriveEnum(t)              /* Construct definition of enumeration     */
 306 Tycon t; {
 307     Int  l    = tycon(t).line;
 308     Cell x    = inventVar();
 309     Cell y    = inventVar();
 310     Cell first = hd(tycon(t).defn);
 311     Cell last = tycon(t).defn;
 312
 313     if (!isEnumType(t)) {
 314         ERRMSG(l) "Can only derive instances of Enum for enumeration types"
 315         EEND;
 316     }
 317     while (hasCfun(tl(last))) {
 318         last = tl(last);
 319     }
 320     last = hd(last);
 321     implementConToTag(t);
 322     implementTagToCon(t);
 323     return cons(mkBind("toEnum",      mkVarAlts(l,tycon(t).tagToCon)),
 324            cons(mkBind("fromEnum",    mkVarAlts(l,tycon(t).conToTag)),
 325            cons(mkBind("enumFrom",    singleton(pair(singleton(x),
 326                                         pair(mkInt(l),
 327                                         ap2(varEnumFromTo,x,last))))),
 328            /* default instance of enumFromTo is good */
 329            cons(mkBind("enumFromThen",singleton(pair(doubleton(x,y),
 330                                         pair(mkInt(l),
 331                                         ap3(varEnumFromThenTo,x,y,
 332                                         ap(COND,triple(ap2(varLe,x,y),
 333                                         last,first))))))),
 334            /* default instance of enumFromThenTo is good */
 335            NIL))));
 336 }
 337 #endif /* DERIVE_ENUM */
 338
 339 #if DERIVE_IX
 340 static List  local mkIxBindsEnum        Args((Tycon));
 341 static List  local mkIxBinds            Args((Int,Cell,Int));
 342 static Cell  local prodRange            Args((Int,List,Cell,Cell,Cell));
 343 static Cell  local prodIndex            Args((Int,List,Cell,Cell,Cell));
 344 static Cell  local prodInRange          Args((Int,List,Cell,Cell,Cell));
 345
 346 List deriveIx(t)                /* Construct definition of indexing        */
 347 Tycon t; {
 348     if (isEnumType(t)) {        /* Definitions for enumerations            */
 349         implementConToTag(t);
 350         implementTagToCon(t);
 351         return mkIxBindsEnum(t);
 352     } else if (isTuple(t)) {    /* Definitions for product types           */
 353         return mkIxBinds(0,t,tupleOf(t));
 354     } else if (isTycon(t) && cfunOf(hd(tycon(t).defn))==0) {
 355         return mkIxBinds(tycon(t).line,
 356                          hd(tycon(t).defn),
 357                          name(hd(tycon(t).defn)).arity);
 358     }
 359     ERRMSG(tycon(t).line)
 360         "Can only derive instances of Ix for enumeration or product types"
 361     EEND;
 362     return NIL;/* NOTREACHED*/
 363 }
 364
 365 /* instance  Ix T  where
 366  *     range (c1,c2)       =  map tagToCon [conToTag c1 .. conToTag c2]
 367  *     index b@(c1,c2) ci
 368  *         | inRange b ci  =  conToTag ci - conToTag c1
 369  *         | otherwise     =  error "Ix.index.T: Index out of range."
 370  *     inRange (c1,c2) ci  =  conToTag c1 <= i && i <= conToTag c2
 371  *                            where i = conToTag ci
 372  */
 373 static List local mkIxBindsEnum(t)
 374 Tycon t; {
 375     Int l = tycon(t).line;
 376     Name tagToCon = tycon(t).tagToCon;
 377     Name conToTag = tycon(t).conToTag;
 378     Cell b  = inventVar();
 379     Cell c1 = inventVar();
 380     Cell c2 = inventVar();
 381     Cell ci = inventVar();
 382     return cons(mkBind("range",  singleton(pair(singleton(ap2(mkTuple(2),
 383                                  c1,c2)), pair(mkInt(l),ap2(varMap,tagToCon,
 384                                  ap2(varEnumFromTo,ap(conToTag,c1),
 385                                  ap(conToTag,c2))))))),
 386            cons(mkBind("index",  singleton(pair(doubleton(ap(ASPAT,pair(b,
 387                                  ap2(mkTuple(2),c1,c2))),ci),
 388                                  pair(mkInt(l),ap(COND,
 389                                  triple(ap2(varInRange,b,ci),
 390                                  ap2(qvarMinus,ap(conToTag,ci),
 391                                  ap(conToTag,c1)),
 392                                  ap(varError,mkStr(findText(
 393                                  "Ix.index: Index out of range"))))))))),
 394            cons(mkBind("inRange",singleton(pair(doubleton(ap2(mkTuple(2),
 395                                  c1,c2),ci), pair(mkInt(l),ap2(varAnd,
 396                                  ap2(varLe,ap(conToTag,c1),ap(conToTag,ci)),
 397                                  ap2(varLe,ap(conToTag,ci),
 398                                  ap(conToTag,c2))))))),
 399                                         /* ToDo: share conToTag ci         */
 400            NIL)));
 401 }
 402
 403 static List local mkIxBinds(line,h,n)   /* build bindings for derived Ix on*/
 404 Int  line;                              /* a product type                  */
 405 Cell h;
 406 Int  n; {
 407     List vs   = getDiVars(3*n);
 408     Cell ls   = h;
 409     Cell us   = h;
 410     Cell is   = h;
 411     Cell pr   = NIL;
 412     Cell pats = NIL;
 413     Int  i;
 414
 415     for (i=0; i<n; ++i, vs=tl(vs)) {    /* build three patterns for values */
 416         ls = ap(ls,hd(vs));             /* of the datatype concerned       */
 417         us = ap(us,hd(vs=tl(vs)));
 418         is = ap(is,hd(vs=tl(vs)));
 419     }
 420     pr   = ap2(mkTuple(2),ls,us);       /* Build (ls,us)                   */
 421     pats = cons(pr,cons(is,NIL));       /* Build [(ls,us),is]              */
 422
 423     return cons(prodRange(line,singleton(pr),ls,us,is),
 424            cons(prodIndex(line,pats,ls,us,is),
 425            cons(prodInRange(line,pats,ls,us,is),
 426            NIL)));
 427 }
 428
 429 static Cell local prodRange(line,pats,ls,us,is)
 430 Int  line;                              /* Make definition of range for a  */
 431 List pats;                              /* product type                    */
 432 Cell ls, us, is; {
 433     /* range :: (a,a) -> [a]
 434      * range (X a b c, X p q r)
 435      *   = [ X x y z | x <- range (a,p), y <- range (b,q), z <- range (c,r) ]
 436      */
 437     Cell is1 = is;
 438     List e   = NIL;
 439     for (; isAp(ls); ls=fun(ls), us=fun(us), is=fun(is)) {
 440         e = cons(ap(FROMQUAL,pair(arg(is),
 441                                   ap(varRange,ap2(mkTuple(2),
 442                                                    arg(ls),
 443                                                    arg(us))))),e);
 444     }
 445     e = ap(COMP,pair(is1,e));
 446     e = singleton(pair(pats,pair(mkInt(line),e)));
 447     return mkBind("range",e);
 448 }
 449
 450 static Cell local prodIndex(line,pats,ls,us,is)
 451 Int  line;                              /* Make definition of index for a  */
 452 List pats;                              /* product type                    */
 453 Cell ls, us, is; {
 454     /* index :: (a,a) -> a -> Bool
 455      * index (X a b c, X p q r) (X x y z)
 456      *  = index (c,r) z + rangeSize (c,r) * (
 457      *     index (b,q) y + rangeSize (b,q) * (
 458      *      index (a,x) x))
 459      */
 460     List xs = NIL;
 461     Cell e  = NIL;
 462     for (; isAp(ls); ls=fun(ls), us=fun(us), is=fun(is)) {
 463         xs = cons(ap2(varIndex,ap2(mkTuple(2),arg(ls),arg(us)),arg(is)),xs);
 464     }
 465     for (e=hd(xs); nonNull(xs=tl(xs));) {
 466         Cell x = hd(xs);
 467         e = ap2(qvarPlus,x,ap2(varMult,ap(varRangeSize,arg(fun(x))),e));
 468     }
 469     e = singleton(pair(pats,pair(mkInt(line),e)));
 470     return mkBind("index",e);
 471 }
 472
 473 static Cell local prodInRange(line,pats,ls,us,is)
 474 Int  line;                              /* Make definition of inRange for a*/
 475 List pats;                              /* product type                    */
 476 Cell ls, us, is; {
 477     /* inRange :: (a,a) -> a -> Bool
 478      * inRange (X a b c, X p q r) (X x y z)
 479      *          = inRange (a,p) x && inRange (b,q) y && inRange (c,r) z
 480      */
 481     Cell e = ap2(varInRange,ap2(mkTuple(2),arg(ls),arg(us)),arg(is));
 482     while (ls=fun(ls), us=fun(us), is=fun(is), isAp(ls)) {
 483         e = ap2(varAnd,
 484                 ap2(varInRange,ap2(mkTuple(2),arg(ls),arg(us)),arg(is)),
 485                 e);
 486     }
 487     e = singleton(pair(pats,pair(mkInt(line),e)));
 488     return mkBind("inRange",e);
 489 }
 490 #endif /* DERIVE_IX */
 491
 492
 493 /* --------------------------------------------------------------------------
 494  * Deriving Show:
 495  * ------------------------------------------------------------------------*/
 496
 497 List deriveShow(t)              /* Construct definition of text conversion */
 498 Tycon t; {
 499     List alts = NIL;
 500     if (isTycon(t)) {                   /* deal with type constrs          */
 501         List cs = tycon(t).defn;
 502         for (; hasCfun(cs); cs=tl(cs)) {
 503             alts = cons(mkAltShow(tycon(t).line,hd(cs),userArity(hd(cs))),
 504                         alts);
 505         }
 506         alts = rev(alts);
 507     } else {                            /* special case for tuples         */
 508         alts = singleton(mkAltShow(0,t,tupleOf(t)));
 509     }
 510     return singleton(mkBind("showsPrec",alts));
 511 }
 512
 513 static Cell local mkAltShow(line,h,a)   /* make alt for showsPrec eqn      */
 514 Int  line;
 515 Cell h;
 516 Int  a; {
 517     List vs   = getDiVars(a+1);
 518     Cell d    = hd(vs);
 519     Cell pat  = h;
 520     List pats = NIL;
 521     Int  i    = 0;
 522     for (vs=tl(vs); i<a; i++) {
 523         pat = ap(pat,hd(vs));
 524         vs  = tl(vs);
 525     }
 526     pats = cons(d,cons(pat,NIL));
 527     return pair(pats,pair(mkInt(line),showsPrecRhs(d,pat,a)));
 528 }
 529
 530 #define shows0   ap(nameShowsPrec,mkInt(0))
 531 #define shows10  ap(nameShowsPrec,mkInt(10))
 532 #define showsOP  ap(nameComp,consChar('('))
 533 #define showsOB  ap(nameComp,consChar('{'))
 534 #define showsCM  ap(nameComp,consChar(','))
 535 #define showsSP  ap(nameComp,consChar(' '))
 536 #define showsBQ  ap(nameComp,consChar('`'))
 537 #define showsCP  consChar(')')
 538 #define showsCB  consChar('}')
 539
 540 static Cell local showsPrecRhs(d,pat,a) /* build a rhs for showsPrec for a */
 541 Cell d, pat;                            /* given pattern, pat              */
 542 Int  a; {
 543     Cell h   = getHead(pat);
 544     List cfs = cfunSfuns;
 545
 546     if (isTuple(h)) {
 547         /* To display a tuple:
 548          *    showsPrec d (a,b,c,d) = showChar '(' . showsPrec 0 a .
 549          *                            showChar ',' . showsPrec 0 b .
 550          *                            showChar ',' . showsPrec 0 c .
 551          *                            showChar ',' . showsPrec 0 d .
 552          *                            showChar ')'
 553          */
 554         Int  i   = tupleOf(h);
 555         Cell rhs = showsCP;
 556         for (; i>1; --i) {
 557             rhs = ap(showsCM,ap2(nameComp,ap(shows0,arg(pat)),rhs));
 558             pat = fun(pat);
 559         }
 560         return ap(showsOP,ap2(nameComp,ap(shows0,arg(pat)),rhs));
 561     }
 562
 563     for (; nonNull(cfs) && h!=fst(hd(cfs)); cfs=tl(cfs)) {
 564     }
 565     if (nonNull(cfs)) {
 566         /* To display a value using record syntax:
 567          *    showsPrec d C{x=e, y=f, z=g} = showString "C"  . showChar '{' .
 568          *                                   showField "x" e . showChar ',' .
 569          *                                   showField "y" f . showChar ',' .
 570          *                                   showField "z" g . showChar '}'
 571          *    showField lab val
 572          *      = showString lab . showChar '=' . shows val
 573          */
 574         Cell rhs     = showsCB;
 575         List vs      = dupOnto(snd(hd(cfs)),NIL);
 576         if (isAp(pat)) {
 577             for (;;) {
 578                 rhs = ap2(nameComp,
 579                           ap2(nameShowField,
 580                               mkStr(textOf(hd(vs))),
 581                               arg(pat)),
 582                           rhs);
 583                 pat = fun(pat);
 584                 vs  = tl(vs);
 585                 if (isAp(pat)) {
 586                     rhs = ap(showsCM,rhs);
 587                 } else {
 588                     break;
 589                 }
 590             }
 591         }
 592         rhs = ap2(nameComp,ap(nameApp,mkStr(name(h).text)),ap(showsOB,rhs));
 593         return rhs;
 594     }
 595     else if (a==0) {
 596         /* To display a nullary constructor:
 597          *    showsPrec d Foo = showString "Foo"
 598          */
 599         return ap(nameApp,mkStr(name(h).text));
 600     } else {
 601         Syntax s = syntaxOf(h);
 602         if (a==2 && assocOf(s)!=APPLIC) {
 603             /* For a binary constructor with prec p:
 604              * showsPrec d (a :* b) = showParen (d > p)
 605              *                          (showsPrec lp a . showChar ' ' .
 606              *                           showsString s  . showChar ' ' .
 607              *                           showsPrec rp b)
 608              */
 609             Int  p   = precOf(s);
 610             Int  lp  = (assocOf(s)==LEFT_ASS)  ? p : (p+1);
 611             Int  rp  = (assocOf(s)==RIGHT_ASS) ? p : (p+1);
 612             Cell rhs = ap(showsSP,ap2(nameShowsPrec,mkInt(rp),arg(pat)));
 613             if (defaultSyntax(name(h).text)==APPLIC) {
 614                 rhs = ap(showsBQ,
 615                          ap2(nameComp,
 616                              ap(nameApp,mkStr(name(h).text)),
 617                              ap(showsBQ,rhs)));
 618             } else {
 619                 rhs = ap2(nameComp,ap(nameApp,mkStr(name(h).text)),rhs);
 620             }
 621
 622             rhs = ap2(nameComp,
 623                       ap2(nameShowsPrec,mkInt(lp),arg(fun(pat))),
 624                       ap(showsSP,rhs));
 625             rhs = ap2(nameShowParen,ap2(nameLe,mkInt(p+1),d),rhs);
 626             return rhs;
 627         }
 628         else {
 629             /* To display a non-nullary constructor with applicative syntax:
 630              *    showsPrec d (Foo x y) = showParen (d>=10)
 631              *                             (showString "Foo" .
 632              *                              showChar ' ' . showsPrec 10 x .
 633              *                              showChar ' ' . showsPrec 10 y)
 634              */
 635             Cell rhs = ap(showsSP,ap(shows10,arg(pat)));
 636             for (pat=fun(pat); isAp(pat); pat=fun(pat)) {
 637                 rhs = ap(showsSP,ap2(nameComp,ap(shows10,arg(pat)),rhs));
 638             }
 639             rhs = ap2(nameComp,ap(nameApp,mkStr(name(h).text)),rhs);
 640             rhs = ap2(nameShowParen,ap2(nameLe,mkInt(10),d),rhs);
 641             return rhs;
 642         }
 643     }
 644 }
 645 #undef  shows10
 646 #undef  shows0
 647 #undef  showsOP
 648 #undef  showsOB
 649 #undef  showsCM
 650 #undef  showsSP
 651 #undef  showsBQ
 652 #undef  showsCP
 653 #undef  showsCB
 654
 655 /* --------------------------------------------------------------------------
 656  * Deriving Read:
 657  * ------------------------------------------------------------------------*/
 658
 659 #define Tuple2(f,s)      ap2(mkTuple(2),f,s)
 660 #define Lex(r)           ap(nameLex,r)
 661 #define ZFexp(h,q)       ap(FROMQUAL, pair(h,q))
 662 #define ReadsPrec(n,e)   ap2(nameReadsPrec,n,e)
 663 #define Lambda(v,e)      ap(LAMBDA,pair(v, pair(mkInt(0),e)))
 664 #define ReadParen(a,b,c) ap(ap2(nameReadParen,a,b),c)
 665 #define ReadField(f,s)   ap2(nameReadField,f,s)
 666 #define GT(l,r)          ap2(nameGt,l,r)
 667 #define Append(a,b)      ap2(nameApp,a,b)
 668
 669 /*  Construct the readsPrec function of the form:
 670  *
 671  *    readsPrec d r = (readParen (d>p1) (\r -> [ (C1 ...,s) | ... ]) r ++
 672  *                    (readParen (d>p2) (\r -> [ (C2 ...,s) | ... ]) r ++
 673  *                    ...
 674  *                    (readParen (d>pn) (\r -> [ (Cn ...,s) | ... ]) r) ... ))
 675  */
 676 List deriveRead(t)              /* construct definition of text reader     */
 677 Cell t; {
 678     Cell alt  = NIL;
 679     Cell exp  = NIL;
 680     Cell d    = inventVar();
 681     Cell r    = inventVar();
 682     List pat  = cons(d,cons(r,NIL));
 683     Int  line = 0;
 684
 685     if (isTycon(t)) {
 686         List cs = tycon(t).defn;
 687         List exps = NIL;
 688         for (; hasCfun(cs); cs=tl(cs)) {
 689             exps = cons(mkReadCon(hd(cs),d,r),exps);
 690         }
 691         /* reverse concatenate list of subexpressions */
 692         exp = hd(exps);
 693         for (exps=tl(exps); nonNull(exps); exps=tl(exps)) {
 694             exp = ap2(nameApp,hd(exps),exp);
 695         }
 696         line = tycon(t).line;
 697     }
 698     else { /* Tuples */
 699         exp = ap(mkReadTuple(t),r);
 700     }
 701     /* printExp(stdout,exp); putc('\n',stdout); */
 702     alt  = pair(pat,pair(mkInt(line),exp));
 703     return singleton(mkBind("readsPrec",singleton(alt)));
 704 }
 705
 706 /* Generate an expression of the form:
 707  *
 708  *   readParen (d > p) <derived expression> r
 709  *
 710  * for a (non-tuple) constructor "con" of precedence "p".
 711  */
 712
 713 static Cell local mkReadCon(con, d, r) /* generate reader for a constructor */
 714 Name con;
 715 Cell d;
 716 Cell r; {
 717     Cell exp = NIL;
 718     Int  p   = 0;
 719     Syntax s = syntaxOf(con);
 720     List cfs = cfunSfuns;
 721     for (; nonNull(cfs) && con!=fst(hd(cfs)); cfs=tl(cfs)) {
 722     }
 723     if (nonNull(cfs)) {
 724         exp = mkReadRecord(con,snd(hd(cfs)));
 725         return ReadParen(nameFalse, exp, r);
 726     }
 727
 728     if (userArity(con)==2 && assocOf(s)!=APPLIC) {
 729         exp = mkReadInfix(con);
 730         p   = precOf(s);
 731     } else {
 732         exp = mkReadPrefix(con);
 733         p   = 9;
 734     }
 735     return ReadParen(userArity(con)==0 ? nameFalse : GT(d,mkInt(p)), exp, r);
 736 }
 737
 738 /* Given an n-ary prefix constructor, generate a single lambda
 739  * expression, such that
 740  *
 741  *   data T ... = Constr a1 a2 .. an | ....
 742  *
 743  * derives
 744  *
 745  *   \ r -> [ (Constr t1 t2 ... tn, sn) | ("Constr",s0) <- lex r,
 746  *                                        (t1,s1) <- readsPrec 10 s0,
 747  *                                        (t2,s2) <- readsPrec 10 s1,
 748  *                                        ...,
 749  *                                        (tn,sn) <- readsPrec 10 sn-1 ]
 750  *
 751  */
 752 static Cell local mkReadPrefix(con)    /* readsPrec for prefix constructor */
 753 Cell con; {
 754     Int  arity  = userArity(con);
 755     Cell cn     = mkStr(name(con).text);
 756     Cell r      = inventVar();
 757     Cell prev_s = inventVar();
 758     Cell exp    = con;
 759     List quals  = NIL;
 760     Int  i;
 761
 762     /* build (reversed) list of qualifiers and constructor */
 763     quals = cons(ZFexp(Tuple2(cn,prev_s),Lex(r)),quals);
 764     for(i=0; i<arity; i++) {
 765         Cell t = inventVar();
 766         Cell s = inventVar();
 767         quals  = cons(ZFexp(Tuple2(t,s),ReadsPrec(mkInt(10),prev_s)), quals);
 768         exp    = ap(exp,t);
 769         prev_s = s;
 770     }
 771
 772     /* \r -> [ (exp, prev_s) | quals ] */
 773     return Lambda(singleton(r),ap(COMP,pair(Tuple2(exp, prev_s), rev(quals))));
 774 }
 775
 776 /* Given a binary infix constructor of precedence p
 777  *
 778  *   ... | T1 `con` T2 | ...
 779  *
 780  * generate the lambda expression
 781  *
 782  *   \ r -> [ (u `con` v, s2) | (u,s0)     <- readsPrec lp r,
 783  *                              ("con",s1) <- lex s0,
 784  *                              (v,s2)     <- readsPrec rp s1 ]
 785  *
 786  * where lp and rp are either p or p+1 depending on associativity
 787  */
 788 static Cell local mkReadInfix( con )
 789 Cell con;
 790 {
 791     Syntax s  = syntaxOf(con);
 792     Int    p  = precOf(s);
 793     Int    lp = assocOf(s)==LEFT_ASS  ? p : (p+1);
 794     Int    rp = assocOf(s)==RIGHT_ASS ? p : (p+1);
 795     Cell   cn = mkStr(name(con).text);
 796     Cell   r  = inventVar();
 797     Cell   s0 = inventVar();
 798     Cell   s1 = inventVar();
 799     Cell   s2 = inventVar();
 800     Cell   u  = inventVar();
 801     Cell   v  = inventVar();
 802     List quals = NIL;
 803
 804     quals = cons(ZFexp(Tuple2(u, s0), ReadsPrec(mkInt(lp),r)),  quals);
 805     quals = cons(ZFexp(Tuple2(cn,s1), Lex(s0)),                 quals);
 806     quals = cons(ZFexp(Tuple2(v, s2), ReadsPrec(mkInt(rp),s1)), quals);
 807
 808     return Lambda(singleton(r),
 809                   ap(COMP,pair(Tuple2(ap2(con,u,v),s2),rev(quals))));
 810 }
 811
 812 /* Given the n-ary tuple constructor return a lambda expression:
 813  *
 814  *   \ r -> [ ((t1,t2,...tn),s(2n+1)) | ("(",s0)      <- lex r,
 815  *                                      (t1, s1)      <- readsPrec 0 s0,
 816  *                                      ...
 817  *                                      (",",s(2n-1)) <- lex s(2n-2),
 818  *                                      (tn, s(2n))   <- readsPrec 0 s(2n-1),
 819  *                                      (")",s(2n+1)) <- lex s(2n) ]
 820  */
 821 static Cell local mkReadTuple( tup ) /* readsPrec for n-tuple */
 822 Cell tup; {
 823     Int  arity  = tupleOf(tup);
 824     Cell lp     = mkStr(findText("("));
 825     Cell rp     = mkStr(findText(")"));
 826     Cell co     = mkStr(findText(","));
 827     Cell sep    = lp;
 828     Cell r      = inventVar();
 829     Cell prev_s = r;
 830     Cell s      = inventVar();
 831     Cell exp    = tup;
 832     List quals  = NIL;
 833     Int  i;
 834
 835     /* build (reversed) list of qualifiers and constructor */
 836     for(i=0; i<arity; i++) {
 837         Cell t  = inventVar();
 838         Cell si = inventVar();
 839         Cell sj = inventVar();
 840         quals  = cons(ZFexp(Tuple2(sep,si),Lex(prev_s)),quals);
 841         quals  = cons(ZFexp(Tuple2(t,sj),ReadsPrec(mkInt(0),si)), quals);
 842         exp    = ap(exp,t);
 843         prev_s = sj;
 844         sep    = co;
 845     }
 846     quals = cons(ZFexp(Tuple2(rp,s),Lex(prev_s)),quals);
 847
 848     /* \ r -> [ (exp,s) | quals ] */
 849     return Lambda(singleton(r),ap(COMP,pair(Tuple2(exp,s),rev(quals))));
 850 }
 851
 852 /* Given a record constructor
 853  *
 854  *   ... | C { f1 :: T1, ... fn :: Tn } | ...
 855  *
 856  * generate the expression:
 857  *
 858  *   \ r -> [(C t1 t2 ... tn,s(2n+1)) | ("C", s0)    <- lex r,
 859  *                                      ("{", s1)    <- lex s0,
 860  *                                      (t1,  s2)    <- readField "f1" s1,
 861  *                                      ...
 862  *                                      (",", s(2n-1)) <- lex s(2n),
 863  *                                      (tn,  s(2n)) <- readField "fn" s(2n+1),
 864  *                                      ("}", s(2n+1)) <- lex s(2n+2) ]
 865  *
 866  * where
 867  *
 868  *   readField    :: Read a => String -> ReadS a
 869  *   readField m s0 = [ r | (t,  s1) <- lex s0, t == m,
 870  *                          ("=",s2) <- lex s1,
 871  *                          r        <- readsPrec 10 s2 ]
 872  */
 873 static Cell local mkReadRecord(con, fs) /* readsPrec for record constructor */
 874 Cell con;
 875 List fs; {
 876     Cell cn     = mkStr(name(con).text);
 877     Cell lb     = mkStr(findText("{"));
 878     Cell rb     = mkStr(findText("}"));
 879     Cell co     = mkStr(findText(","));
 880     Cell sep    = lb;
 881     Cell r      = inventVar();
 882     Cell s0     = inventVar();
 883     Cell prev_s = s0;
 884     Cell s      = inventVar();
 885     Cell exp    = con;
 886     List quals  = NIL;
 887
 888     /* build (reversed) list of qualifiers and constructor */
 889     quals  = cons(ZFexp(Tuple2(cn,s0),Lex(r)), quals);
 890     for(; nonNull(fs); fs=tl(fs)) {
 891         Cell f  = mkStr(textOf(hd(fs)));
 892         Cell t  = inventVar();
 893         Cell si = inventVar();
 894         Cell sj = inventVar();
 895         quals  = cons(ZFexp(Tuple2(sep,si),Lex(prev_s)),     quals);
 896         quals  = cons(ZFexp(Tuple2(t,  sj),ReadField(f,si)), quals);
 897         exp    = ap(exp,t);
 898         prev_s = sj;
 899         sep    = co;
 900     }
 901     quals = cons(ZFexp(Tuple2(rb,s),Lex(prev_s)),quals);
 902
 903     /* \ r -> [ (exp,s) | quals ] */
 904     return Lambda(singleton(r),ap(COMP,pair(Tuple2(exp,s),rev(quals))));
 905 }
 906
 907 #undef Tuple2
 908 #undef Lex
 909 #undef ZFexp
 910 #undef ReadsPrec
 911 #undef Lambda
 912 #undef ReadParen
 913 #undef ReadField
 914 #undef GT
 915 #undef Append
 916
 917 /* --------------------------------------------------------------------------
 918  * Deriving Bounded:
 919  * ------------------------------------------------------------------------*/
 920
 921 #if DERIVE_BOUNDED
 922
 923 List deriveBounded(t)             /* construct definition of bounds        */
 924 Tycon t; {
 925     if (isEnumType(t)) {
 926         Cell last  = tycon(t).defn;
 927         Cell first = hd(last);
 928         while (hasCfun(tl(last))) {
 929             last = tl(last);
 930         }
 931         return cons(mkBind("minBound",mkVarAlts(tycon(t).line,first)),
 932                 cons(mkBind("maxBound",mkVarAlts(tycon(t).line,hd(last))),
 933                  NIL));
 934     } else if (isTuple(t)) {    /* Definitions for product types           */
 935         return mkBndBinds(0,t,tupleOf(t));
 936     } else if (isTycon(t) && cfunOf(hd(tycon(t).defn))==0) {
 937         return mkBndBinds(tycon(t).line,
 938                           hd(tycon(t).defn),
 939                           userArity(hd(tycon(t).defn)));
 940     }
 941     ERRMSG(tycon(t).line)
 942      "Can only derive instances of Bounded for enumeration and product types"
 943     EEND;
 944     return NIL;
 945 }
 946
 947 static List local mkBndBinds(line,h,n)  /* build bindings for derived      */
 948 Int  line;                              /* Bounded on a product type       */
 949 Cell h;
 950 Int  n; {
 951     Cell minB = h;
 952     Cell maxB = h;
 953     while (n-- > 0) {
 954         minB = ap(minB,nameMinBnd);
 955         maxB = ap(maxB,nameMaxBnd);
 956     }
 957     return cons(mkBind("minBound",mkVarAlts(line,minB)),
 958             cons(mkBind("maxBound",mkVarAlts(line,maxB)),
 959              NIL));
 960 }
 961 #endif /* DERIVE_BOUNDED */
 962
 963
 964
 965 /* --------------------------------------------------------------------------
 966  * Helpers: conToTag and tagToCon
 967  * ------------------------------------------------------------------------*/
 968
 969 /* \ v -> case v of { ...; Ci _ _ -> i; ... } */
 970 Void implementConToTag(t)
 971 Tycon t; {
 972     if (isNull(tycon(t).conToTag)) {
 973         List   cs  = tycon(t).defn;
 974         Name   nm  = newName(inventText(),NIL);
 975         StgVar v   = mkStgVar(NIL,NIL);
 976         List alts  = NIL; /* can't fail */
 977
 978         assert(isTycon(t) && (tycon(t).what==DATATYPE
 979                               || tycon(t).what==NEWTYPE));
 980         for (; hasCfun(cs); cs=tl(cs)) {
 981             Name    c   = hd(cs);
 982             Int     num = cfunOf(c) == 0 ? 0 : cfunOf(c)-1;
 983             StgVar  r   = mkStgVar(mkStgCon(nameMkI,singleton(mkInt(num))),
 984                                    NIL);
 985             StgExpr tag = mkStgLet(singleton(r),r);
 986             List    vs  = NIL;
 987             Int i;
 988             for(i=0; i < name(c).arity; ++i) {
 989                 vs = cons(mkStgVar(NIL,NIL),vs);
 990             }
 991             alts = cons(mkStgCaseAlt(c,vs,tag),alts);
 992         }
 993
 994         name(nm).line   = tycon(t).line;
 995         name(nm).type   = conToTagType(t);
 996         name(nm).arity  = 1;
 997         name(nm).stgVar = mkStgVar(mkStgLambda(singleton(v),mkStgCase(v,alts)),
 998                                    NIL);
 999         tycon(t).conToTag = nm;
1000         /* hack to make it print out */
1001         stgGlobals = cons(pair(nm,name(nm).stgVar),stgGlobals);
1002     }
1003 }
1004
1005 /* \ v -> case v of { ...; i -> Ci; ... } */
1006 Void implementTagToCon(t)
1007 Tycon t; {
1008     if (isNull(tycon(t).tagToCon)) {
1009         String etxt;
1010         String tyconname;
1011         List   cs;
1012         Name   nm;
1013         StgVar v1;
1014         StgVar v2;
1015         Cell   txt0;
1016         StgVar bind1;
1017         StgVar bind2;
1018         StgVar bind3;
1019         List   alts;
1020
1021         assert(nameMkA);
1022         assert(nameUnpackString);
1023         assert(nameError);
1024         assert(isTycon(t) && (tycon(t).what==DATATYPE
1025                               || tycon(t).what==NEWTYPE));
1026
1027         tyconname  = textToStr(tycon(t).text);
1028         etxt       = malloc(100+strlen(tyconname));
1029         assert(etxt);
1030         sprintf(etxt,
1031                 "out-of-range arg for `toEnum' "
1032                 "in derived `instance Enum %s'",
1033                 tyconname);
1034
1035         cs  = tycon(t).defn;
1036         nm  = newName(inventText(),NIL);
1037         v1  = mkStgVar(NIL,NIL);
1038         v2  = mkStgPrimVar(NIL,mkStgRep(INT_REP),NIL);
1039
1040         txt0  = mkStr(findText(etxt));
1041         bind1 = mkStgVar(mkStgCon(nameMkA,singleton(txt0)),NIL);
1042         bind2 = mkStgVar(mkStgApp(nameUnpackString,singleton(bind1)),NIL);
1043         bind3 = mkStgVar(mkStgApp(nameError,singleton(bind2)),NIL);
1044
1045         alts  = singleton(
1046                    mkStgPrimAlt(
1047                       singleton(
1048                          mkStgPrimVar(NIL,mkStgRep(INT_REP),NIL)
1049                       ),
1050                       makeStgLet ( tripleton(bind1,bind2,bind3), bind3 )
1051                    )
1052                 );
1053
1054         for (; hasCfun(cs); cs=tl(cs)) {
1055             Name   c   = hd(cs);
1056             Int    num = cfunOf(c) == 0 ? 0 : cfunOf(c)-1;
1057             StgVar pat = mkStgPrimVar(mkInt(num),mkStgRep(INT_REP),NIL);
1058             assert(name(c).arity==0);
1059             alts = cons(mkStgPrimAlt(singleton(pat),c),alts);
1060         }
1061
1062         name(nm).line   = tycon(t).line;
1063         name(nm).type   = tagToConType(t);
1064         name(nm).arity  = 1;
1065         name(nm).stgVar = mkStgVar(
1066                             mkStgLambda(
1067                               singleton(v1),
1068                               mkStgCase(
1069                                 v1,
1070                                 singleton(
1071                                   mkStgCaseAlt(
1072                                     nameMkI,
1073                                     singleton(v2),
1074                                     mkStgPrimCase(v2,alts))))),
1075                             NIL
1076                           );
1077         tycon(t).tagToCon = nm;
1078         /* hack to make it print out */
1079         stgGlobals = cons(pair(nm,name(nm).stgVar),stgGlobals);
1080         if (etxt) free(etxt);
1081     }
1082 }
1083
1084
1085 /* --------------------------------------------------------------------------
1086  * Derivation control:
1087  * ------------------------------------------------------------------------*/
1088
1089 Void deriveControl(what)
1090 Int what; {
1091     Text textPrelude = findText("Prelude");
1092     switch (what) {
1093         case INSTALL :
1094                 varTrue           = mkQVar(textPrelude,findText("True"));
1095                 varFalse          = mkQVar(textPrelude,findText("False"));
1096 #if DERIVE_ORD
1097                 varCompAux        = mkQVar(textPrelude,findText("primCompAux"));
1098                 varCompare        = mkQVar(textPrelude,findText("compare"));
1099                 varEQ             = mkQVar(textPrelude,findText("EQ"));
1100 #endif
1101 #if DERIVE_IX
1102                 varRangeSize      = mkQVar(textPrelude,findText("rangeSize"));
1103                 varInRange        = mkQVar(textPrelude,findText("inRange"));
1104                 varRange          = mkQVar(textPrelude,findText("range"));
1105                 varIndex          = mkQVar(textPrelude,findText("index"));
1106                 varMult           = mkQVar(textPrelude,findText("*"));
1107                 qvarPlus          = mkQVar(textPrelude,findText("+"));
1108                 varMap            = mkQVar(textPrelude,findText("map"));
1109                 qvarMinus         = mkQVar(textPrelude,findText("-"));
1110                 varError          = mkQVar(textPrelude,findText("error"));
1111 #endif
1112 #if DERIVE_ENUM
1113                 varToEnum         = mkQVar(textPrelude,findText("toEnum"));
1114                 varFromEnum       = mkQVar(textPrelude,findText("fromEnum"));
1115                 varEnumFromTo     = mkQVar(textPrelude,findText("enumFromTo"));
1116                 varEnumFromThenTo = mkQVar(textPrelude,findText("enumFromThenTo"));
1117 #endif
1118 #if DERIVE_BOUNDED
1119                 varMinBound       = mkQVar(textPrelude,findText("minBound"));
1120                 varMaxBound       = mkQVar(textPrelude,findText("maxBound"));
1121 #endif
1122 #if DERIVE_SHOW
1123                 conCons           = mkQCon(textPrelude,findText(":"));
1124                 varShowField      = mkQVar(textPrelude,findText("primShowField"));
1125                 varShowParen      = mkQVar(textPrelude,findText("showParen"));
1126                 varCompose        = mkQVar(textPrelude,findText("."));
1127                 varShowsPrec      = mkQVar(textPrelude,findText("showsPrec"));
1128                 varLe             = mkQVar(textPrelude,findText("<="));
1129 #endif
1130 #if DERIVE_READ
1131                 varReadField      = mkQVar(textPrelude,findText("primReadField"));
1132                 varReadParen      = mkQVar(textPrelude,findText("readParen"));
1133                 varLex            = mkQVar(textPrelude,findText("lex"));
1134                 varReadsPrec      = mkQVar(textPrelude,findText("readsPrec"));
1135                 varGt             = mkQVar(textPrelude,findText(">"));
1136 #endif
1137 #if DERIVE_SHOW || DERIVE_READ
1138                 varAppend         = mkQVar(textPrelude,findText("++"));
1139 #endif
1140 #if DERIVE_EQ || DERIVE_IX
1141                 varAnd            = mkQVar(textPrelude,findText("&&"));
1142 #endif
1143 #if DERIVE_EQ || DERIVE_ORD
1144                 varEq             = mkQVar(textPrelude,findText("=="));
1145 #endif
1146                 /* deliberate fall through */
1147         case RESET   :
1148                 diVars      = NIL;
1149                 diNum       = 0;
1150 #if DERIVE_SHOW | DERIVE_READ
1151                 cfunSfuns   = NIL;
1152 #endif
1153                 break;
1154
1155         case MARK    :
1156                 mark(diVars);
1157 #if DERIVE_SHOW | DERIVE_READ
1158                 mark(cfunSfuns);
1159 #endif
1160                 mark(varTrue);
1161                 mark(varFalse);
1162 #if DERIVE_ORD
1163                 mark(varCompAux);
1164                 mark(varCompare);
1165                 mark(varEQ);
1166 #endif
1167 #if DERIVE_IX
1168                 mark(varRangeSize);
1169                 mark(varInRange);
1170                 mark(varRange);
1171                 mark(varIndex);
1172                 mark(varMult);
1173                 mark(qvarPlus);
1174                 mark(varMap);
1175                 mark(qvarMinus);
1176                 mark(varError);
1177 #endif
1178 #if DERIVE_ENUM
1179                 mark(varToEnum);
1180                 mark(varFromEnum);
1181                 mark(varEnumFromTo);
1182                 mark(varEnumFromThenTo);
1183 #endif
1184 #if DERIVE_BOUNDED
1185                 mark(varMinBound);
1186                 mark(varMaxBound);
1187 #endif
1188 #if DERIVE_SHOW
1189                 mark(conCons);
1190                 mark(varShowField);
1191                 mark(varShowParen);
1192                 mark(varCompose);
1193                 mark(varShowsPrec);
1194                 mark(varLe);
1195 #endif
1196 #if DERIVE_READ
1197                 mark(varReadField);
1198                 mark(varReadParen);
1199                 mark(varLex);
1200                 mark(varReadsPrec);
1201                 mark(varGt);
1202 #endif
1203 #if DERIVE_SHOW || DERIVE_READ
1204                 mark(varAppend);
1205 #endif
1206 #if DERIVE_EQ || DERIVE_IX
1207                 mark(varAnd);
1208 #endif
1209 #if DERIVE_EQ || DERIVE_ORD
1210                 mark(varEq);
1211 #endif
1212                 break;
1213     }
1214 }
1215
1216 /*-------------------------------------------------------------------------*/