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