X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;ds=sidebyside;f=ghc%2Finterpreter%2Fderive.c;h=cd83f893d949a0c9fd541a98795df6f83ebcb836;hb=7e150969472ef9a48af9a7a2cc23a84952e90078;hp=3f2f23450012d640556020017675425504d5be91;hpb=438596897ebbe25a07e1c82085cfbc5bdb00f09e;p=ghc-hetmet.git diff --git a/ghc/interpreter/derive.c b/ghc/interpreter/derive.c index 3f2f234..cd83f89 100644 --- a/ghc/interpreter/derive.c +++ b/ghc/interpreter/derive.c @@ -1,99 +1,57 @@ -/* -*- 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 */ @@ -115,7 +73,6 @@ Cell r; { 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 */ @@ -136,9 +93,7 @@ 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)) { @@ -148,11 +103,12 @@ Tycon t; { /* type (i.e. all constructors arity == 0) */ 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) @@ -172,9 +128,7 @@ Tycon t; { /* type (i.e. all constructors arity == 0) */ * 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 */ @@ -183,12 +137,12 @@ 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 */ @@ -202,21 +156,19 @@ Int line; /* using patterns in pats for lhs */ 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 */ @@ -227,18 +179,18 @@ 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) { @@ -247,7 +199,7 @@ Type t; { /* for some TUPLE or DATATYPE t */ 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); @@ -264,31 +216,30 @@ Int line; /* using patterns in pats for lhs */ 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" @@ -302,24 +253,18 @@ Tycon t; { 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); @@ -329,7 +274,7 @@ Tycon 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" @@ -354,12 +299,24 @@ Tycon t; { 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))); } @@ -371,19 +328,22 @@ Int n; { Cell ls = h; Cell us = h; Cell is = h; + Cell js = h; Cell pr = NIL; Cell pats = NIL; + Int i; for (i=0; i1; --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)) { @@ -536,11 +494,11 @@ Cell d, pat; { /* given pattern, pat */ * = 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); @@ -553,16 +511,17 @@ Cell d, pat; { /* given pattern, pat */ } } } - 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 ' ' . @@ -572,21 +531,24 @@ Cell d, pat; { /* given pattern, pat */ 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" . @@ -595,10 +557,10 @@ Cell d, pat; { /* given pattern, pat */ */ 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; } } @@ -612,31 +574,20 @@ Cell d, pat; { /* given pattern, pat */ #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: * @@ -645,7 +596,7 @@ static Cell local mkReadRecord Args((Cell,List)); * ... * (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; @@ -657,16 +608,17 @@ Cell t; { 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); */ @@ -680,29 +632,30 @@ Cell t; { * * 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 @@ -721,7 +674,7 @@ Cell r; { */ 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(); @@ -758,7 +711,7 @@ Cell con; { 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); @@ -884,17 +837,11 @@ List fs; { #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; @@ -905,12 +852,12 @@ Tycon t; { 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" @@ -925,144 +872,155 @@ Int n; { 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; } }