-/* -*- mode: hugs-c; -*- */
+
/* --------------------------------------------------------------------------
* Deriving
*
- * Copyright (c) The University of Nottingham and Yale University, 1994-1997.
- * All rights reserved. See NOTICE for details and conditions of use etc...
- * Hugs version 1.4, December 1997
+ * The Hugs 98 system is Copyright (c) Mark P Jones, Alastair Reid, the
+ * Yale Haskell Group, and the Oregon Graduate Institute of Science and
+ * Technology, 1994-1999, All rights reserved. It is distributed as
+ * free software under the license in the file "License", which is
+ * included in the distribution.
*
* $RCSfile: derive.c,v $
- * $Revision: 1.2 $
- * $Date: 1998/12/02 13:22:03 $
+ * $Revision: 1.14 $
+ * $Date: 2000/03/23 14:54:20 $
* ------------------------------------------------------------------------*/
-#include "prelude.h"
+#include "hugsbasictypes.h"
#include "storage.h"
#include "connect.h"
#include "errors.h"
-#include "translate.h" /* for implementConTag */
-#include "derive.h"
-
-static Cell varTrue;
-static Cell varFalse;
-#if DERIVE_ORD
-static Cell varCompAux; /* auxiliary function for compares */
-static Cell varCompare;
-static Cell varEQ;
-#endif
-#if DERIVE_IX
-static Cell varRangeSize; /* calculate size of index range */
-static Cell varInRange;
-static Cell varRange;
-static Cell varIndex;
-static Cell varMult;
-static Cell varPlus;
-static Cell varMap;
-static Cell varMinus;
-static Cell varError;
-#endif
-#if DERIVE_ENUM
-static Cell varToEnum;
-static Cell varFromEnum;
-static Cell varEnumFromTo;
-static Cell varEnumFromThenTo;
-#endif
-#if DERIVE_BOUNDED
-static Cell varMinBound;
-static Cell varMaxBound;
-#endif
-#if DERIVE_SHOW
-static Cell conCons;
-static Cell varShowField; /* display single field */
-static Cell varShowParen; /* wrap with parens */
-static Cell varCompose; /* function composition */
-static Cell varShowsPrec;
-static Cell varLe;
-#endif
-#if DERIVE_READ
-static Cell varReadField; /* read single field */
-static Cell varReadParen; /* unwrap from parens */
-static Cell varLex; /* lexer */
-static Cell varReadsPrec;
-static Cell varGt;
-#endif
-#if DERIVE_SHOW || DERIVE_READ
-static Cell varAppend; /* list append */
-List cfunSfuns; /* List of (Cfun,[SelectorVar]) */
-#endif
-#if DERIVE_EQ || DERIVE_IX
-static Cell varAnd; /* built-in logical connectives */
-#endif
-#if DERIVE_EQ || DERIVE_ORD
-static Cell varEq;
-#endif
+#include "Assembler.h"
+List cfunSfuns; /* List of (Cfun,[SelectorVar]) */
/* --------------------------------------------------------------------------
* local function prototypes:
* ------------------------------------------------------------------------*/
-static List local getDiVars Args((Int));
-static Cell local mkBind Args((String,List));
-static Cell local mkVarAlts Args((Int,Cell));
+static List local getDiVars ( Int );
+static Cell local mkBind ( String,List );
+static Cell local mkVarAlts ( Int,Cell );
+static List local makeDPats2 ( Cell,Int );
+static Bool local isEnumType ( Tycon );
+static Pair local mkAltEq ( Int,List );
+static Pair local mkAltOrd ( Int,List );
+static Cell local prodRange ( Int,List,Cell,Cell,Cell );
+static Cell local prodIndex ( Int,List,Cell,Cell,Cell );
+static Cell local prodInRange ( Int,List,Cell,Cell,Cell );
+static List local mkIxBinds ( Int,Cell,Int );
+static Cell local mkAltShow ( Int,Cell,Int );
+static Cell local showsPrecRhs ( Cell,Cell,Int );
+static Cell local mkReadCon ( Name,Cell,Cell );
+static Cell local mkReadPrefix ( Cell );
+static Cell local mkReadInfix ( Cell );
+static Cell local mkReadTuple ( Cell );
+static Cell local mkReadRecord ( Cell,List );
+static List local mkBndBinds ( Int,Cell,Int );
-#if DERIVE_EQ || DERIVE_ORD
-static List local makeDPats2 Args((Cell,Int));
-#endif
-#if DERIVE_ORD || DERIVE_ENUM || DERIVE_IX || DERIVE_BOUNDED
-static Bool local isEnumType Args((Tycon));
-#endif
/* --------------------------------------------------------------------------
* Deriving Utilities
* ------------------------------------------------------------------------*/
-static List diVars = NIL; /* Acts as a cache of invented vars*/
-static Int diNum = 0;
+List diVars = NIL; /* Acts as a cache of invented vars*/
+Int diNum = 0;
static List local getDiVars(n) /* get list of at least n vars for */
Int n; { /* derived instance generation */
return singleton(pair(NIL,pair(mkInt(line),r)));
}
-#if DERIVE_EQ || DERIVE_ORD
static List local makeDPats2(h,n) /* generate pattern list */
Cell h; /* by putting two new patterns with*/
Int n; { /* head h and new var components */
}
return cons(p,vs);
}
-#endif
-#if DERIVE_ORD || DERIVE_ENUM || DERIVE_IX || DERIVE_BOUNDED
static Bool local isEnumType(t) /* Determine whether t is an enumeration */
Tycon t; { /* type (i.e. all constructors arity == 0) */
if (isTycon(t) && (tycon(t).what==DATATYPE || tycon(t).what==NEWTYPE)) {
return FALSE;
}
}
+ /* ToDo: correct? addCfunTable(t); */
return TRUE;
}
return FALSE;
}
-#endif
+
/* --------------------------------------------------------------------------
* Given a datatype: data T a b = A a b | B Int | C deriving (Eq, Ord)
* constructors in the datatype definition.
* ------------------------------------------------------------------------*/
-#if DERIVE_EQ
-
-static Pair local mkAltEq Args((Int,List));
+static Pair local mkAltEq ( Int,List );
List deriveEq(t) /* generate binding for derived == */
Type t; { /* for some TUPLE or DATATYPE t */
List cs = tycon(t).defn;
for (; hasCfun(cs); cs=tl(cs)) {
alts = cons(mkAltEq(tycon(t).line,
- makeDPats2(hd(cs),name(hd(cs)).arity)),
+ makeDPats2(hd(cs),userArity(hd(cs)))),
alts);
}
if (cfunOf(hd(tycon(t).defn))!=0) {
alts = cons(pair(cons(WILDCARD,cons(WILDCARD,NIL)),
- pair(mkInt(tycon(t).line),varFalse)),alts);
+ pair(mkInt(tycon(t).line),nameFalse)),alts);
}
alts = rev(alts);
} else { /* special case for tuples */
List pats; { /* arguments */
Cell p = hd(pats);
Cell q = hd(tl(pats));
- Cell e = varTrue;
+ Cell e = nameTrue;
if (isAp(p)) {
- e = ap2(varEq,arg(p),arg(q));
+ e = ap2(nameEq,arg(p),arg(q));
for (p=fun(p), q=fun(q); isAp(p); p=fun(p), q=fun(q)) {
- e = ap2(varAnd,ap2(varEq,arg(p),arg(q)),e);
+ e = ap2(nameAnd,ap2(nameEq,arg(p),arg(q)),e);
}
}
return pair(pats,pair(mkInt(line),e));
}
-#endif /* DERIVE_EQ */
-#if DERIVE_ORD
-static Pair local mkAltOrd Args((Int,List));
+static Pair local mkAltOrd ( Int,List );
List deriveOrd(t) /* make binding for derived compare*/
Type t; { /* for some TUPLE or DATATYPE t */
Cell rhs = NIL;
if (cfunOf(hd(tycon(t).defn))!=0) {
implementConToTag(t);
- rhs = ap2(varCompare,
+ rhs = ap2(nameCompare,
ap(tycon(t).conToTag,u),
ap(tycon(t).conToTag,w));
} else {
- rhs = varEQ;
+ rhs = nameEQ;
}
alts = singleton(pair(doubleton(u,w),pair(mkInt(tycon(t).line),rhs)));
} else if (isTycon(t)) { /* deal with type constrs */
List cs = tycon(t).defn;
for (; hasCfun(cs); cs=tl(cs)) {
alts = cons(mkAltOrd(tycon(t).line,
- makeDPats2(hd(cs),name(hd(cs)).arity)),
+ makeDPats2(hd(cs),userArity(hd(cs)))),
alts);
}
if (cfunOf(hd(tycon(t).defn))!=0) {
implementConToTag(t);
alts = cons(pair(doubleton(u,w),
pair(mkInt(tycon(t).line),
- ap2(varCompare,
+ ap2(nameCompare,
ap(tycon(t).conToTag,u),
ap(tycon(t).conToTag,w)))),
alts);
List pats; { /* arguments */
Cell p = hd(pats);
Cell q = hd(tl(pats));
- Cell e = varEQ;
+ Cell e = nameEQ;
if (isAp(p)) {
- e = ap2(varCompare,arg(p),arg(q));
+ e = ap2(nameCompare,arg(p),arg(q));
for (p=fun(p), q=fun(q); isAp(p); p=fun(p), q=fun(q)) {
- e = ap3(varCompAux,arg(p),arg(q),e);
+ e = ap3(nameCompAux,arg(p),arg(q),e);
}
}
return pair(pats,pair(mkInt(line),e));
}
-#endif /* DERIVE_ORD */
+
/* --------------------------------------------------------------------------
* Deriving Ix and Enum:
* ------------------------------------------------------------------------*/
-#if DERIVE_ENUM
List deriveEnum(t) /* Construct definition of enumeration */
Tycon t; {
- Int l = tycon(t).line;
- Cell x = inventVar();
- Cell y = inventVar();
+ Int l = tycon(t).line;
+ Cell x = inventVar();
+ Cell y = inventVar();
Cell first = hd(tycon(t).defn);
- Cell last = tycon(t).defn;
+ Cell last = tycon(t).defn;
if (!isEnumType(t)) {
ERRMSG(l) "Can only derive instances of Enum for enumeration types"
implementTagToCon(t);
return cons(mkBind("toEnum", mkVarAlts(l,tycon(t).tagToCon)),
cons(mkBind("fromEnum", mkVarAlts(l,tycon(t).conToTag)),
- cons(mkBind("enumFrom", singleton(pair(singleton(x), pair(mkInt(l),ap2(varEnumFromTo,x,last))))),
- /* default instance of enumFromTo is good */
- cons(mkBind("enumFromThen",singleton(pair(doubleton(x,y),pair(mkInt(l),ap3(varEnumFromThenTo,x,y,ap(COND,triple(ap2(varLe,x,y),last,first))))))),
- /* default instance of enumFromThenTo is good */
- NIL))));
+ NIL));
}
-#endif /* DERIVE_ENUM */
-#if DERIVE_IX
-static List local mkIxBindsEnum Args((Tycon));
-static List local mkIxBinds Args((Int,Cell,Int));
-static Cell local prodRange Args((Int,List,Cell,Cell,Cell));
-static Cell local prodIndex Args((Int,List,Cell,Cell,Cell));
-static Cell local prodInRange Args((Int,List,Cell,Cell,Cell));
+
+static List local mkIxBindsEnum ( Tycon );
+static List local mkIxBinds ( Int,Cell,Int );
+static Cell local prodRange ( Int,List,Cell,Cell,Cell );
+static Cell local prodIndex ( Int,List,Cell,Cell,Cell );
+static Cell local prodInRange ( Int,List,Cell,Cell,Cell );
List deriveIx(t) /* Construct definition of indexing */
Tycon t; {
- Int l = tycon(t).line;
if (isEnumType(t)) { /* Definitions for enumerations */
implementConToTag(t);
implementTagToCon(t);
} else if (isTycon(t) && cfunOf(hd(tycon(t).defn))==0) {
return mkIxBinds(tycon(t).line,
hd(tycon(t).defn),
- name(hd(tycon(t).defn)).arity);
+ userArity(hd(tycon(t).defn)));
}
ERRMSG(tycon(t).line)
"Can only derive instances of Ix for enumeration or product types"
Cell c1 = inventVar();
Cell c2 = inventVar();
Cell ci = inventVar();
- return cons(mkBind("range", singleton(pair(singleton(ap2(mkTuple(2),c1,c2)), pair(mkInt(l),ap2(varMap,tagToCon,ap2(varEnumFromTo,ap(conToTag,c1),ap(conToTag,c2))))))),
- cons(mkBind("index", singleton(pair(doubleton(ap(ASPAT,pair(b,ap2(mkTuple(2),c1,c2))),ci),
- pair(mkInt(l),ap(COND,triple(ap2(varInRange,b,ci),
- ap2(varMinus,ap(conToTag,ci),ap(conToTag,c1)),
- ap(varError,mkStr(findText("Ix.index: Index out of range"))))))))),
- cons(mkBind("inRange",singleton(pair(doubleton(ap2(mkTuple(2),c1,c2),ci), pair(mkInt(l),ap2(varAnd,ap2(varLe,ap(conToTag,c1),ap(conToTag,ci)),ap2(varLe,ap(conToTag,ci),ap(conToTag,c2))))))), /* ToDo: share conToTag ci */
+ return cons(mkBind("range", singleton(pair(singleton(ap2(mkTuple(2),
+ c1,c2)), pair(mkInt(l),ap2(nameMap,tagToCon,
+ ap2(nameFromTo,ap(conToTag,c1),
+ ap(conToTag,c2))))))),
+ cons(mkBind("index", singleton(pair(doubleton(ap(ASPAT,pair(b,
+ ap2(mkTuple(2),c1,c2))),ci),
+ pair(mkInt(l),ap(COND,
+ triple(ap2(nameInRange,b,ci),
+ ap2(nameMinus,ap(conToTag,ci),
+ ap(conToTag,c1)),
+ ap(nameError,mkStr(findText(
+ "Ix.index: Index out of range"))))))))),
+ cons(mkBind("inRange",singleton(pair(doubleton(ap2(mkTuple(2),
+ c1,c2),ci), pair(mkInt(l),ap2(nameAnd,
+ ap2(nameLe,ap(conToTag,c1),ap(conToTag,ci)),
+ ap2(nameLe,ap(conToTag,ci),
+ ap(conToTag,c2))))))),
+ /* ToDo: share conToTag ci */
NIL)));
}
Cell ls = h;
Cell us = h;
Cell is = h;
+ Cell js = h;
Cell pr = NIL;
Cell pats = NIL;
+
Int i;
for (i=0; i<n; ++i, vs=tl(vs)) { /* build three patterns for values */
ls = ap(ls,hd(vs)); /* of the datatype concerned */
us = ap(us,hd(vs=tl(vs)));
is = ap(is,hd(vs=tl(vs)));
+ js = ap(js,hd(vs)); /* ... and one expression */
}
pr = ap2(mkTuple(2),ls,us); /* Build (ls,us) */
pats = cons(pr,cons(is,NIL)); /* Build [(ls,us),is] */
- return cons(prodRange(line,singleton(pr),ls,us,is),
+ return cons(prodRange(line,singleton(pr),ls,us,js),
cons(prodIndex(line,pats,ls,us,is),
cons(prodInRange(line,pats,ls,us,is),
NIL)));
List e = NIL;
for (; isAp(ls); ls=fun(ls), us=fun(us), is=fun(is)) {
e = cons(ap(FROMQUAL,pair(arg(is),
- ap(varRange,ap2(mkTuple(2),
+ ap(nameRange,ap2(mkTuple(2),
arg(ls),
arg(us))))),e);
}
List xs = NIL;
Cell e = NIL;
for (; isAp(ls); ls=fun(ls), us=fun(us), is=fun(is)) {
- xs = cons(ap2(varIndex,ap2(mkTuple(2),arg(ls),arg(us)),arg(is)),xs);
+ xs = cons(ap2(nameIndex,ap2(mkTuple(2),arg(ls),arg(us)),arg(is)),xs);
}
for (e=hd(xs); nonNull(xs=tl(xs));) {
Cell x = hd(xs);
- e = ap2(varPlus,x,ap2(varMult,ap(varRangeSize,arg(fun(x))),e));
+ e = ap2(namePlus,x,ap2(nameMult,ap(nameRangeSize,arg(fun(x))),e));
}
e = singleton(pair(pats,pair(mkInt(line),e)));
return mkBind("index",e);
* inRange (X a b c, X p q r) (X x y z)
* = inRange (a,p) x && inRange (b,q) y && inRange (c,r) z
*/
- Cell e = ap2(varInRange,ap2(mkTuple(2),arg(ls),arg(us)),arg(is));
+ Cell e = ap2(nameInRange,ap2(mkTuple(2),arg(ls),arg(us)),arg(is));
while (ls=fun(ls), us=fun(us), is=fun(is), isAp(ls)) {
- e = ap2(varAnd,
- ap2(varInRange,ap2(mkTuple(2),arg(ls),arg(us)),arg(is)),
+ e = ap2(nameAnd,
+ ap2(nameInRange,ap2(mkTuple(2),arg(ls),arg(us)),arg(is)),
e);
}
e = singleton(pair(pats,pair(mkInt(line),e)));
return mkBind("inRange",e);
}
-#endif /* DERIVE_IX */
+
/* --------------------------------------------------------------------------
* Deriving Show:
* ------------------------------------------------------------------------*/
-#if DERIVE_SHOW
-
-static Cell local mkAltShow Args((Int,Cell,Int));
-static Cell local showsPrecRhs Args((Cell,Cell));
-
List deriveShow(t) /* Construct definition of text conversion */
Tycon t; {
List alts = NIL;
if (isTycon(t)) { /* deal with type constrs */
List cs = tycon(t).defn;
for (; hasCfun(cs); cs=tl(cs)) {
- alts = cons(mkAltShow(tycon(t).line,hd(cs),name(hd(cs)).arity),
+ alts = cons(mkAltShow(tycon(t).line,hd(cs),userArity(hd(cs))),
alts);
}
alts = rev(alts);
List vs = getDiVars(a+1);
Cell d = hd(vs);
Cell pat = h;
- while (vs=tl(vs), 0<a--) {
+ List pats = NIL;
+ Int i = 0;
+ for (vs=tl(vs); i<a; i++) {
pat = ap(pat,hd(vs));
+ vs = tl(vs);
}
- return pair(doubleton(d,pat),
- pair(mkInt(line),showsPrecRhs(d,pat)));
+ pats = cons(d,cons(pat,NIL));
+ return pair(pats,pair(mkInt(line),showsPrecRhs(d,pat,a)));
}
-#define consChar(c) ap(conCons,mkChar(c))
-#define shows0 ap(varShowsPrec,mkInt(0))
-#define shows10 ap(varShowsPrec,mkInt(10))
-#define showsOP ap(varCompose,consChar('('))
-#define showsOB ap(varCompose,consChar('{'))
-#define showsCM ap(varCompose,consChar(','))
-#define showsSP ap(varCompose,consChar(' '))
-#define showsBQ ap(varCompose,consChar('`'))
+#define shows0 ap(nameShowsPrec,mkInt(0))
+#define shows10 ap(nameShowsPrec,mkInt(10))
+#define showsOP ap(nameComp,consChar('('))
+#define showsOB ap(nameComp,consChar('{'))
+#define showsCM ap(nameComp,consChar(','))
+#define showsSP ap(nameComp,consChar(' '))
+#define showsBQ ap(nameComp,consChar('`'))
#define showsCP consChar(')')
#define showsCB consChar('}')
-static Cell local showsPrecRhs(d,pat) /* build a rhs for showsPrec for a */
-Cell d, pat; { /* given pattern, pat */
+static Cell local showsPrecRhs(d,pat,a) /* build a rhs for showsPrec for a */
+Cell d, pat; /* given pattern, pat */
+Int a; {
Cell h = getHead(pat);
List cfs = cfunSfuns;
Int i = tupleOf(h);
Cell rhs = showsCP;
for (; i>1; --i) {
- rhs = ap(showsCM,ap2(varCompose,ap(shows0,arg(pat)),rhs));
+ rhs = ap(showsCM,ap2(nameComp,ap(shows0,arg(pat)),rhs));
pat = fun(pat);
}
- return ap(showsOP,ap2(varCompose,ap(shows0,arg(pat)),rhs));
+ return ap(showsOP,ap2(nameComp,ap(shows0,arg(pat)),rhs));
}
for (; nonNull(cfs) && h!=fst(hd(cfs)); cfs=tl(cfs)) {
* = showString lab . showChar '=' . shows val
*/
Cell rhs = showsCB;
- List vs = revDupOnto(snd(hd(cfs)),NIL);
+ List vs = dupOnto(snd(hd(cfs)),NIL);
if (isAp(pat)) {
for (;;) {
- rhs = ap2(varCompose,
- ap2(varShowField,
+ rhs = ap2(nameComp,
+ ap2(nameShowField,
mkStr(textOf(hd(vs))),
arg(pat)),
rhs);
}
}
}
- rhs = ap2(varCompose,ap(varAppend,mkStr(name(h).text)),ap(showsOB,rhs));
+ rhs = ap2(nameComp,ap(nameApp,mkStr(name(h).text)),ap(showsOB,rhs));
return rhs;
- } else if (name(h).arity==0) {
+ }
+ else if (a==0) {
/* To display a nullary constructor:
* showsPrec d Foo = showString "Foo"
*/
- return ap(varAppend,mkStr(name(h).text));
+ return ap(nameApp,mkStr(name(h).text));
} else {
- Syntax s = syntaxOf(name(h).text);
- if (name(h).arity==2 && assocOf(s)!=APPLIC) {
+ Syntax s = syntaxOf(h);
+ if (a==2 && assocOf(s)!=APPLIC) {
/* For a binary constructor with prec p:
* showsPrec d (a :* b) = showParen (d > p)
* (showsPrec lp a . showChar ' ' .
Int p = precOf(s);
Int lp = (assocOf(s)==LEFT_ASS) ? p : (p+1);
Int rp = (assocOf(s)==RIGHT_ASS) ? p : (p+1);
- Cell rhs = ap(showsSP,ap2(varShowsPrec,mkInt(rp),arg(pat)));
+ Cell rhs = ap(showsSP,ap2(nameShowsPrec,mkInt(rp),arg(pat)));
if (defaultSyntax(name(h).text)==APPLIC) {
rhs = ap(showsBQ,
- ap2(varCompose,
- ap(varAppend,mkStr(name(h).text)),
+ ap2(nameComp,
+ ap(nameApp,mkStr(fixLitText(name(h).text))),
ap(showsBQ,rhs)));
} else {
- rhs = ap2(varCompose,ap(varAppend,mkStr(name(h).text)),rhs);
+ rhs = ap2(nameComp,
+ ap(nameApp,mkStr(fixLitText(name(h).text))),rhs);
}
- rhs = ap2(varCompose,
- ap2(varShowsPrec,mkInt(lp),arg(fun(pat))),
+
+ rhs = ap2(nameComp,
+ ap2(nameShowsPrec,mkInt(lp),arg(fun(pat))),
ap(showsSP,rhs));
- rhs = ap2(varShowParen,ap2(varLe,mkInt(p+1),d),rhs);
+ rhs = ap2(nameShowParen,ap2(nameLe,mkInt(p+1),d),rhs);
return rhs;
- } else {
+ }
+ else {
/* To display a non-nullary constructor with applicative syntax:
* showsPrec d (Foo x y) = showParen (d>=10)
* (showString "Foo" .
*/
Cell rhs = ap(showsSP,ap(shows10,arg(pat)));
for (pat=fun(pat); isAp(pat); pat=fun(pat)) {
- rhs = ap(showsSP,ap2(varCompose,ap(shows10,arg(pat)),rhs));
+ rhs = ap(showsSP,ap2(nameComp,ap(shows10,arg(pat)),rhs));
}
- rhs = ap2(varCompose,ap(varAppend,mkStr(name(h).text)),rhs);
- rhs = ap2(varShowParen,ap2(varLe,mkInt(10),d),rhs);
+ rhs = ap2(nameComp,ap(nameApp,mkStr(name(h).text)),rhs);
+ rhs = ap2(nameShowParen,ap2(nameLe,mkInt(10),d),rhs);
return rhs;
}
}
#undef showsBQ
#undef showsCP
#undef showsCB
-#undef consChar
-
-#endif /* DERIVE_SHOW */
/* --------------------------------------------------------------------------
* Deriving Read:
* ------------------------------------------------------------------------*/
-#if DERIVE_READ
-
-static Cell local mkReadCon Args((Name,Cell,Cell));
-static Cell local mkReadPrefix Args((Cell));
-static Cell local mkReadInfix Args((Cell));
-static Cell local mkReadTuple Args((Cell));
-static Cell local mkReadRecord Args((Cell,List));
-
#define Tuple2(f,s) ap2(mkTuple(2),f,s)
-#define Lex(r) ap(varLex,r)
+#define Lex(r) ap(nameLex,r)
#define ZFexp(h,q) ap(FROMQUAL, pair(h,q))
-#define ReadsPrec(n,e) ap2(varReadsPrec,n,e)
+#define ReadsPrec(n,e) ap2(nameReadsPrec,n,e)
#define Lambda(v,e) ap(LAMBDA,pair(v, pair(mkInt(0),e)))
-#define ReadParen(a,b,c) ap3(varReadParen,a,b,c)
-#define ReadField(f,s) ap2(varReadField,f,s)
-#define GT(l,r) ap2(varGt,l,r)
-#define Append(a,b) ap2(varAppend,a,b)
+#define ReadParen(a,b,c) ap(ap2(nameReadParen,a,b),c)
+#define ReadField(f,s) ap2(nameReadField,f,s)
+#define GT(l,r) ap2(nameGt,l,r)
+#define Append(a,b) ap2(nameApp,a,b)
/* Construct the readsPrec function of the form:
*
* ...
* (readParen (d>pn) (\r -> [ (Cn ...,s) | ... ]) r) ... ))
*/
-List deriveRead(t) /* construct definition of text reader */
+List deriveRead(t) /* construct definition of text reader */
Cell t; {
Cell alt = NIL;
Cell exp = NIL;
if (isTycon(t)) {
List cs = tycon(t).defn;
List exps = NIL;
- for(; hasCfun(cs); cs=tl(cs)) {
+ for (; hasCfun(cs); cs=tl(cs)) {
exps = cons(mkReadCon(hd(cs),d,r),exps);
}
/* reverse concatenate list of subexpressions */
exp = hd(exps);
- for(exps=tl(exps); nonNull(exps); exps=tl(exps)) {
- exp = ap2(varAppend,hd(exps),exp);
+ for (exps=tl(exps); nonNull(exps); exps=tl(exps)) {
+ exp = ap2(nameApp,hd(exps),exp);
}
line = tycon(t).line;
- } else { /* Tuples */
+ }
+ else { /* Tuples */
exp = ap(mkReadTuple(t),r);
}
/* printExp(stdout,exp); putc('\n',stdout); */
*
* for a (non-tuple) constructor "con" of precedence "p".
*/
+
static Cell local mkReadCon(con, d, r) /* generate reader for a constructor */
Name con;
Cell d;
Cell r; {
Cell exp = NIL;
Int p = 0;
- Syntax s = syntaxOf(name(con).text);
+ Syntax s = syntaxOf(con);
List cfs = cfunSfuns;
for (; nonNull(cfs) && con!=fst(hd(cfs)); cfs=tl(cfs)) {
}
if (nonNull(cfs)) {
exp = mkReadRecord(con,snd(hd(cfs)));
- p = 9;
- } else if (name(con).arity==2 && assocOf(s)!=APPLIC) {
+ return ReadParen(nameFalse, exp, r);
+ }
+
+ if (userArity(con)==2 && assocOf(s)!=APPLIC) {
exp = mkReadInfix(con);
p = precOf(s);
} else {
exp = mkReadPrefix(con);
p = 9;
}
- return ReadParen(name(con).arity==0 ? varFalse : GT(d,mkInt(p)),
- exp,
- r);
+ return ReadParen(userArity(con)==0 ? nameFalse : GT(d,mkInt(p)), exp, r);
}
/* Given an n-ary prefix constructor, generate a single lambda
*/
static Cell local mkReadPrefix(con) /* readsPrec for prefix constructor */
Cell con; {
- Int arity = name(con).arity;
+ Int arity = userArity(con);
Cell cn = mkStr(name(con).text);
Cell r = inventVar();
Cell prev_s = inventVar();
static Cell local mkReadInfix( con )
Cell con;
{
- Syntax s = syntaxOf(name(con).text);
+ Syntax s = syntaxOf(con);
Int p = precOf(s);
Int lp = assocOf(s)==LEFT_ASS ? p : (p+1);
Int rp = assocOf(s)==RIGHT_ASS ? p : (p+1);
#undef GT
#undef Append
-#endif /* DERIVE_READ */
-
/* --------------------------------------------------------------------------
* Deriving Bounded:
* ------------------------------------------------------------------------*/
-#if DERIVE_BOUNDED
-
-static List local mkBndBinds Args((Int,Cell,Int));
-
-List deriveBounded(t) /* construct definition of bounds */
+List deriveBounded(t) /* construct definition of bounds */
Tycon t; {
if (isEnumType(t)) {
Cell last = tycon(t).defn;
return cons(mkBind("minBound",mkVarAlts(tycon(t).line,first)),
cons(mkBind("maxBound",mkVarAlts(tycon(t).line,hd(last))),
NIL));
- } else if (isTuple(t)) { /* Definitions for product types */
+ } else if (isTuple(t)) { /* Definitions for product types */
return mkBndBinds(0,t,tupleOf(t));
} else if (isTycon(t) && cfunOf(hd(tycon(t).defn))==0) {
return mkBndBinds(tycon(t).line,
hd(tycon(t).defn),
- name(hd(tycon(t).defn)).arity);
+ userArity(hd(tycon(t).defn)));
}
ERRMSG(tycon(t).line)
"Can only derive instances of Bounded for enumeration and product types"
Cell minB = h;
Cell maxB = h;
while (n-- > 0) {
- minB = ap(minB,varMinBound);
- maxB = ap(maxB,varMaxBound);
+ minB = ap(minB,nameMinBnd);
+ maxB = ap(maxB,nameMaxBnd);
}
return cons(mkBind("minBound",mkVarAlts(line,minB)),
- cons(mkBind("maxBound",mkVarAlts(line,maxB)),
- NIL));
+ cons(mkBind("maxBound",mkVarAlts(line,maxB)),
+ NIL));
}
-#endif /* DERIVE_BOUNDED */
/* --------------------------------------------------------------------------
- * Static Analysis control:
+ * Helpers: conToTag and tagToCon
+ * ------------------------------------------------------------------------*/
+
+/* \ v -> case v of { ...; Ci _ _ -> i; ... } */
+Void implementConToTag(t)
+Tycon t; {
+ if (isNull(tycon(t).conToTag)) {
+ List cs = tycon(t).defn;
+ Name nm = newName(inventText(),NIL);
+ StgVar v = mkStgVar(NIL,NIL);
+ List alts = NIL; /* can't fail */
+
+ assert(isTycon(t) && (tycon(t).what==DATATYPE
+ || tycon(t).what==NEWTYPE));
+ for (; hasCfun(cs); cs=tl(cs)) {
+ Name c = hd(cs);
+ Int num = cfunOf(c) == 0 ? 0 : cfunOf(c)-1;
+ StgVar r = mkStgVar(mkStgCon(nameMkI,singleton(mkInt(num))),
+ NIL);
+ StgExpr tag = mkStgLet(singleton(r),r);
+ List vs = NIL;
+ Int i;
+ for(i=0; i < name(c).arity; ++i) {
+ vs = cons(mkStgVar(NIL,NIL),vs);
+ }
+ alts = cons(mkStgCaseAlt(c,vs,tag),alts);
+ }
+
+ name(nm).line = tycon(t).line;
+ name(nm).type = conToTagType(t);
+ name(nm).arity = 1;
+ name(nm).stgVar = mkStgVar(mkStgLambda(singleton(v),mkStgCase(v,alts)),
+ NIL);
+ tycon(t).conToTag = nm;
+ /* hack to make it print out */
+ stgGlobals = cons(pair(nm,name(nm).stgVar),stgGlobals);
+ }
+}
+
+/* \ v -> case v of { ...; i -> Ci; ... } */
+Void implementTagToCon(t)
+Tycon t; {
+ if (isNull(tycon(t).tagToCon)) {
+ String tyconname;
+ List cs;
+ Name nm;
+ StgVar v1;
+ StgVar v2;
+ Cell txt0;
+ StgVar bind1;
+ StgVar bind2;
+ StgVar bind3;
+ List alts;
+ char etxt[200];
+
+ assert(nameMkA);
+ assert(nameUnpackString);
+ assert(nameError);
+ assert(isTycon(t) && (tycon(t).what==DATATYPE
+ || tycon(t).what==NEWTYPE));
+
+ tyconname = textToStr(tycon(t).text);
+ if (strlen(tyconname) > 100)
+ internal("implementTagToCon: tycon name too long");
+
+ sprintf(etxt,
+ "out-of-range arg for `toEnum' "
+ "in derived `instance Enum %s'",
+ tyconname);
+
+ cs = tycon(t).defn;
+ nm = newName(inventText(),NIL);
+ v1 = mkStgVar(NIL,NIL);
+ v2 = mkStgPrimVar(NIL,mkStgRep(INT_REP),NIL);
+
+ txt0 = mkStr(findText(etxt));
+ bind1 = mkStgVar(mkStgCon(nameMkA,singleton(txt0)),NIL);
+ bind2 = mkStgVar(mkStgApp(nameUnpackString,singleton(bind1)),NIL);
+ bind3 = mkStgVar(mkStgApp(nameError,singleton(bind2)),NIL);
+
+ alts = singleton(
+ mkStgPrimAlt(
+ singleton(
+ mkStgPrimVar(NIL,mkStgRep(INT_REP),NIL)
+ ),
+ makeStgLet ( tripleton(bind1,bind2,bind3), bind3 )
+ )
+ );
+
+ for (; hasCfun(cs); cs=tl(cs)) {
+ Name c = hd(cs);
+ Int num = cfunOf(c) == 0 ? 0 : cfunOf(c)-1;
+ StgVar pat = mkStgPrimVar(mkInt(num),mkStgRep(INT_REP),NIL);
+ assert(name(c).arity==0);
+ alts = cons(mkStgPrimAlt(singleton(pat),c),alts);
+ }
+
+ name(nm).line = tycon(t).line;
+ name(nm).type = tagToConType(t);
+ name(nm).arity = 1;
+ name(nm).stgVar = mkStgVar(
+ mkStgLambda(
+ singleton(v1),
+ mkStgCase(
+ v1,
+ singleton(
+ mkStgCaseAlt(
+ nameMkI,
+ singleton(v2),
+ mkStgPrimCase(v2,alts))))),
+ NIL
+ );
+ tycon(t).tagToCon = nm;
+ /* hack to make it print out */
+ stgGlobals = cons(pair(nm,name(nm).stgVar),stgGlobals);
+ }
+}
+
+
+/* --------------------------------------------------------------------------
+ * Derivation control:
* ------------------------------------------------------------------------*/
Void deriveControl(what)
Int what; {
- Text textPrelude = findText("PreludeBuiltin");
switch (what) {
- case INSTALL :
- varTrue = mkQVar(textPrelude,findText("True"));
- varFalse = mkQVar(textPrelude,findText("False"));
-#if DERIVE_ORD
- varCompAux = mkQVar(textPrelude,findText("primCompAux"));
- varCompare = mkQVar(textPrelude,findText("compare"));
- varEQ = mkQVar(textPrelude,findText("EQ"));
-#endif
-#if DERIVE_IX
- varRangeSize = mkQVar(textPrelude,findText("rangeSize"));
- varInRange = mkQVar(textPrelude,findText("inRange"));
- varRange = mkQVar(textPrelude,findText("range"));
- varIndex = mkQVar(textPrelude,findText("index"));
- varMult = mkQVar(textPrelude,findText("*"));
- varPlus = mkQVar(textPrelude,findText("+"));
- varMap = mkQVar(textPrelude,findText("map"));
- varMinus = mkQVar(textPrelude,findText("-"));
- varError = mkQVar(textPrelude,findText("error"));
-#endif
-#if DERIVE_ENUM
- varToEnum = mkQVar(textPrelude,findText("toEnum"));
- varFromEnum = mkQVar(textPrelude,findText("fromEnum"));
- varEnumFromTo = mkQVar(textPrelude,findText("enumFromTo"));
- varEnumFromThenTo = mkQVar(textPrelude,findText("enumFromThenTo"));
-#endif
-#if DERIVE_BOUNDED
- varMinBound = mkQVar(textPrelude,findText("minBound"));
- varMaxBound = mkQVar(textPrelude,findText("maxBound"));
-#endif
-#if DERIVE_SHOW
- conCons = mkQCon(textPrelude,findText(":"));
- varShowField = mkQVar(textPrelude,findText("primShowField"));
- varShowParen = mkQVar(textPrelude,findText("showParen"));
- varCompose = mkQVar(textPrelude,findText("."));
- varShowsPrec = mkQVar(textPrelude,findText("showsPrec"));
- varLe = mkQVar(textPrelude,findText("<="));
-#endif
-#if DERIVE_READ
- varReadField = mkQVar(textPrelude,findText("primReadField"));
- varReadParen = mkQVar(textPrelude,findText("readParen"));
- varLex = mkQVar(textPrelude,findText("lex"));
- varReadsPrec = mkQVar(textPrelude,findText("readsPrec"));
- varGt = mkQVar(textPrelude,findText(">"));
-#endif
-#if DERIVE_SHOW || DERIVE_READ
- varAppend = mkQVar(textPrelude,findText("++"));
-#endif
-#if DERIVE_EQ || DERIVE_IX
- varAnd = mkQVar(textPrelude,findText("&&"));
-#endif
-#if DERIVE_EQ || DERIVE_ORD
- varEq = mkQVar(textPrelude,findText("=="));
-#endif
- /* deliberate fall through */
+ case PREPREL :
case RESET :
diVars = NIL;
diNum = 0;
-#if DERIVE_SHOW | DERIVE_READ
cfunSfuns = NIL;
-#endif
break;
case MARK :
mark(diVars);
-#if DERIVE_SHOW | DERIVE_READ
mark(cfunSfuns);
-#endif
- mark(varTrue);
- mark(varFalse);
-#if DERIVE_ORD
- mark(varCompAux);
- mark(varCompare);
- mark(varEQ);
-#endif
-#if DERIVE_IX
- mark(varRangeSize);
- mark(varInRange);
- mark(varRange);
- mark(varIndex);
- mark(varMult);
- mark(varPlus);
- mark(varMap);
- mark(varMinus);
- mark(varError);
-#endif
-#if DERIVE_ENUM
- mark(varToEnum);
- mark(varFromEnum);
- mark(varEnumFromTo);
- mark(varEnumFromThenTo);
-#endif
-#if DERIVE_BOUNDED
- mark(varMinBound);
- mark(varMaxBound);
-#endif
-#if DERIVE_SHOW
- mark(conCons);
- mark(varShowField);
- mark(varShowParen);
- mark(varCompose);
- mark(varShowsPrec);
- mark(varLe);
-#endif
-#if DERIVE_READ
- mark(varReadField);
- mark(varReadParen);
- mark(varLex);
- mark(varReadsPrec);
- mark(varGt);
-#endif
-#if DERIVE_SHOW || DERIVE_READ
- mark(varAppend);
-#endif
-#if DERIVE_EQ || DERIVE_IX
- mark(varAnd);
-#endif
-#if DERIVE_EQ || DERIVE_ORD
- mark(varEq);
-#endif
break;
+
+ case POSTPREL: break;
}
}
projects / ghc-hetmet.git / blobdiff