/* -------------------------------------------------------------------------- * This is the Hugs compiler, handling translation of typechecked code to * `kernel' language, elimination of pattern matching and translation to * super combinators (lambda lifting). * * The Hugs 98 system is Copyright (c) Mark P Jones, Alastair Reid, the * Yale Haskell Group, and the OGI School of Science & Engineering at OHSU, * 1994-2003, All rights reserved. It is distributed as free software under * the license in the file "License", which is included in the distribution. * * $RCSfile: compiler.c,v $ * $Revision: 1.25 $ * $Date: 2003/12/04 13:53:50 $ * ------------------------------------------------------------------------*/ #include "prelude.h"#include "storage.h"#include "connect.h"#include "errors.h"#include "goal.h"#include "char.h"#include "output.h" /* needed for DEBUG_CODE|DEBUG_SHOWSC */#include "opts.h" /* needed for DEBUG_SHOWSC */ Addr inputCode; /* Addr of compiled code for expr */static Name currentName; /* Top level name being processed */#if DEBUG_SHOWSCstatic FILE *scfp; /* super combinator file pointer */#endif /* -------------------------------------------------------------------------- * Local function prototypes: * ------------------------------------------------------------------------*/ static Cell local translate Args((Cell));static Void local transPair Args((Pair));static Void local transTriple Args((Triple));static Void local transAlt Args((Cell));static Void local transCase Args((Cell));static List local transBinds Args((List));static Cell local transRhs Args((Cell));static Cell local mkConsList Args((List));static Cell local expandLetrec Args((Cell));static Cell local transComp Args((Cell,List,Cell));static Cell local transDo Args((Cell,Cell,List));static Cell local transConFlds Args((Cell,List));static Cell local transUpdFlds Args((Cell,List,List)); #if MUDOstatic Cell local transMDo Args((Cell,Cell,List));static Cell local mdoBuildTuple Args((List));#endif static Cell local refutePat Args((Cell));static Cell local refutePatAp Args((Cell));static Cell local matchPat Args((Cell));static List local remPat Args((Cell,Cell,List));static List local remPat1 Args((Cell,Cell,List)); static Cell local pmcTerm Args((Int,List,Cell));static Cell local pmcPair Args((Int,List,Pair));static Cell local pmcTriple Args((Int,List,Triple));static Cell local pmcVar Args((List,Text));static Void local pmcLetrec Args((Int,List,Pair));static Cell local pmcVarDef Args((Int,List,List));static Void local pmcFunDef Args((Int,List,Triple));static List local altsMatch Args((Int,Int,List,List));static Cell local match Args((Int,List));static Cell local joinMas Args((Int,List));static Bool local canFail Args((Cell));static List local addConTable Args((Cell,Cell,List));static Void local advance Args((Int,Int,Cell));static Bool local emptyMatch Args((Cell));static Cell local maDiscr Args((Cell));static Bool local isNumDiscr Args((Cell));static Bool local eqNumDiscr Args((Cell,Cell));#if TREXstatic Bool local isExtDiscr Args((Cell));static Bool local eqExtDiscr Args((Cell,Cell));#endif static Cell local lift Args((Int,List,Cell));static Void local liftPair Args((Int,List,Pair));static Void local liftTriple Args((Int,List,Triple));static Void local liftAlt Args((Int,List,Cell));static Void local liftNumcase Args((Int,List,Triple));static Cell local liftVar Args((List,Cell));static Cell local liftLetrec Args((Int,List,Cell));static Void local liftFundef Args((Int,List,Triple));static Void local solve Args((List)); static Cell local preComp Args((Cell));static Cell local preCompPair Args((Pair));static Cell local preCompTriple Args((Triple));static Void local preCompCase Args((Pair));static Cell local preCompOffset Args((Int)); static Void local compileGlobalFunction Args((Pair));static Void local compileGenFunction Args((Name));static Name local compileSelFunction Args((Pair));static Void local newGlobalFunction Args((Name,Int,List,Int,Cell)); #if DEBUG_SHOWSCstatic Void local debugConstructors Args((FILE *fp,Cell c));static Void local debugConstructor Args((FILE *fp,Name c));#endif /* -------------------------------------------------------------------------- * Translation: Convert input expressions into a less complex language * of terms using only LETREC, AP, constants and vars. * Also remove pattern definitions on lhs of eqns. * ------------------------------------------------------------------------*/ static Cell local translate(e) /* Translate expression: */Cell e; { switch (whatIs(e)) { case LETREC : snd(snd(e)) = translate(snd(snd(e))); return expandLetrec(e); case COND : transTriple(snd(e)); return e; case AP : fst(e) = translate(fst(e)); if (fst(e)==nameId || fst(e)==nameInd) return translate(snd(e)); if (isName(fst(e)) && isMfun(fst(e)) && mfunOf(fst(e))==0) return translate(snd(e)); snd(e) = translate(snd(e)); return e; #if BIGNUMS case POSNUM : case ZERONUM : case NEGNUM : return e;#endif case NAME : if (e==nameOtherwise) return nameTrue; if (isCfun(e)) { if (isName(name(e).defn)) return name(e).defn; if (isPair(name(e).defn)) return snd(name(e).defn); } return e; #if TREX case RECSEL : return nameRecSel; case EXT :#endif case TUPLE : case VAROPCELL : case VARIDCELL : case DICTVAR : case INTCELL : case DOUBLECELL : case STRCELL : case CHARCELL : return e; #if IPARAM case IPVAR : return nameId;#endif case FINLIST : mapOver(translate,snd(e)); return mkConsList(snd(e)); case DOCOMP : { Cell m = translate(fst(snd(e))); Cell r = translate(fst(snd(snd(e)))); return transDo(m,r,snd(snd(snd(e)))); } case MONADCOMP : { Cell m = translate(fst(snd(e))); Cell r = translate(fst(snd(snd(e)))); Cell qs = snd(snd(snd(e))); if (m == nameListMonad) return transComp(r,qs,nameNil); else {#if MONAD_COMPS r = ap(ap(nameReturn,m),r); return transDo(m,r,qs);#else internal("translate: monad comps");#endif } }#if MUDO case MDOCOMP : { Cell m = translate(fst(fst(snd(e)))); Cell ms = translate(snd(fst(snd(e)))); Cell r = translate(fst(snd(snd(e)))); Cell segs = snd(snd(snd(e))); map2Over(transMDo,m,ms,segs); return transDo(ms,r,segs); }#endif case CONFLDS : return transConFlds(fst(snd(e)),snd(snd(e))); case UPDFLDS : return transUpdFlds(fst3(snd(e)), snd3(snd(e)), thd3(snd(e))); case CASE : { Cell nv = inventVar(); mapProc(transCase,snd(snd(e))); return ap(LETREC, pair(singleton(pair(nv,snd(snd(e)))), ap(nv,translate(fst(snd(e)))))); } case LAMBDA : { Cell nv = inventVar(); transAlt(snd(e)); return ap(LETREC, pair(singleton(pair( nv, singleton(snd(e)))), nv)); } default : internal("translate"); } return e;} static Void local transPair(pr) /* Translate each component in a */Pair pr; { /* pair of expressions. */ fst(pr) = translate(fst(pr)); snd(pr) = translate(snd(pr));} static Void local transTriple(tr) /* Translate each component in a */Triple tr; { /* triple of expressions. */ fst3(tr) = translate(fst3(tr)); snd3(tr) = translate(snd3(tr)); thd3(tr) = translate(thd3(tr));} static Void local transAlt(e) /* Translate alt: */Cell e; { /* ([Pat], Rhs) ==> ([Pat], Rhs') */ snd(e) = transRhs(snd(e));} static Void local transCase(c) /* Translate case: */Cell c; { /* (Pat, Rhs) ==> ([Pat], Rhs') */ fst(c) = singleton(fst(c)); snd(c) = transRhs(snd(c));} static List local transBinds(bs) /* Translate list of bindings: */List bs; { /* eliminating pattern matching on */ List newBinds = NIL; /* lhs of bindings. */ for (; nonNull(bs); bs=tl(bs)) {#if IPARAM Cell v = fst(hd(bs)); while (isAp(v) && fun(v) == nameInd) v = arg(v); fst(hd(bs)) = v; if (isVar(v)) {#else if (isVar(fst(hd(bs)))) {#endif mapProc(transAlt,snd(hd(bs))); newBinds = cons(hd(bs),newBinds); } else newBinds = remPat(fst(snd(hd(bs))), snd(snd(hd(bs)))=transRhs(snd(snd(hd(bs)))), newBinds); } return newBinds;} static Cell local transRhs(rhs) /* Translate rhs: removing line nos */Cell rhs; { switch (whatIs(rhs)) { case LETREC : snd(snd(rhs)) = transRhs(snd(snd(rhs))); return expandLetrec(rhs); case GUARDED : mapOver(snd,snd(rhs)); /* discard line number */ mapProc(transPair,snd(rhs)); return rhs; default : return translate(snd(rhs)); /* discard line number */ }} static Cell local mkConsList(es) /* Construct expression for list es */List es; { /* using nameNil and nameCons */ if (isNull(es)) return nameNil; else return ap(ap(nameCons,hd(es)),mkConsList(tl(es)));} static Cell local expandLetrec(root) /* translate LETREC with list of */Cell root; { /* groups of bindings (from depend. */ Cell e = snd(snd(root)); /* analysis) to use nested LETRECs */ List bss = fst(snd(root)); Cell temp; if (isNull(bss)) /* should never happen, but just in */ return e; /* case: LETREC [] IN e ==> e */ mapOver(transBinds,bss); /* translate each group of bindings */ for (temp=root; nonNull(tl(bss)); bss=tl(bss)) { fst(snd(temp)) = hd(bss); snd(snd(temp)) = ap(LETREC,pair(NIL,e)); temp = snd(snd(temp)); } fst(snd(temp)) = hd(bss); return root;} /* -------------------------------------------------------------------------- * Translation of list comprehensions is based on the description in * `The Implementation of Functional Programming Languages': * * [ e | qs ] ++ l => transComp e qs l * transComp e [] l => e : l * transComp e ((p<-xs):qs) l => LETREC _h [] = l * _h (p:_xs) = transComp e qs (_h _xs) * _h (_:_xs) = _h _xs --if p !failFree * IN _h xs * transComp e (b:qs) l => if b then transComp e qs l else l * transComp e (decls:qs) l => LETREC decls IN transComp e qs l * ------------------------------------------------------------------------*/ static Cell local transComp(e,qs,l) /* Translate [e | qs] ++ l */Cell e;List qs;Cell l; { if (nonNull(qs)) { Cell q = hd(qs); Cell qs1 = tl(qs); switch (fst(q)) { case FROMQUAL : { Cell ld = NIL; Cell hVar = inventVar(); Cell xsVar = inventVar(); if (!failFree(fst(snd(q)))) ld = cons(pair(singleton( ap(ap(nameCons, WILDCARD), xsVar)), ap(hVar,xsVar)), ld); ld = cons(pair(singleton( ap(ap(nameCons, fst(snd(q))), xsVar)), transComp(e, qs1, ap(hVar,xsVar))), ld); ld = cons(pair(singleton(nameNil), l), ld); return ap(LETREC, pair(singleton(pair(hVar, ld)), ap(hVar, translate(snd(snd(q)))))); } case QWHERE : return expandLetrec(ap(LETREC, pair(snd(q), transComp(e,qs1,l)))); case BOOLQUAL : return ap(COND, triple(translate(snd(q)), transComp(e,qs1,l), l)); } } return ap(ap(nameCons,e),l);} /* -------------------------------------------------------------------------- * Translation of monad comprehensions written using do-notation: * * do { e } => e * do { p <- exp; qs } => LETREC _h p = do { qs } * _h _ = fail m "match fails" * IN bind m exp _h * do { LET decls; qs } => LETREC decls IN do { qs } * do { IF guard; qs } => if guard then do { qs } else fail m "guard fails" * do { exp; qs } => (>>) m exp (do {qs}) * * where m :: Monad f * ------------------------------------------------------------------------*/ static Cell local transDo(m,e,qs) /* Translate do { qs ; e } */Cell m;Cell e;List qs; { if (nonNull(qs)) { Cell q = hd(qs); Cell qs1 = tl(qs); switch (fst(q)) { case FROMQUAL : { Cell ld = NIL; Cell hVar = inventVar(); if (!failFree(fst(snd(q)))) { Cell str = mkStr(findText("match fails")); ld = cons(pair(singleton(WILDCARD), ap2(nameMFail,m,str)), ld); } ld = cons(pair(singleton(fst(snd(q))), transDo(m,e,qs1)), ld); return ap(LETREC, pair(singleton(pair(hVar,ld)), ap(ap(ap(nameBind, m), translate(snd(snd(q)))), hVar))); } case DOQUAL : return ap(ap(ap(nameThen,m), translate(snd(q))), transDo(m,e,qs1)); case QWHERE : return expandLetrec(ap(LETREC, pair(snd(q), transDo(m,e,qs1)))); case BOOLQUAL : return ap(COND, triple(translate(snd(q)), transDo(m,e,qs1), ap2(nameMFail,m, mkStr(findText("guard fails"))))); } } return e;} #if MUDO/* Copied verbatim from parser.y: */static Cell local mdoBuildTuple(tup) /* build tuple (x1,...,xn) from */List tup; { /* list [xn,...,x1] */ Int n = 0; Cell t = tup; Cell x; do { /* . . */ x = fst(t); /* / \ / \ */ fst(t) = snd(t); /* xn . . xn */ snd(t) = x; /* . ===> . */ x = t; /* . . */ t = fun(x); /* . . */ n++; /* / \ / \ */ } while (nonNull(t)); /* x1 NIL (n) x1 */ fst(x) = mkTuple(n); return tup;} static Cell local transMDo(m,ms,seg) /* translate each segment in an mdo */Cell m; /* dictionary for recursive monad */Cell ms; /* dictionary for monad */List seg; { /* seg looks like: ((1,2,3),4) where: 1: rec vars of the segment 2: exp vars of the segment 3: def vars of the segment (not used here) 4: list of qualifiers in the segment */ List qs = snd(seg); List recs = fst3(fst(seg)); List exps = snd3(fst(seg)); Int noOfRecs = length(recs); Int noOfExps = length(exps); /* Case 1: Not a recursive segment. It must be the case that |qs| = 1 */ if(isNull(recs)) { if(length(qs)!=1) { internal("MDO: Non-recursive, non-singleton segment, Impossible!"); } return hd(qs); } #define mkLambda(arg,body) ap(LAMBDA,pair(singleton(arg),pair(0,body)))#define mkDoComp(qs,exp) ap(DOCOMP,pair(ms,pair(exp,qs)))#define BIND(e1,e2) ap3(nameBind,ms,e1,e2)Lines 1–500 of 2180. Load more
/* -------------------------------------------------------------------------- * This is the Hugs compiler, handling translation of typechecked code to * `kernel' language, elimination of pattern matching and translation to * super combinators (lambda lifting). * * The Hugs 98 system is Copyright (c) Mark P Jones, Alastair Reid, the * Yale Haskell Group, and the OGI School of Science & Engineering at OHSU, * 1994-2003, All rights reserved. It is distributed as free software under * the license in the file "License", which is included in the distribution. * * $RCSfile: compiler.c,v $ * $Revision: 1.25 $ * $Date: 2003/12/04 13:53:50 $ * ------------------------------------------------------------------------*/ #include "prelude.h" #include "storage.h" #include "connect.h" #include "errors.h" #include "goal.h" #include "char.h" #include "output.h" /* needed for DEBUG_CODE|DEBUG_SHOWSC */ #include "opts.h" /* needed for DEBUG_SHOWSC */ Addr inputCode; /* Addr of compiled code for expr */ static Name currentName; /* Top level name being processed */ #if DEBUG_SHOWSC static FILE *scfp; /* super combinator file pointer */ #endif /* -------------------------------------------------------------------------- * Local function prototypes: * ------------------------------------------------------------------------*/ static Cell local translate Args((Cell)); static Void local transPair Args((Pair)); static Void local transTriple Args((Triple)); static Void local transAlt Args((Cell)); static Void local transCase Args((Cell)); static List local transBinds Args((List)); static Cell local transRhs Args((Cell)); static Cell local mkConsList Args((List)); static Cell local expandLetrec Args((Cell)); static Cell local transComp Args((Cell,List,Cell)); static Cell local transDo Args((Cell,Cell,List)); static Cell local transConFlds Args((Cell,List)); static Cell local transUpdFlds Args((Cell,List,List)); #if MUDO static Cell local transMDo Args((Cell,Cell,List)); static Cell local mdoBuildTuple Args((List)); #endif static Cell local refutePat Args((Cell)); static Cell local refutePatAp Args((Cell)); static Cell local matchPat Args((Cell)); static List local remPat Args((Cell,Cell,List)); static List local remPat1 Args((Cell,Cell,List)); static Cell local pmcTerm Args((Int,List,Cell)); static Cell local pmcPair Args((Int,List,Pair)); static Cell local pmcTriple Args((Int,List,Triple)); static Cell local pmcVar Args((List,Text)); static Void local pmcLetrec Args((Int,List,Pair)); static Cell local pmcVarDef Args((Int,List,List)); static Void local pmcFunDef Args((Int,List,Triple)); static List local altsMatch Args((Int,Int,List,List)); static Cell local match Args((Int,List)); static Cell local joinMas Args((Int,List)); static Bool local canFail Args((Cell)); static List local addConTable Args((Cell,Cell,List)); static Void local advance Args((Int,Int,Cell)); static Bool local emptyMatch Args((Cell)); static Cell local maDiscr Args((Cell)); static Bool local isNumDiscr Args((Cell)); static Bool local eqNumDiscr Args((Cell,Cell)); #if TREX static Bool local isExtDiscr Args((Cell)); static Bool local eqExtDiscr Args((Cell,Cell)); #endif static Cell local lift Args((Int,List,Cell)); static Void local liftPair Args((Int,List,Pair)); static Void local liftTriple Args((Int,List,Triple)); static Void local liftAlt Args((Int,List,Cell)); static Void local liftNumcase Args((Int,List,Triple)); static Cell local liftVar Args((List,Cell)); static Cell local liftLetrec Args((Int,List,Cell)); static Void local liftFundef Args((Int,List,Triple)); static Void local solve Args((List)); static Cell local preComp Args((Cell)); static Cell local preCompPair Args((Pair)); static Cell local preCompTriple Args((Triple)); static Void local preCompCase Args((Pair)); static Cell local preCompOffset Args((Int)); static Void local compileGlobalFunction Args((Pair)); static Void local compileGenFunction Args((Name)); static Name local compileSelFunction Args((Pair)); static Void local newGlobalFunction Args((Name,Int,List,Int,Cell)); #if DEBUG_SHOWSC static Void local debugConstructors Args((FILE *fp,Cell c)); static Void local debugConstructor Args((FILE *fp,Name c)); #endif /* -------------------------------------------------------------------------- * Translation: Convert input expressions into a less complex language * of terms using only LETREC, AP, constants and vars. * Also remove pattern definitions on lhs of eqns. * ------------------------------------------------------------------------*/ static Cell local translate(e) /* Translate expression: */ Cell e; { switch (whatIs(e)) { case LETREC : snd(snd(e)) = translate(snd(snd(e))); return expandLetrec(e); case COND : transTriple(snd(e)); return e; case AP : fst(e) = translate(fst(e)); if (fst(e)==nameId || fst(e)==nameInd) return translate(snd(e)); if (isName(fst(e)) && isMfun(fst(e)) && mfunOf(fst(e))==0) return translate(snd(e)); snd(e) = translate(snd(e)); return e; #if BIGNUMS case POSNUM : case ZERONUM : case NEGNUM : return e; #endif case NAME : if (e==nameOtherwise) return nameTrue; if (isCfun(e)) { if (isName(name(e).defn)) return name(e).defn; if (isPair(name(e).defn)) return snd(name(e).defn); } return e; #if TREX case RECSEL : return nameRecSel; case EXT : #endif case TUPLE : case VAROPCELL : case VARIDCELL : case DICTVAR : case INTCELL : case DOUBLECELL : case STRCELL : case CHARCELL : return e; #if IPARAM case IPVAR : return nameId; #endif case FINLIST : mapOver(translate,snd(e)); return mkConsList(snd(e)); case DOCOMP : { Cell m = translate(fst(snd(e))); Cell r = translate(fst(snd(snd(e)))); return transDo(m,r,snd(snd(snd(e)))); } case MONADCOMP : { Cell m = translate(fst(snd(e))); Cell r = translate(fst(snd(snd(e)))); Cell qs = snd(snd(snd(e))); if (m == nameListMonad) return transComp(r,qs,nameNil); else { #if MONAD_COMPS r = ap(ap(nameReturn,m),r); return transDo(m,r,qs); #else internal("translate: monad comps"); #endif } } #if MUDO case MDOCOMP : { Cell m = translate(fst(fst(snd(e)))); Cell ms = translate(snd(fst(snd(e)))); Cell r = translate(fst(snd(snd(e)))); Cell segs = snd(snd(snd(e))); map2Over(transMDo,m,ms,segs); return transDo(ms,r,segs); } #endif case CONFLDS : return transConFlds(fst(snd(e)),snd(snd(e))); case UPDFLDS : return transUpdFlds(fst3(snd(e)), snd3(snd(e)), thd3(snd(e))); case CASE : { Cell nv = inventVar(); mapProc(transCase,snd(snd(e))); return ap(LETREC, pair(singleton(pair(nv,snd(snd(e)))), ap(nv,translate(fst(snd(e)))))); } case LAMBDA : { Cell nv = inventVar(); transAlt(snd(e)); return ap(LETREC, pair(singleton(pair( nv, singleton(snd(e)))), nv)); } default : internal("translate"); } return e; } static Void local transPair(pr) /* Translate each component in a */ Pair pr; { /* pair of expressions. */ fst(pr) = translate(fst(pr)); snd(pr) = translate(snd(pr)); } static Void local transTriple(tr) /* Translate each component in a */ Triple tr; { /* triple of expressions. */ fst3(tr) = translate(fst3(tr)); snd3(tr) = translate(snd3(tr)); thd3(tr) = translate(thd3(tr)); } static Void local transAlt(e) /* Translate alt: */ Cell e; { /* ([Pat], Rhs) ==> ([Pat], Rhs') */ snd(e) = transRhs(snd(e)); } static Void local transCase(c) /* Translate case: */ Cell c; { /* (Pat, Rhs) ==> ([Pat], Rhs') */ fst(c) = singleton(fst(c)); snd(c) = transRhs(snd(c)); } static List local transBinds(bs) /* Translate list of bindings: */ List bs; { /* eliminating pattern matching on */ List newBinds = NIL; /* lhs of bindings. */ for (; nonNull(bs); bs=tl(bs)) { #if IPARAM Cell v = fst(hd(bs)); while (isAp(v) && fun(v) == nameInd) v = arg(v); fst(hd(bs)) = v; if (isVar(v)) { #else if (isVar(fst(hd(bs)))) { #endif mapProc(transAlt,snd(hd(bs))); newBinds = cons(hd(bs),newBinds); } else newBinds = remPat(fst(snd(hd(bs))), snd(snd(hd(bs)))=transRhs(snd(snd(hd(bs)))), newBinds); } return newBinds; } static Cell local transRhs(rhs) /* Translate rhs: removing line nos */ Cell rhs; { switch (whatIs(rhs)) { case LETREC : snd(snd(rhs)) = transRhs(snd(snd(rhs))); return expandLetrec(rhs); case GUARDED : mapOver(snd,snd(rhs)); /* discard line number */ mapProc(transPair,snd(rhs)); return rhs; default : return translate(snd(rhs)); /* discard line number */ } } static Cell local mkConsList(es) /* Construct expression for list es */ List es; { /* using nameNil and nameCons */ if (isNull(es)) return nameNil; else return ap(ap(nameCons,hd(es)),mkConsList(tl(es))); } static Cell local expandLetrec(root) /* translate LETREC with list of */ Cell root; { /* groups of bindings (from depend. */ Cell e = snd(snd(root)); /* analysis) to use nested LETRECs */ List bss = fst(snd(root)); Cell temp; if (isNull(bss)) /* should never happen, but just in */ return e; /* case: LETREC [] IN e ==> e */ mapOver(transBinds,bss); /* translate each group of bindings */ for (temp=root; nonNull(tl(bss)); bss=tl(bss)) { fst(snd(temp)) = hd(bss); snd(snd(temp)) = ap(LETREC,pair(NIL,e)); temp = snd(snd(temp)); } fst(snd(temp)) = hd(bss); return root; } /* -------------------------------------------------------------------------- * Translation of list comprehensions is based on the description in * `The Implementation of Functional Programming Languages': * * [ e | qs ] ++ l => transComp e qs l * transComp e [] l => e : l * transComp e ((p<-xs):qs) l => LETREC _h [] = l * _h (p:_xs) = transComp e qs (_h _xs) * _h (_:_xs) = _h _xs --if p !failFree * IN _h xs * transComp e (b:qs) l => if b then transComp e qs l else l * transComp e (decls:qs) l => LETREC decls IN transComp e qs l * ------------------------------------------------------------------------*/ static Cell local transComp(e,qs,l) /* Translate [e | qs] ++ l */ Cell e; List qs; Cell l; { if (nonNull(qs)) { Cell q = hd(qs); Cell qs1 = tl(qs); switch (fst(q)) { case FROMQUAL : { Cell ld = NIL; Cell hVar = inventVar(); Cell xsVar = inventVar(); if (!failFree(fst(snd(q)))) ld = cons(pair(singleton( ap(ap(nameCons, WILDCARD), xsVar)), ap(hVar,xsVar)), ld); ld = cons(pair(singleton( ap(ap(nameCons, fst(snd(q))), xsVar)), transComp(e, qs1, ap(hVar,xsVar))), ld); ld = cons(pair(singleton(nameNil), l), ld); return ap(LETREC, pair(singleton(pair(hVar, ld)), ap(hVar, translate(snd(snd(q)))))); } case QWHERE : return expandLetrec(ap(LETREC, pair(snd(q), transComp(e,qs1,l)))); case BOOLQUAL : return ap(COND, triple(translate(snd(q)), transComp(e,qs1,l), l)); } } return ap(ap(nameCons,e),l); } /* -------------------------------------------------------------------------- * Translation of monad comprehensions written using do-notation: * * do { e } => e * do { p <- exp; qs } => LETREC _h p = do { qs } * _h _ = fail m "match fails" * IN bind m exp _h * do { LET decls; qs } => LETREC decls IN do { qs } * do { IF guard; qs } => if guard then do { qs } else fail m "guard fails" * do { exp; qs } => (>>) m exp (do {qs}) * * where m :: Monad f * ------------------------------------------------------------------------*/ static Cell local transDo(m,e,qs) /* Translate do { qs ; e } */ Cell m; Cell e; List qs; { if (nonNull(qs)) { Cell q = hd(qs); Cell qs1 = tl(qs); switch (fst(q)) { case FROMQUAL : { Cell ld = NIL; Cell hVar = inventVar(); if (!failFree(fst(snd(q)))) { Cell str = mkStr(findText("match fails")); ld = cons(pair(singleton(WILDCARD), ap2(nameMFail,m,str)), ld); } ld = cons(pair(singleton(fst(snd(q))), transDo(m,e,qs1)), ld); return ap(LETREC, pair(singleton(pair(hVar,ld)), ap(ap(ap(nameBind, m), translate(snd(snd(q)))), hVar))); } case DOQUAL : return ap(ap(ap(nameThen,m), translate(snd(q))), transDo(m,e,qs1)); case QWHERE : return expandLetrec(ap(LETREC, pair(snd(q), transDo(m,e,qs1)))); case BOOLQUAL : return ap(COND, triple(translate(snd(q)), transDo(m,e,qs1), ap2(nameMFail,m, mkStr(findText("guard fails"))))); } } return e; } #if MUDO /* Copied verbatim from parser.y: */ static Cell local mdoBuildTuple(tup) /* build tuple (x1,...,xn) from */ List tup; { /* list [xn,...,x1] */ Int n = 0; Cell t = tup; Cell x; do { /* . . */ x = fst(t); /* / \ / \ */ fst(t) = snd(t); /* xn . . xn */ snd(t) = x; /* . ===> . */ x = t; /* . . */ t = fun(x); /* . . */ n++; /* / \ / \ */ } while (nonNull(t)); /* x1 NIL (n) x1 */ fst(x) = mkTuple(n); return tup; } static Cell local transMDo(m,ms,seg) /* translate each segment in an mdo */ Cell m; /* dictionary for recursive monad */ Cell ms; /* dictionary for monad */ List seg; { /* seg looks like: ((1,2,3),4) where: 1: rec vars of the segment 2: exp vars of the segment 3: def vars of the segment (not used here) 4: list of qualifiers in the segment */ List qs = snd(seg); List recs = fst3(fst(seg)); List exps = snd3(fst(seg)); Int noOfRecs = length(recs); Int noOfExps = length(exps); /* Case 1: Not a recursive segment. It must be the case that |qs| = 1 */ if(isNull(recs)) { if(length(qs)!=1) { internal("MDO: Non-recursive, non-singleton segment, Impossible!"); } return hd(qs); } #define mkLambda(arg,body) ap(LAMBDA,pair(singleton(arg),pair(0,body))) #define mkDoComp(qs,exp) ap(DOCOMP,pair(ms,pair(exp,qs))) #define BIND(e1,e2) ap3(nameBind,ms,e1,e2)