# ----------------------------------------------------------------------------- #
-# $Id: Makefile,v 1.3 1999/01/14 18:08:26 sewardj Exp $ #
+# $Id: Makefile,v 1.4 1999/02/03 17:08:25 sewardj Exp $ #
# ----------------------------------------------------------------------------- #
TOP = ../..
# interpreter and relevant .a/.so files #
# --------------------------------------------------------------------- #
+YACC = bison -y
+%.c: %.y
+ -$(YACC) $<
+ mv y.tab.c $@
+
+
HS_SRCS =
-C_SRCS = \
- charset.c codegen.c compiler.c connect.c derive.c desugar.c \
- dynamic.c free.c hugs.c input.c interface.c lift.c link.c \
- machdep.c modules.c optimise.c output.c pat.c pmc.c pp.c static.c \
- stg.c stgSubst.c storage.c subst.c translate.c type.c
+Y_SRCS = parser.y
+C_SRCS = link.c type.c static.c storage.c derive.c input.c compiler.c subst.c \
+ translate.c codegen.c lift.c free.c stgSubst.c optimise.c output.c \
+ hugs.c dynamic.c stg.c
-SRC_CC_OPTS = -g -I$(GHC_DIR)/includes -D__HUGS__ -Wall -Wno-unused
+SRC_CC_OPTS = -g -I$(GHC_DIR)/includes -I$(GHC_DIR)/rts -D__HUGS__ -Wall -Wno-unused
GHC_LIBS_NEEDED = $(TOP)/ghc/rts/libHSrts.a $(TOP)/ghc/rts/gmp/libgmp.a
GHC_DYN_CBITS_DIR = $(TOP)/ghc/lib/std/cbits
GHC_DYN_CBITS = $(GHC_DYN_CBITS_DIR)/libHS_cbits.so
-all :: $(GHC_LIBS_NEEDED) $(GHC_DYN_CBITS) hugs Prelude.hs
+all :: parser.c $(GHC_LIBS_NEEDED) $(GHC_DYN_CBITS) hugs Prelude.hs
hugs: $(C_OBJS)
$(CC) -rdynamic -o $@ $(CC_OPTS) $^ $(GHC_LIBS_NEEDED) -lbfd -liberty -ldl -lm
$(TOP)/ghc/rts/gmp/libgmp.a:
(cd $(TOP)/ghc/rts/gmp ; make clean ; make)
-
# --------------------------------------------------------------------- #
# Prelude #
# --------------------------------------------------------------------- #
CLEAN_FILES += hugs libHS_cbits.so $(GHC_DYN_CBITS) $(GHC_DYN_CBITS_DIR)/*.o
CLEAN_FILES += $(TOP)/ghc/rts/libHSrts.a $(TOP)/ghc/rts/*.o
CLEAN_FILES += $(TOP)/ghc/rts/gmp/libgmp.a $(TOP)/ghc/rts/gmp/*.o $(TOP)/ghc/rts/gmp/*/*.o
+CLEAN_FILES += parser.c
INSTALL_LIBEXECS = hugs
-/* -*- mode: hugs-c; -*- */
+
/* --------------------------------------------------------------------------
* Code generator
*
* Hugs version 1.4, December 1997
*
* $RCSfile: codegen.c,v $
- * $Revision: 1.2 $
- * $Date: 1998/12/02 13:21:59 $
+ * $Revision: 1.3 $
+ * $Date: 1999/02/03 17:08:25 $
* ------------------------------------------------------------------------*/
#include "prelude.h"
#include "storage.h"
+#include "backend.h"
#include "connect.h"
#include "errors.h"
-#include "stg.h"
#include "Assembler.h"
-#include "lift.h"
#include "link.h"
-#include "pp.h"
-#include "codegen.h"
+
/* --------------------------------------------------------------------------
* Local function prototypes:
setPos(hd(vs),asmUnbox(bco,boxingConRep(con)));
} else {
asmBeginUnpack(bco);
- map1Proc(cgBind,bco,reverse(vs));
+ map1Proc(cgBind,bco,rev(vs));
asmEndUnpack(bco);
}
cgExpr(bco,root,body);
AsmBCO bco = asmBeginBCO();
AsmSp root = asmBeginArgCheck(bco);
- map1Proc(cgBind,bco,reverse(stgLambdaArgs(e)));
+ map1Proc(cgBind,bco,rev(stgLambdaArgs(e)));
asmEndArgCheck(bco,root);
/* ppStgExpr(e); */
/* No need to use return address or to Slide */
AsmSp beginPrim = asmBeginPrim(bco);
- map1Proc(pushAtom,bco,reverse(stgPrimArgs(scrut)));
+ map1Proc(pushAtom,bco,rev(stgPrimArgs(scrut)));
asmEndPrim(bco,(AsmPrim*)name(stgPrimOp(scrut)).primop,beginPrim);
for(; nonNull(alts); alts=tl(alts)) {
List pats = stgPrimAltPats(alt);
StgExpr body = stgPrimAltBody(alt);
AsmSp altBegin = asmBeginAlt(bco);
- map1Proc(cgBind,bco,reverse(pats));
+ map1Proc(cgBind,bco,rev(pats));
testPrimPats(bco,root,pats,body);
asmEndAlt(bco,altBegin);
}
case STGAPP: /* Tail call */
{
AsmSp env = asmBeginEnter(bco);
- map1Proc(pushAtom,bco,reverse(stgAppArgs(e)));
+ map1Proc(pushAtom,bco,rev(stgAppArgs(e)));
pushAtom(bco,stgAppFun(e));
asmEndEnter(bco,env,root);
break;
case STGPRIM: /* Tail call again */
{
AsmSp beginPrim = asmBeginPrim(bco);
- map1Proc(pushAtom,bco,reverse(stgPrimArgs(e)));
+ map1Proc(pushAtom,bco,rev(stgPrimArgs(e)));
asmEndPrim(bco,(AsmPrim*)name(e).primop,beginPrim);
/* map1Proc(cgBind,bco,rs_vars); */
assert(0); /* asmReturn_retty(); */
doNothing(); /* already done in alloc */
} else {
AsmSp start = asmBeginPack(bco);
- map1Proc(pushAtom,bco,reverse(args));
+ map1Proc(pushAtom,bco,rev(args));
asmEndPack(bco,getPos(v),start,stgConInfo(con));
}
return;
&& whatIs(stgVarBody(fun)) == LAMBDA
&& length(stgLambdaArgs(stgVarBody(fun))) > length(args)) {
AsmSp start = asmBeginMkPAP(bco);
- map1Proc(pushAtom,bco,reverse(args));
+ map1Proc(pushAtom,bco,rev(args));
pushAtom(bco,fun);
asmEndMkPAP(bco,getPos(v),start); /* optimisation */
} else {
AsmSp start = asmBeginMkAP(bco);
- map1Proc(pushAtom,bco,reverse(args));
+ map1Proc(pushAtom,bco,rev(args));
pushAtom(bco,fun);
asmEndMkAP(bco,getPos(v),start);
}
/* ToDo: merge this code with cgLambda */
AsmBCO bco = (AsmBCO)getObj(v);
AsmSp root = asmBeginArgCheck(bco);
- map1Proc(cgBind,bco,reverse(stgLambdaArgs(rhs)));
+ map1Proc(cgBind,bco,rev(stgLambdaArgs(rhs)));
asmEndArgCheck(bco,root);
cgExpr(bco,root,stgLambdaBody(rhs));
/* --------------------------------------------------------------------------
* Interpreter command structure
*
- * 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
+ * Hugs 98 is Copyright (c) Mark P Jones, Alastair Reid and the Yale
+ * Haskell Group 1994-99, and is distributed as Open Source software
+ * under the Artistic License; see the file "Artistic" that is included
+ * in the distribution for details.
*
* $RCSfile: command.h,v $
- * $Revision: 1.2 $
- * $Date: 1998/12/02 13:22:01 $
+ * $Revision: 1.3 $
+ * $Date: 1999/02/03 17:08:26 $
* ------------------------------------------------------------------------*/
typedef Int Command;
#define INFO 15
#define COLLECT 16
#define SETMODULE 17
-#define SHOWVERSION 18
-#define NOCMD 19
+#define NOCMD 18
/*-------------------------------------------------------------------------*/
-/* -*- mode: hugs-c; -*- */
+
/* --------------------------------------------------------------------------
* This is the Hugs compiler, handling translation of typechecked code to
* `kernel' language, elimination of pattern matching and translation to
* super combinators (lambda lifting).
*
- * 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
+ * Hugs 98 is Copyright (c) Mark P Jones, Alastair Reid and the Yale
+ * Haskell Group 1994-99, and is distributed as Open Source software
+ * under the Artistic License; see the file "Artistic" that is included
+ * in the distribution for details.
*
* $RCSfile: compiler.c,v $
- * $Revision: 1.2 $
- * $Date: 1998/12/02 13:22:01 $
+ * $Revision: 1.3 $
+ * $Date: 1999/02/03 17:08:26 $
* ------------------------------------------------------------------------*/
#include "prelude.h"
#include "storage.h"
+#include "backend.h"
#include "connect.h"
-#include "input.h"
-#include "compiler.h"
-#include "hugs.h" /* for target */
#include "errors.h"
+#include "Rts.h" /* for rts_eval and related stuff */
+#include "RtsAPI.h" /* for rts_eval and related stuff */
+#include "Schedule.h"
+#include "link.h"
-#include "desugar.h"
-#include "pmc.h"
-
-#include "optimise.h"
-
-#include "Rts.h" /* for rts_eval and related stuff */
-#include "RtsAPI.h" /* for rts_eval and related stuff */
+/*#define DEBUG_SHOWSC*/ /* Must also be set in output.c */
-Name currentName; /* Top level name being processed */
+Addr inputCode; /* Addr of compiled code for expr */
+static Name currentName; /* Top level name being processed */
#if DEBUG_CODE
-Bool debugCode = FALSE; /* TRUE => print G-code to screen */
+Bool debugCode = FALSE; /* TRUE => print G-code to screen */
#endif
+
+
/* --------------------------------------------------------------------------
* Local function prototypes:
* ------------------------------------------------------------------------*/
-static List local addGlobals( List binds );
+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));
+
+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));
/* --------------------------------------------------------------------------
- * STG stuff
+ * 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 EVAL_INSTANCES
+ if (fst(e)==nameStrict)
+ return nameIStrict;
+ if (fst(e)==nameSeq)
+ return nameISeq;
+#endif
+ 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 FLOATCELL :
+ case STRCELL :
+ case CHARCELL : return e;
+
+ 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
+ }
+ }
+
+ 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 (isVar(fst(hd(bs)))) {
+ 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 { e; qs } => LETREC _h _ = [ e | qs ] in bind m exp _h
+ *
+ * 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 : { Cell hVar = inventVar();
+ Cell ld = cons(pair(singleton(WILDCARD),
+ transDo(m,e,qs1)),
+ NIL);
+ return ap(LETREC,
+ pair(singleton(pair(hVar,ld)),
+ ap(ap(ap(nameBind,
+ m),
+ translate(snd(q))),
+ hVar)));
+ }
+
+ 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;
+}
+
+/* --------------------------------------------------------------------------
+ * Translation of named field construction and update:
+ *
+ * Construction is implemented using the following transformation:
+ *
+ * C{x1=e1, ..., xn=en} = C v1 ... vm
+ * where:
+ * vi = e1, if the ith component of C is labelled with x1
+ * ...
+ * = en, if the ith component of C is labelled with xn
+ * = undefined, otherwise
+ *
+ * Update is implemented using the following transformation:
+ *
+ * e{x1=e1, ..., xn=en}
+ * = let nv (C a1 ... am) v1 ... vn = C a1' .. am'
+ * nv (D b1 ... bk) v1 ... vn = D b1' .. bk
+ * ...
+ * nv _ v1 ... vn = error "failed update"
+ * in nv e e1 ... en
+ * where:
+ * nv, v1, ..., vn, a1, ..., am, b1, ..., bk, ... are new variables,
+ * C,D,... = { K | K is a constr fun s.t. {x1,...,xn} subset of sels(K)}
+ * and:
+ * ai' = v1, if the ith component of C is labelled with x1
+ * ...
+ * = vn, if the ith component of C is labelled with xn
+ * = ai, otherwise
+ * etc...
+ *
+ * The error case may be omitted if C,D,... is an enumeration of all of the
+ * constructors for the datatype concerned. Strictly speaking, error case
+ * isn't needed at all -- the only benefit of including it is that the user
+ * will get a "failed update" message rather than a cryptic {v354 ...}.
+ * So, for now, we'll go with the second option!
+ *
+ * For the time being, code for each update operation is generated
+ * independently of any other updates. However, if updates are used
+ * frequently, then we might want to consider changing the implementation
+ * at a later stage to cache definitions of functions like nv above. This
+ * would create a shared library of update functions, indexed by a set of
+ * constructors {C,D,...}.
+ * ------------------------------------------------------------------------*/
+
+static Cell local transConFlds(c,flds) /* Translate C{flds} */
+Name c;
+List flds; {
+ Cell e = c;
+ Int m = name(c).arity;
+ Int i;
+ for (i=m; i>0; i--)
+ e = ap(e,nameUndefined);
+ for (; nonNull(flds); flds=tl(flds)) {
+ Cell a = e;
+ for (i=m-sfunPos(fst(hd(flds)),c); i>0; i--)
+ a = fun(a);
+ arg(a) = translate(snd(hd(flds)));
+ }
+ return e;
+}
+
+static Cell local transUpdFlds(e,cs,flds)/* Translate e{flds} */
+Cell e; /* (cs is corresp list of constrs) */
+List cs;
+List flds; {
+ Cell nv = inventVar();
+ Cell body = ap(nv,translate(e));
+ List fs = flds;
+ List args = NIL;
+ List alts = NIL;
+
+ for (; nonNull(fs); fs=tl(fs)) { /* body = nv e1 ... en */
+ Cell b = hd(fs); /* args = [v1, ..., vn] */
+ body = ap(body,translate(snd(b)));
+ args = cons(inventVar(),args);
+ }
+
+ for (; nonNull(cs); cs=tl(cs)) { /* Loop through constructors to */
+ Cell c = hd(cs); /* build up list of alts. */
+ Cell pat = c;
+ Cell rhs = c;
+ List as = args;
+ Int m = name(c).arity;
+ Int i;
+
+ for (i=m; i>0; i--) { /* pat = C a1 ... am */
+ Cell a = inventVar(); /* rhs = C a1 ... am */
+ pat = ap(pat,a);
+ rhs = ap(rhs,a);
+ }
+
+ for (fs=flds; nonNull(fs); fs=tl(fs), as=tl(as)) {
+ Name s = fst(hd(fs)); /* Replace approp ai in rhs with */
+ Cell r = rhs; /* vars from [v1,...,vn] */
+ for (i=m-sfunPos(s,c); i>0; i--)
+ r = fun(r);
+ arg(r) = hd(as);
+ }
+
+ alts = cons(pair(cons(pat,args),rhs),alts);
+ }
+ return ap(LETREC,pair(singleton(pair(nv,alts)),body));
+}
+
+/* --------------------------------------------------------------------------
+ * Elimination of pattern bindings:
+ *
+ * The following code adopts the definition of failure free patterns as given
+ * in the Haskell 1.3 report; the term "irrefutable" is also used there for
+ * a subset of the failure free patterns described here, but has no useful
+ * role in this implementation. Basically speaking, the failure free patterns
+ * are: variable, wildcard, ~apat
+ * var@apat, if apat is failure free
+ * C apat1 ... apatn if C is a product constructor
+ * (i.e. an only constructor) and
+ * apat1,...,apatn are failure free
+ * Note that the last case automatically covers the case where C comes from
+ * a newtype construction.
+ * ------------------------------------------------------------------------*/
+
+Bool failFree(pat) /* is pattern failure free? (do we need */
+Cell pat; { /* a conformality check?) */
+ Cell c = getHead(pat);
+
+ switch (whatIs(c)) {
+ case ASPAT : return failFree(snd(snd(pat)));
+
+ case NAME : if (!isCfun(c) || cfunOf(c)!=0)
+ return FALSE;
+ /*intentional fall-thru*/
+ case TUPLE : for (; isAp(pat); pat=fun(pat))
+ if (!failFree(arg(pat)))
+ return FALSE;
+ /*intentional fall-thru*/
+ case LAZYPAT :
+ case VAROPCELL :
+ case VARIDCELL :
+ case DICTVAR :
+ case WILDCARD : return TRUE;
+
+#if TREX
+ case EXT : return failFree(extField(pat)) &&
+ failFree(extRow(pat));
+#endif
+
+ case CONFLDS : if (cfunOf(fst(snd(c)))==0) {
+ List fs = snd(snd(c));
+ for (; nonNull(fs); fs=tl(fs))
+ if (!failFree(snd(hd(fs))))
+ return FALSE;
+ return TRUE;
+ }
+ /*intentional fall-thru*/
+ default : return FALSE;
+ }
+}
+
+static Cell local refutePat(pat) /* find pattern to refute in conformality*/
+Cell pat; { /* test with pat. */
+ /* e.g. refPat (x:y) == (_:_) */
+ /* refPat ~(x:y) == _ etc.. */
+
+ switch (whatIs(pat)) {
+ case ASPAT : return refutePat(snd(snd(pat)));
+
+ case FINLIST : { Cell ys = snd(pat);
+ Cell xs = NIL;
+ for (; nonNull(ys); ys=tl(ys))
+ xs = ap(ap(nameCons,refutePat(hd(ys))),xs);
+ return revOnto(xs,nameNil);
+ }
+
+ case CONFLDS : { Cell ps = NIL;
+ Cell fs = snd(snd(pat));
+ for (; nonNull(fs); fs=tl(fs)) {
+ Cell p = refutePat(snd(hd(fs)));
+ ps = cons(pair(fst(hd(fs)),p),ps);
+ }
+ return pair(CONFLDS,pair(fst(snd(pat)),rev(ps)));
+ }
+
+ case VAROPCELL :
+ case VARIDCELL :
+ case DICTVAR :
+ case WILDCARD :
+ case LAZYPAT : return WILDCARD;
+
+ case STRCELL :
+ case CHARCELL :
+#if NPLUSK
+ case ADDPAT :
+#endif
+ case TUPLE :
+ case NAME : return pat;
+
+ case AP : return refutePatAp(pat);
+
+ default : internal("refutePat");
+ return NIL; /*NOTREACHED*/
+ }
+}
+
+static Cell local refutePatAp(p) /* find pattern to refute in conformality*/
+Cell p; {
+ Cell h = getHead(p);
+ if (h==nameFromInt || h==nameFromInteger || h==nameFromDouble)
+ return p;
+#if NPLUSK
+ else if (whatIs(h)==ADDPAT)
+ return ap(fun(p),refutePat(arg(p)));
+#endif
+#if TREX
+ else if (isExt(h)) {
+ Cell pf = refutePat(extField(p));
+ Cell pr = refutePat(extRow(p));
+ return ap(ap(fun(fun(p)),pf),pr);
+ }
+#endif
+ else {
+ List as = getArgs(p);
+ mapOver(refutePat,as);
+ return applyToArgs(h,as);
+ }
+}
+
+static Cell local matchPat(pat) /* find pattern to match against */
+Cell pat; { /* replaces parts of pattern that do not */
+ /* include variables with wildcards */
+ switch (whatIs(pat)) {
+ case ASPAT : { Cell p = matchPat(snd(snd(pat)));
+ return (p==WILDCARD) ? fst(snd(pat))
+ : ap(ASPAT,
+ pair(fst(snd(pat)),p));
+ }
+
+ case FINLIST : { Cell ys = snd(pat);
+ Cell xs = NIL;
+ for (; nonNull(ys); ys=tl(ys))
+ xs = cons(matchPat(hd(ys)),xs);
+ while (nonNull(xs) && hd(xs)==WILDCARD)
+ xs = tl(xs);
+ for (ys=nameNil; nonNull(xs); xs=tl(xs))
+ ys = ap(ap(nameCons,hd(xs)),ys);
+ return ys;
+ }
+
+ case CONFLDS : { Cell ps = NIL;
+ Name c = fst(snd(pat));
+ Cell fs = snd(snd(pat));
+ Bool avar = FALSE;
+ for (; nonNull(fs); fs=tl(fs)) {
+ Cell p = matchPat(snd(hd(fs)));
+ ps = cons(pair(fst(hd(fs)),p),ps);
+ if (p!=WILDCARD)
+ avar = TRUE;
+ }
+ return avar ? pair(CONFLDS,pair(c,rev(ps)))
+ : WILDCARD;
+ }
+
+ case VAROPCELL :
+ case VARIDCELL :
+ case DICTVAR : return pat;
+
+ case LAZYPAT : { Cell p = matchPat(snd(pat));
+ return (p==WILDCARD) ? WILDCARD : ap(LAZYPAT,p);
+ }
+
+ case WILDCARD :
+ case STRCELL :
+ case CHARCELL : return WILDCARD;
+
+ case TUPLE :
+ case NAME :
+ case AP : { Cell h = getHead(pat);
+ if (h==nameFromInt ||
+ h==nameFromInteger || h==nameFromDouble)
+ return WILDCARD;
+#if NPLUSK
+ else if (whatIs(h)==ADDPAT)
+ return pat;
+#endif
+#if TREX
+ else if (isExt(h)) {
+ Cell pf = matchPat(extField(pat));
+ Cell pr = matchPat(extRow(pat));
+ return (pf==WILDCARD && pr==WILDCARD)
+ ? WILDCARD
+ : ap(ap(fun(fun(pat)),pf),pr);
+ }
+#endif
+ else {
+ List args = NIL;
+ Bool avar = FALSE;
+ for (; isAp(pat); pat=fun(pat)) {
+ Cell p = matchPat(arg(pat));
+ if (p!=WILDCARD)
+ avar = TRUE;
+ args = cons(p,args);
+ }
+ return avar ? applyToArgs(pat,args)
+ : WILDCARD;
+ }
+ }
+
+ default : internal("matchPat");
+ return NIL; /*NOTREACHED*/
+ }
+}
+
+#define addEqn(v,val,lds) cons(pair(v,singleton(pair(NIL,val))),lds)
+
+static List local remPat(pat,expr,lds)
+Cell pat; /* Produce list of definitions for eqn */
+Cell expr; /* pat = expr, including a conformality */
+List lds; { /* check if required. */
+
+ /* Conformality test (if required):
+ * pat = expr ==> nv = LETREC confCheck nv@pat = nv
+ * IN confCheck expr
+ * remPat1(pat,nv,.....);
+ */
+
+ if (!failFree(pat)) {
+ Cell confVar = inventVar();
+ Cell nv = inventVar();
+ Cell locfun = pair(confVar, /* confVar [([nv@refPat],nv)] */
+ singleton(pair(singleton(ap(ASPAT,
+ pair(nv,
+ refutePat(pat)))),
+ nv)));
+
+ if (whatIs(expr)==GUARDED) { /* A spanner ... special case */
+ lds = addEqn(nv,expr,lds); /* for guarded pattern binding*/
+ expr = nv;
+ nv = inventVar();
+ }
+
+ if (whatIs(pat)==ASPAT) { /* avoid using new variable if*/
+ nv = fst(snd(pat)); /* a variable is already given*/
+ pat = snd(snd(pat)); /* by an as-pattern */
+ }
+
+ lds = addEqn(nv, /* nv = */
+ ap(LETREC,pair(singleton(locfun), /* LETREC [locfun] */
+ ap(confVar,expr))), /* IN confVar expr */
+ lds);
+
+ return remPat1(matchPat(pat),nv,lds);
+ }
+
+ return remPat1(matchPat(pat),expr,lds);
+}
+
+static List local remPat1(pat,expr,lds)
+Cell pat; /* Add definitions for: pat = expr to */
+Cell expr; /* list of local definitions in lds. */
+List lds; {
+ Cell c = getHead(pat);
+
+ switch (whatIs(c)) {
+ case WILDCARD :
+ case STRCELL :
+ case CHARCELL : break;
+
+ case ASPAT : return remPat1(snd(snd(pat)), /* v@pat = expr */
+ fst(snd(pat)),
+ addEqn(fst(snd(pat)),expr,lds));
+
+ case LAZYPAT : { Cell nv;
+
+ if (isVar(expr) || isName(expr))
+ nv = expr;
+ else {
+ nv = inventVar();
+ lds = addEqn(nv,expr,lds);
+ }
+
+ return remPat(snd(pat),nv,lds);
+ }
+
+#if NPLUSK
+ case ADDPAT : return remPat1(arg(pat), /* n + k = expr */
+ ap(ap(ap(namePmSub,
+ arg(fun(pat))),
+ mkInt(snd(fun(fun(pat))))),
+ expr),
+ lds);
+#endif
+
+ case FINLIST : return remPat1(mkConsList(snd(pat)),expr,lds);
+
+ case CONFLDS : { Name h = fst(snd(pat));
+ Int m = name(h).arity;
+ Cell p = h;
+ List fs = snd(snd(pat));
+ Int i = m;
+ while (0<i--)
+ p = ap(p,WILDCARD);
+ for (; nonNull(fs); fs=tl(fs)) {
+ Cell r = p;
+ for (i=m-sfunPos(fst(hd(fs)),h); i>0; i--)
+ r = fun(r);
+ arg(r) = snd(hd(fs));
+ }
+ return remPat1(p,expr,lds);
+ }
+
+ case DICTVAR : /* shouldn't really occur */
+ assert(0); /* so let's test for it then! ADR */
+ case VARIDCELL :
+ case VAROPCELL : return addEqn(pat,expr,lds);
+
+ case NAME : if (c==nameFromInt || c==nameFromInteger
+ || c==nameFromDouble) {
+ if (argCount==2)
+ arg(fun(pat)) = translate(arg(fun(pat)));
+ break;
+ }
+
+ if (argCount==1 && isCfun(c) /* for newtype */
+ && cfunOf(c)==0 && name(c).defn==nameId)
+ return remPat1(arg(pat),expr,lds);
+
+ /* intentional fall-thru */
+ case TUPLE : { List ps = getArgs(pat);
+
+ if (nonNull(ps)) {
+ Cell nv, sel;
+ Int i;
+
+ if (isVar(expr) || isName(expr))
+ nv = expr;
+ else {
+ nv = inventVar();
+ lds = addEqn(nv,expr,lds);
+ }
+
+ sel = ap(ap(nameSel,c),nv);
+ for (i=1; nonNull(ps); ++i, ps=tl(ps))
+ lds = remPat1(hd(ps),
+ ap(sel,mkInt(i)),
+ lds);
+ }
+ }
+ break;
+
+#if TREX
+ case EXT : { Cell nv = inventVar();
+ arg(fun(fun(pat)))
+ = translate(arg(fun(fun(pat))));
+ lds = addEqn(nv,
+ ap(ap(nameRecBrk,
+ arg(fun(fun(pat)))),
+ expr),
+ lds);
+ lds = remPat1(extField(pat),ap(nameFst,nv),lds);
+ lds = remPat1(extRow(pat),ap(nameSnd,nv),lds);
+ }
+ break;
+#endif
+
+ default : internal("remPat1");
+ break;
+ }
+ return lds;
+}
+
+/* --------------------------------------------------------------------------
+ * Eliminate pattern matching in function definitions -- pattern matching
+ * compiler:
+ *
+ * The original Gofer/Hugs pattern matching compiler was based on Wadler's
+ * algorithms described in `Implementation of functional programming
+ * languages'. That should still provide a good starting point for anyone
+ * wanting to understand this part of the system. However, the original
+ * algorithm has been generalized and restructured in order to implement
+ * new features added in Haskell 1.3.
+ *
+ * During the translation, in preparation for later stages of compilation,
+ * all local and bound variables are replaced by suitable offsets, and
+ * locally defined function symbols are given new names (which will
+ * eventually be their names when lifted to make top level definitions).
+ * ------------------------------------------------------------------------*/
+
+static Offset freeBegin; /* only variables with offset <= freeBegin are of */
+static List freeVars; /* interest as `free' variables */
+static List freeFuns; /* List of `free' local functions */
+
+static Cell local pmcTerm(co,sc,e) /* apply pattern matching compiler */
+Int co; /* co = current offset */
+List sc; /* sc = scope */
+Cell e; { /* e = expr to transform */
+ switch (whatIs(e)) {
+ case GUARDED : map2Over(pmcPair,co,sc,snd(e));
+ break;
+
+ case LETREC : pmcLetrec(co,sc,snd(e));
+ break;
+
+ case VARIDCELL:
+ case VAROPCELL:
+ case DICTVAR : return pmcVar(sc,textOf(e));
+
+ case COND : return ap(COND,pmcTriple(co,sc,snd(e)));
+
+ case AP : return pmcPair(co,sc,e);
+
+#if BIGNUMS
+ case POSNUM :
+ case ZERONUM :
+ case NEGNUM :
+#endif
+#if NPLUSK
+ case ADDPAT :
+#endif
+#if TREX
+ case EXT :
+#endif
+ case TUPLE :
+ case NAME :
+ case CHARCELL :
+ case INTCELL :
+ case FLOATCELL:
+ case STRCELL : break;
+
+ default : internal("pmcTerm");
+ break;
+ }
+ return e;
+}
+
+static Cell local pmcPair(co,sc,pr) /* apply pattern matching compiler */
+Int co; /* to a pair of exprs */
+List sc;
+Pair pr; {
+ return pair(pmcTerm(co,sc,fst(pr)),
+ pmcTerm(co,sc,snd(pr)));
+}
+
+static Cell local pmcTriple(co,sc,tr) /* apply pattern matching compiler */
+Int co; /* to a triple of exprs */
+List sc;
+Triple tr; {
+ return triple(pmcTerm(co,sc,fst3(tr)),
+ pmcTerm(co,sc,snd3(tr)),
+ pmcTerm(co,sc,thd3(tr)));
+}
+
+static Cell local pmcVar(sc,t) /* find translation of variable */
+List sc; /* in current scope */
+Text t; {
+ List xs;
+ Name n;
+
+ for (xs=sc; nonNull(xs); xs=tl(xs)) {
+ Cell x = hd(xs);
+ if (t==textOf(fst(x))) {
+ if (isOffset(snd(x))) { /* local variable ... */
+ if (snd(x)<=freeBegin && !cellIsMember(snd(x),freeVars))
+ freeVars = cons(snd(x),freeVars);
+ return snd(x);
+ }
+ else { /* local function ... */
+ if (!cellIsMember(snd(x),freeFuns))
+ freeFuns = cons(snd(x),freeFuns);
+ return fst3(snd(x));
+ }
+ }
+ }
+
+ if (isNull(n=findName(t))) /* Lookup global name - the only way*/
+ n = newName(t,currentName); /* this (should be able to happen) */
+ /* is with new global var introduced*/
+ /* after type check; e.g. remPat1 */
+ return n;
+}
+
+static Void local pmcLetrec(co,sc,e) /* apply pattern matching compiler */
+Int co; /* to LETREC, splitting decls into */
+List sc; /* two sections */
+Pair e; {
+ List fs = NIL; /* local function definitions */
+ List vs = NIL; /* local variable definitions */
+ List ds;
+
+ for (ds=fst(e); nonNull(ds); ds=tl(ds)) { /* Split decls into two */
+ Cell v = fst(hd(ds));
+ Int arity = length(fst(hd(snd(hd(ds)))));
+
+ if (arity==0) { /* Variable declaration */
+ vs = cons(snd(hd(ds)),vs);
+ sc = cons(pair(v,mkOffset(++co)),sc);
+ }
+ else { /* Function declaration */
+ fs = cons(triple(inventVar(),mkInt(arity),snd(hd(ds))),fs);
+ sc = cons(pair(v,hd(fs)),sc);
+ }
+ }
+ vs = rev(vs); /* Put declaration lists back in */
+ fs = rev(fs); /* original order */
+ fst(e) = pair(vs,fs); /* Store declaration lists */
+ map2Over(pmcVarDef,co,sc,vs); /* Translate variable definitions */
+ map2Proc(pmcFunDef,co,sc,fs); /* Translate function definitions */
+ snd(e) = pmcTerm(co,sc,snd(e)); /* Translate LETREC body */
+ freeFuns = diffList(freeFuns,fs); /* Delete any `freeFuns' bound in fs*/
+}
+
+static Cell local pmcVarDef(co,sc,vd) /* apply pattern matching compiler */
+Int co; /* to variable definition */
+List sc;
+List vd; { /* vd :: [ ([], rhs) ] */
+ Cell d = snd(hd(vd));
+ if (nonNull(tl(vd)) && canFail(d))
+ return ap(FATBAR,pair(pmcTerm(co,sc,d),
+ pmcVarDef(co,sc,tl(vd))));
+ return pmcTerm(co,sc,d);
+}
+
+static Void local pmcFunDef(co,sc,fd) /* apply pattern matching compiler */
+Int co; /* to function definition */
+List sc;
+Triple fd; { /* fd :: (Var, Arity, [Alt]) */
+ Offset saveFreeBegin = freeBegin;
+ List saveFreeVars = freeVars;
+ List saveFreeFuns = freeFuns;
+ Int arity = intOf(snd3(fd));
+ Cell temp = altsMatch(co+1,arity,sc,thd3(fd));
+ Cell xs;
+
+ freeBegin = mkOffset(co);
+ freeVars = NIL;
+ freeFuns = NIL;
+ temp = match(co+arity,temp);
+ thd3(fd) = triple(freeVars,freeFuns,temp);
+
+ for (xs=freeVars; nonNull(xs); xs=tl(xs))
+ if (hd(xs)<=saveFreeBegin && !cellIsMember(hd(xs),saveFreeVars))
+ saveFreeVars = cons(hd(xs),saveFreeVars);
+
+ for (xs=freeFuns; nonNull(xs); xs=tl(xs))
+ if (!cellIsMember(hd(xs),saveFreeFuns))
+ saveFreeFuns = cons(hd(xs),saveFreeFuns);
+
+ freeBegin = saveFreeBegin;
+ freeVars = saveFreeVars;
+ freeFuns = saveFreeFuns;
+}
+
+/* ---------------------------------------------------------------------------
+ * Main part of pattern matching compiler: convert [Alt] to case constructs
+ *
+ * This section of Hugs has been almost completely rewritten to be more
+ * general, in particular, to allow pattern matching in orders other than the
+ * strictly left-to-right approach of the previous version. This is needed
+ * for the implementation of the so-called Haskell 1.3 `record' syntax.
+ *
+ * At each stage, the different branches for the cases to be considered
+ * are represented by a list of values of type:
+ * Match ::= { maPats :: [Pat], patterns to match
+ * maOffs :: [Offs], offsets of corresponding values
+ * maSc :: Scope, mapping from vars to offsets
+ * maRhs :: Rhs } right hand side
+ * [Implementation uses nested pairs, ((pats,offs),(sc,rhs)).]
+ *
+ * The Scope component has type:
+ * Scope ::= [(Var,Expr)]
+ * and provides a mapping from variable names to offsets used in the matching
+ * process.
+ *
+ * Matches can be normalized by reducing them to a form in which the list
+ * of patterns is empty (in which case the match itself is described as an
+ * empty match), or in which the list is non-empty and the first pattern is
+ * one that requires either a CASE or NUMCASE (or EXTCASE) to decompose.
* ------------------------------------------------------------------------*/
-#include "stg.h"
-#include "translate.h"
-#include "codegen.h"
+#define mkMatch(ps,os,sc,r) pair(pair(ps,os),pair(sc,r))
+#define maPats(ma) fst(fst(ma))
+#define maOffs(ma) snd(fst(ma))
+#define maSc(ma) fst(snd(ma))
+#define maRhs(ma) snd(snd(ma))
+#define extSc(v,o,ma) maSc(ma) = cons(pair(v,o),maSc(ma))
+
+static List local altsMatch(co,n,sc,as) /* Make a list of matches from list*/
+Int co; /* of Alts, with initial offsets */
+Int n; /* reverse (take n [co..]) */
+List sc;
+List as; {
+ List mas = NIL;
+ List us = NIL;
+ for (; n>0; n--)
+ us = cons(mkOffset(co++),us);
+ for (; nonNull(as); as=tl(as)) /* Each Alt is ([Pat], Rhs) */
+ mas = cons(mkMatch(fst(hd(as)),us,sc,snd(hd(as))),mas);
+ return rev(mas);
+}
+
+static Cell local match(co,mas) /* Generate case statement for Matches mas */
+Int co; /* at current offset co */
+List mas; { /* N.B. Assumes nonNull(mas). */
+ Cell srhs = NIL; /* Rhs for selected matches */
+ List smas = mas; /* List of selected matches */
+ mas = tl(mas);
+ tl(smas) = NIL;
+
+ if (emptyMatch(hd(smas))) { /* The case for empty matches: */
+ while (nonNull(mas) && emptyMatch(hd(mas))) {
+ List temp = tl(mas);
+ tl(mas) = smas;
+ smas = mas;
+ mas = temp;
+ }
+ srhs = joinMas(co,rev(smas));
+ }
+ else { /* Non-empty match */
+ Int o = offsetOf(hd(maOffs(hd(smas))));
+ Cell d = maDiscr(hd(smas));
+ if (isNumDiscr(d)) { /* Numeric match */
+ Int da = discrArity(d);
+ Cell d1 = pmcTerm(co,maSc(hd(smas)),d);
+ while (nonNull(mas) && !emptyMatch(hd(mas))
+ && o==offsetOf(hd(maOffs(hd(mas))))
+ && isNumDiscr(d=maDiscr(hd(mas)))
+ && eqNumDiscr(d,d1)) {
+ List temp = tl(mas);
+ tl(mas) = smas;
+ smas = mas;
+ mas = temp;
+ }
+ smas = rev(smas);
+ map2Proc(advance,co,da,smas);
+ srhs = ap(NUMCASE,triple(mkOffset(o),d1,match(co+da,smas)));
+ }
+#if TREX
+ else if (isExtDiscr(d)) { /* Record match */
+ Int da = discrArity(d);
+ Cell d1 = pmcTerm(co,maSc(hd(smas)),d);
+ while (nonNull(mas) && !emptyMatch(hd(mas))
+ && o==offsetOf(hd(maOffs(hd(mas))))
+ && isExtDiscr(d=maDiscr(hd(mas)))
+ && eqExtDiscr(d,d1)) {
+ List temp = tl(mas);
+ tl(mas) = smas;
+ smas = mas;
+ mas = temp;
+ }
+ smas = rev(smas);
+ map2Proc(advance,co,da,smas);
+ srhs = ap(EXTCASE,triple(mkOffset(o),d1,match(co+da,smas)));
+ }
+#endif
+ else { /* Constructor match */
+ List tab = addConTable(d,hd(smas),NIL);
+ Int da;
+ while (nonNull(mas) && !emptyMatch(hd(mas))
+ && o==offsetOf(hd(maOffs(hd(mas))))
+ && !isNumDiscr(d=maDiscr(hd(mas)))) {
+ tab = addConTable(d,hd(mas),tab);
+ mas = tl(mas);
+ }
+ for (tab=rev(tab); nonNull(tab); tab=tl(tab)) {
+ d = fst(hd(tab));
+ smas = snd(hd(tab));
+ da = discrArity(d);
+ map2Proc(advance,co,da,smas);
+ srhs = cons(pair(d,match(co+da,smas)),srhs);
+ }
+ srhs = ap(CASE,pair(mkOffset(o),srhs));
+ }
+ }
+ return nonNull(mas) ? ap(FATBAR,pair(srhs,match(co,mas))) : srhs;
+}
+
+static Cell local joinMas(co,mas) /* Combine list of matches into rhs*/
+Int co; /* using FATBARs as necessary */
+List mas; { /* Non-empty list of empty matches */
+ Cell ma = hd(mas);
+ Cell rhs = pmcTerm(co,maSc(ma),maRhs(ma));
+ if (nonNull(tl(mas)) && canFail(rhs))
+ return ap(FATBAR,pair(rhs,joinMas(co,tl(mas))));
+ else
+ return rhs;
+}
+
+static Bool local canFail(rhs) /* Determine if expression (as rhs) */
+Cell rhs; { /* might ever be able to fail */
+ switch (whatIs(rhs)) {
+ case LETREC : return canFail(snd(snd(rhs)));
+ case GUARDED : return TRUE; /* could get more sophisticated ..? */
+ default : return FALSE;
+ }
+}
+
+/* type Table a b = [(a, [b])]
+ *
+ * addTable :: a -> b -> Table a b -> Table a b
+ * addTable x y [] = [(x,[y])]
+ * addTable x y (z@(n,sws):zs)
+ * | n == x = (n,sws++[y]):zs
+ * | otherwise = (n,sws):addTable x y zs
+ */
+
+static List local addConTable(x,y,tab) /* add element (x,y) to table */
+Cell x, y;
+List tab; {
+ if (isNull(tab))
+ return singleton(pair(x,singleton(y)));
+ else if (fst(hd(tab))==x)
+ snd(hd(tab)) = appendOnto(snd(hd(tab)),singleton(y));
+ else
+ tl(tab) = addConTable(x,y,tl(tab));
+
+ return tab;
+}
+
+static Void local advance(co,a,ma) /* Advance non-empty match by */
+Int co; /* processing head pattern */
+Int a; /* discriminator arity */
+Cell ma; {
+ Cell p = hd(maPats(ma));
+ List ps = tl(maPats(ma));
+ List us = tl(maOffs(ma));
+ if (whatIs(p)==CONFLDS) { /* Special case for record syntax */
+ Name c = fst(snd(p));
+ List fs = snd(snd(p));
+ List qs = NIL;
+ List vs = NIL;
+ for (; nonNull(fs); fs=tl(fs)) {
+ vs = cons(mkOffset(co+a+1-sfunPos(fst(hd(fs)),c)),vs);
+ qs = cons(snd(hd(fs)),qs);
+ }
+ ps = revOnto(qs,ps);
+ us = revOnto(vs,us);
+ }
+ else /* Normally just spool off patterns*/
+ for (; a>0; --a) { /* and corresponding offsets ... */
+ us = cons(mkOffset(++co),us);
+ ps = cons(arg(p),ps);
+ p = fun(p);
+ }
+
+ maPats(ma) = ps;
+ maOffs(ma) = us;
+}
+
+/* --------------------------------------------------------------------------
+ * Normalize and test for empty match:
+ * ------------------------------------------------------------------------*/
+
+static Bool local emptyMatch(ma)/* Normalize and test to see if a given */
+Cell ma; { /* match, ma, is empty. */
+
+ while (nonNull(maPats(ma))) {
+ Cell p;
+tidyHd: switch (whatIs(p=hd(maPats(ma)))) {
+ case LAZYPAT : { Cell nv = inventVar();
+ maRhs(ma) = ap(LETREC,
+ pair(remPat(snd(p),nv,NIL),
+ maRhs(ma)));
+ p = nv;
+ }
+ /* intentional fall-thru */
+ case VARIDCELL :
+ case VAROPCELL :
+ case DICTVAR : extSc(p,hd(maOffs(ma)),ma);
+ case WILDCARD : maPats(ma) = tl(maPats(ma));
+ maOffs(ma) = tl(maOffs(ma));
+ continue;
+
+ /* So-called "as-patterns"are really just pattern intersections:
+ * (p1@p2:ps, o:os, sc, e) ==> (p1:p2:ps, o:o:os, sc, e)
+ * (But the input grammar probably doesn't let us take
+ * advantage of this, so we stick with the special case
+ * when p1 is a variable.)
+ */
+ case ASPAT : extSc(fst(snd(p)),hd(maOffs(ma)),ma);
+ hd(maPats(ma)) = snd(snd(p));
+ goto tidyHd;
+
+ case FINLIST : hd(maPats(ma)) = mkConsList(snd(p));
+ return FALSE;
+
+ case STRCELL : { String s = textToStr(textOf(p));
+ for (p=NIL; *s!='\0'; ++s)
+ if (*s!='\\' || *++s=='\\')
+ p = ap(consChar(*s),p);
+ else
+ p = ap(consChar('\0'),p);
+ hd(maPats(ma)) = revOnto(p,nameNil);
+ }
+ return FALSE;
+
+ case AP : if (isName(fun(p)) && isCfun(fun(p))
+ && cfunOf(fun(p))==0
+ && name(fun(p)).defn==nameId) {
+ hd(maPats(ma)) = arg(p);
+ goto tidyHd;
+ }
+ /* intentional fall-thru */
+ case CHARCELL :
+ case NAME :
+ case CONFLDS :
+ return FALSE;
+
+ default : internal("emptyMatch");
+ }
+ }
+ return TRUE;
+}
+
+/* --------------------------------------------------------------------------
+ * Discriminators:
+ * ------------------------------------------------------------------------*/
+
+static Cell local maDiscr(ma) /* Get the discriminator for a non-empty */
+Cell ma; { /* match, ma. */
+ Cell p = hd(maPats(ma));
+ Cell h = getHead(p);
+ switch (whatIs(h)) {
+ case CONFLDS : return fst(snd(p));
+#if NPLUSK
+ case ADDPAT : arg(fun(p)) = translate(arg(fun(p)));
+ return fun(p);
+#endif
+#if TREX
+ case EXT : h = fun(fun(p));
+ arg(h) = translate(arg(h));
+ return h;
+#endif
+ case NAME : if (h==nameFromInt || h==nameFromInteger
+ || h==nameFromDouble) {
+ if (argCount==2)
+ arg(fun(p)) = translate(arg(fun(p)));
+ return p;
+ }
+ }
+ return h;
+}
+
+static Bool local isNumDiscr(d) /* TRUE => numeric discriminator */
+Cell d; {
+ switch (whatIs(d)) {
+ case NAME :
+ case TUPLE :
+ case CHARCELL : return FALSE;
+
+#if TREX
+ case AP : return !isExt(fun(d));
+#else
+ case AP : return TRUE; /* must be a literal or (n+k) */
+#endif
+ }
+ internal("isNumDiscr");
+ return 0;/*NOTREACHED*/
+}
+
+Int discrArity(d) /* Find arity of discriminator */
+Cell d; {
+ switch (whatIs(d)) {
+ case NAME : return name(d).arity;
+ case TUPLE : return tupleOf(d);
+ case CHARCELL : return 0;
+#if TREX
+ case AP : switch (whatIs(fun(d))) {
+#if NPLUSK
+ case ADDPAT : return 1;
+#endif
+ case EXT : return 2;
+ default : return 0;
+ }
+#else
+#if NPLUSK
+ case AP : return (whatIs(fun(d))==ADDPAT) ? 1 : 0;
+#else
+ case AP : return 0; /* must be an Int or Float lit */
+#endif
+#endif
+ }
+ internal("discrArity");
+ return 0;/*NOTREACHED*/
+}
+
+static Bool local eqNumDiscr(d1,d2) /* Determine whether two numeric */
+Cell d1, d2; { /* descriptors have same value */
+#if NPLUSK
+ if (whatIs(fun(d1))==ADDPAT)
+ return whatIs(fun(d2))==ADDPAT && snd(fun(d1))==snd(fun(d2));
+#endif
+ if (isInt(arg(d1)))
+ return isInt(arg(d2)) && intOf(arg(d1))==intOf(arg(d2));
+ if (isFloat(arg(d1)))
+ return isFloat(arg(d2)) && floatOf(arg(d1))==floatOf(arg(d2));
+#if BIGNUMS
+ if (isBignum(arg(d1)))
+ return isBignum(arg(d2)) && bigCmp(arg(d1),arg(d2))==0;
+#endif
+ internal("eqNumDiscr");
+ return FALSE;/*NOTREACHED*/
+}
+
+#if TREX
+static Bool local isExtDiscr(d) /* Test of extension discriminator */
+Cell d; {
+ return isAp(d) && isExt(fun(d));
+}
+
+static Bool local eqExtDiscr(d1,d2) /* Determine whether two extension */
+Cell d1, d2; { /* discriminators have same label */
+ return fun(d1)==fun(d2);
+}
+#endif
+
+/*-------------------------------------------------------------------------*/
+
+
+
+/* --------------------------------------------------------------------------
+ * STG stuff
+ * ------------------------------------------------------------------------*/
static Void local stgCGBinds( List );
return binds;
}
-#if 0
-/* This is a hack to see if "show [1..1000]" will go any faster if I
- * code primShowInt in C
- */
-char* prim_showInt(int x)
-{
- char buffer[50];
- sprintf(buffer,"%d",x);
- return buffer;
-}
-
-void prim_flush_stdout(void)
-{
- fflush(stdout);
-}
-#endif
Void evalExp() { /* compile and run input expression */
/* ToDo: this name (and other names generated during pattern match?)
* get inserted in the symbol table but never get removed.
*/
- Name n = newName(inventText());
+ Name n = newName(inventText(),NIL);
StgVar v = mkStgVar(NIL,NIL);
name(n).stgVar = v;
compiler(RESET);
/* Re-initialise the scheduler - ToDo: do I need this? */
initScheduler();
+ /* ToDo: don't really initScheduler every time. fix */
{
HaskellObj result; /* ignored */
SchedulerStatus status = rts_eval_(closureOfVar(v),10000,&result);
Name n = findName(t);
if (isNull(n)) { /* Lookup global name - the only way*/
- n = newName(t); /* this (should be able to happen) */
+ n = newName(t,NIL); /* this (should be able to happen) */
} /* is with new global var introduced*/
/* after type check; e.g. remPat1 */
name(n).stgVar = nv;
Int arity = length(fst(hd(defs)));
compiler(RESET);
+ currentName = n;
mapProc(transAlt,defs);
stgDefn(n,arity,match(arity,altsMatch(1,arity,NIL,defs)));
name(n).defn = NIL;
return s;
}
+
+#if 0
+I think this is 98-specific.
+static Void local newGlobalFunction(n,arity,fvs,co,e)
+Name n;
+Int arity;
+List fvs;
+Int co;
+Cell e; {
+#ifdef DEBUG_SHOWSC
+ extern Void printSc Args((FILE*, Text, Int, Cell));
+#endif
+ extraVars = fvs;
+ numExtraVars = length(extraVars);
+ localOffset = co;
+ localArity = arity;
+ name(n).arity = arity+numExtraVars;
+ e = preComp(e);
+#ifdef DEBUG_SHOWSC
+ if (debugCode) {
+ printSc(stdout,name(n).text,name(n).arity,e);
+ }
+#endif
+ name(n).code = codeGen(n,name(n).arity,e);
+}
+#endif
+
/* --------------------------------------------------------------------------
* Compiler control:
* ------------------------------------------------------------------------*/
Int what; {
switch (what) {
case INSTALL :
- case RESET : break;
- case MARK : break;
+ case RESET : freeVars = NIL;
+ freeFuns = NIL;
+ freeBegin = mkOffset(0);
+ //extraVars = NIL;
+ //numExtraVars = 0;
+ //localOffset = 0;
+ //localArity = 0;
+ break;
+
+ case MARK : mark(freeVars);
+ mark(freeFuns);
+ //mark(extraVars);
+ break;
}
}
-/* -*- mode: hugs-c; -*- */
/* --------------------------------------------------------------------------
* Connections between components of the Hugs system
*
- * 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
+ * Hugs 98 is Copyright (c) Mark P Jones, Alastair Reid and the Yale
+ * Haskell Group 1994-99, and is distributed as Open Source software
+ * under the Artistic License; see the file "Artistic" that is included
+ * in the distribution for details.
*
* $RCSfile: connect.h,v $
- * $Revision: 1.2 $
- * $Date: 1998/12/02 13:22:03 $
+ * $Revision: 1.3 $
+ * $Date: 1999/02/03 17:08:27 $
* ------------------------------------------------------------------------*/
/* --------------------------------------------------------------------------
* Standard data:
* ------------------------------------------------------------------------*/
+extern Bool haskell98; /* TRUE => Haskell 98 compatibility*/
+extern Module modulePrelude;
+extern Module modulePreludeHugs;
+
+/* --------------------------------------------------------------------------
+ * Primitive constructor functions
+ * ------------------------------------------------------------------------*/
+
+extern Name nameFalse, nameTrue;
+extern Name nameNil, nameCons;
+extern Name nameJust, nameNothing;
+extern Name nameLeft, nameRight;
+extern Name nameUnit;
+
+extern Name nameLT, nameEQ;
+extern Name nameGT;
+extern Name nameFst, nameSnd; /* standard combinators */
+extern Name nameId, nameOtherwise;
+extern Name nameNegate, nameFlip; /* primitives reqd for parsing */
+extern Name nameFrom, nameFromThen;
+extern Name nameFromTo, nameFromThenTo;
+extern Name nameFatbar, nameFail; /* primitives reqd for translation */
+extern Name nameIf, nameSel;
+extern Name nameCompAux;
+extern Name namePmInt, namePmFlt; /* primitives for pattern matching */
+extern Name namePmInteger;
+#if NPLUSK
+extern Name namePmNpk, namePmSub; /* primitives for (n+k) patterns */
+#endif
+extern Name nameError; /* For runtime error messages */
+extern Name nameUndefined; /* A generic undefined value */
+extern Name nameBlackHole; /* For GC-detected black hole */
+extern Name nameInd; /* For dict indirection */
+extern Name nameAnd, nameOr; /* For optimisation of && and || */
+extern Name nameFromInt, nameFromDouble;/*coercion of numerics */
+extern Name nameFromInteger;
+extern Name nameEq, nameCompare; /* names used for deriving */
+extern Name nameMinBnd, nameMaxBnd;
+extern Name nameIndex, nameInRange;
+extern Name nameRange;
+extern Name nameLe, nameGt;
+extern Name nameShowsPrec, nameReadsPrec;
+extern Name nameMult, namePlus;
+extern Name nameConCmp, nameEnRange;
+extern Name nameEnIndex, nameEnInRng;
+extern Name nameEnToEn, nameEnFrEn;
+extern Name nameEnFrom, nameEnFrTh;
+extern Name nameEnFrTo;
+extern Name nameComp, nameApp; /* composition and append */
+extern Name nameShowField; /* display single field */
+extern Name nameShowParen; /* wrap with parens */
+extern Name nameReadField; /* read single field */
+extern Name nameReadParen; /* unwrap from parens */
+extern Name nameLex; /* lexer */
+extern Name nameRangeSize; /* calculate size of index range */
+extern Class classMonad; /* Monads */
+extern Name nameReturn, nameBind; /* for translating monad comps */
+extern Name nameMFail;
+extern Name nameListMonad; /* builder function for List Monad */
+
+#if EVAL_INSTANCES
+extern Name nameStrict, nameSeq; /* Members of class Eval */
+extern Name nameIStrict, nameISeq; /* ... and their implementations */
+#endif
+
+extern Name namePrint; /* printing primitive */
+
+#if IO_MONAD
+extern Type typeProgIO; /* For the IO monad, IO () */
+extern Name nameIORun; /* IO monad executor */
+extern Name namePutStr; /* Prelude.putStr */
+extern Name nameUserErr; /* primitives required for IOError */
+extern Name nameNameErr, nameSearchErr;
+#endif
+
+#if IO_HANDLES
+extern Name nameWriteErr, nameIllegal;/* primitives required for IOError */
+extern Name nameEOFErr;
+#endif
+
+extern Text textPrelude;
+extern Text textNum; /* used to process default decls */
+#if NPLUSK
+extern Text textPlus; /* Used to recognise n+k patterns */
+#endif
+#if TREX
+extern Name nameNoRec; /* The empty record */
+extern Type typeNoRow; /* The empty row */
+extern Type typeRec; /* Record formation */
+extern Kind extKind; /* Kind of extension, *->row->row */
+extern Name nameRecExt; /* Extend a record */
+extern Name nameRecBrk; /* Break a record */
+extern Name nameAddEv; /* Addition of evidence values */
+extern Name nameRecSel; /* Select a record */
+extern Name nameRecShw; /* Show a record */
+extern Name nameShowRecRow; /* Used to output rows */
+extern Name nameRecEq; /* Compare records */
+extern Name nameEqRecRow; /* Used to compare rows */
+extern Name nameInsFld; /* Field insertion routine */
+#endif
+
+extern String repeatStr; /* Repeat last command string */
+extern String hugsEdit; /* String for editor command */
+extern String hugsPath; /* String for file search path */
+extern String projectPath; /* String for project search path */
+
+extern Type typeArrow; /* Builtin type constructors */
+extern Type typeList;
+extern Type typeUnit;
+
+#define fn(from,to) ap(ap(typeArrow,from),to) /* make type: from -> to */
+
+extern List stdDefaults; /* List of standard default types */
+
+extern Class classEq; /* `standard' classes */
+extern Class classOrd;
+extern Class classShow;
+extern Class classRead;
+extern Class classIx;
+extern Class classEnum;
+#if EVAL_INSTANCES
+extern Class classEval;
+#endif
+extern Class classBounded;
+
+extern Class classReal; /* `numeric' classes */
+extern Class classIntegral;
+extern Class classRealFrac;
+extern Class classRealFloat;
+extern Class classFractional;
+extern Class classFloating;
+extern Class classNum;
+
+extern Cell *CStackBase; /* pointer to base of C stack */
+
+extern List tyconDefns; /* list of type constructor defns */
+extern List typeInDefns; /* list of synonym restrictions */
+extern List valDefns; /* list of value definitions */
+extern List classDefns; /* list of class definitions */
+extern List instDefns; /* list of instance definitions */
+extern List selDefns; /* list of selector lists */
+extern List genDefns; /* list of generated defns */
+extern List primDefns; /* list of primitive definitions */
+extern List unqualImports; /* unqualified import list */
+extern List defaultDefns; /* default definitions (if any) */
+extern Int defaultLine; /* line in which default defs occur*/
+extern List evalDefaults; /* defaults for evaluator */
+extern Cell inputExpr; /* evaluator input expression */
+extern Addr inputCode; /* Code for compiled input expr */
+
+extern Int whnfArgs; /* number of args of term in whnf */
+extern Cell whnfHead; /* head of term in whnf */
+extern Int whnfInt; /* integer value of term in whnf */
+extern Float whnfFloat; /* float value of term in whnf */
+/*ToDo?? extern Long numReductions;*/ /* number of reductions used */
+extern Long numCells; /* number of cells allocated */
+extern Int numGcs; /* number of garbage collections */
+extern Bool broken; /* indicates interrupt received */
+/*ToDo?? extern Bool preludeLoaded;*/ /* TRUE => prelude has been loaded */
+
+extern Bool gcMessages; /* TRUE => print GC messages */
+extern Bool literateScripts; /* TRUE => default lit scripts */
+extern Bool literateErrors; /* TRUE => report errs in lit scrs */
+/*ToDo?? extern Bool failOnError;*/ /* TRUE => error produces immediate*/
+ /* termination */
+
+extern Int cutoff; /* Constraint Cutoff depth */
+
+#if USE_PREPROCESSOR
+extern String preprocessor; /* preprocessor command */
+#endif
+
+#if DEBUG_CODE
+extern Bool debugCode; /* TRUE => print G-code to screen */
+#endif
+extern Bool kindExpert; /* TRUE => display kind errors in */
+ /* full detail */
+extern Bool allowOverlap; /* TRUE => allow overlapping insts */
+
/* --------------------------------------------------------------------------
* Function prototypes etc...
* ------------------------------------------------------------------------*/
+extern Void everybody Args((Int));
+
#define RESET 1 /* reset subsystem */
#define MARK 2 /* mark parts of graph in use by subsystem */
#define INSTALL 3 /* install subsystem (executed once only) */
#define EXIT 4 /* Take action immediately before exit() */
#define BREAK 5 /* Take action after program break */
-extern Void everybody Args((Int));
-extern Void machdep Args((Int));
+typedef long Target;
+extern Void setGoal Args((String, Target));
+extern Void soFar Args((Target));
+extern Void done Args((Void));
+extern String fromEnv Args((String,String));
+extern Bool chase Args((List));
+
extern Void storage Args((Int));
-extern Void linkControl Args((Int));
-extern Void translateControl Args((Int));
-extern Void staticAnalysis Args((Int));
-extern Void interface Args((Int));
-extern Void deriveControl Args((Int));
+
extern Void input Args((Int));
+extern Void consoleInput Args((String));
+extern Void projInput Args((String));
+extern Void stringInput Args((String));
+extern Void parseScript Args((String,Long));
+extern Void parseExp Args((Void));
+extern String readFilename Args((Void));
+extern String readLine Args((Void));
+extern Syntax defaultSyntax Args((Text));
+extern Syntax syntaxOf Args((Name));
+extern String unlexChar Args((Char,Char));
+extern Void printString Args((String));
+
+extern Void substitution Args((Int));
+
+extern Void staticAnalysis Args((Int));
+#if IGNORE_MODULES
+#define startModule(m) doNothing()
+#define setExportList(l) doNothing()
+#define setExports(l) doNothing()
+#define addQualImport(m,as) doNothing()
+#define addUnqualImport(m,l) doNothing()
+#else
+extern Void startModule Args((Cell));
+extern Void setExportList Args((List));
+extern Void setExports Args((List));
+extern Void addQualImport Args((Text,Text));
+extern Void addUnqualImport Args((Text,List));
+#endif
+extern Void tyconDefn Args((Int,Cell,Cell,Cell));
+extern Void setTypeIns Args((List));
+extern Void clearTypeIns Args((Void));
+extern Type fullExpand Args((Type));
+extern Bool isAmbiguous Args((Type));
+extern Void ambigError Args((Int,String,Cell,Type));
+extern Void classDefn Args((Int,Cell,Cell));
+extern Void instDefn Args((Int,Cell,Cell));
+extern Void addTupInst Args((Class,Int));
+#if EVAL_INSTANCES
+extern Void addEvalInst Args((Int,Cell,Int,List));
+#endif
+#if TREX
+extern Inst addRecShowInst Args((Class,Ext));
+extern Inst addRecEqInst Args((Class,Ext));
+#endif
+extern Void primDefn Args((Cell,List,Cell));
+extern Void defaultDefn Args((Int,List));
+extern Void checkExp Args((Void));
+extern Void checkDefns Args((Void));
+extern Bool h98Pred Args((Bool,Cell));
+extern Cell h98Context Args((Bool,List));
+extern Void h98CheckCtxt Args((Int,String,Bool,List,Inst));
+extern Void h98CheckType Args((Int,String,Cell,Type));
+extern Void h98DoesntSupport Args((Int,String));
+
extern Void typeChecker Args((Int));
-extern Void desugarControl Args((Int));
-extern Void codegen Args((Int));
+extern Type typeCheckExp Args((Bool));
+extern Void typeCheckDefns Args((Void));
+extern Cell provePred Args((Kinds,List,Cell));
+extern List simpleContext Args((List,Int));
+extern Cell rhsExpr Args((Cell));
+extern Int rhsLine Args((Cell));
+extern Bool isProgType Args((List,Type));
+extern Cell superEvid Args((Cell,Class,Class));
+extern Void linkPreludeTC Args((Void));
+extern Void linkPreludeCM Args((Void));
+
extern Void compiler Args((Int));
-extern Void substitution Args((Int));
-extern Void stgTranslate Args((Int));
-extern Void codegen Args((Int));
+extern Void compileDefns Args((Void));
+extern Void compileExp Args((Void));
+extern Bool failFree Args((Cell));
+extern Int discrArity Args((Cell));
+
+extern Addr codeGen Args((Name,Int,Cell));
+extern Void implementCfun Args((Name,List));
+#if TREX
+extern Name implementRecShw Args((Text,Cell));
+extern Name implementRecEq Args((Text,Cell));
+#endif
+extern Void addCfunTable Args((Tycon));
+extern Name succCfun Args((Name));
+extern Name nextCfun Args((Name,Name));
+extern Name cfunByNum Args((Name,Int));
+extern Void unwind Args((Cell));
+extern Void run Args((Addr,StackPtr));
+
+extern Void eval Args((Cell));
+extern Cell evalWithNoError Args((Cell));
+extern Void evalFails Args((StackPtr));
+
+#if BYTECODE_PRIMS
+extern Int IntAt Args((Addr));
+#if !BREAK_FLOATS
+extern Float FloatAt Args((Addr));
+#endif
+extern Cell CellAt Args((Addr));
+extern Text TextAt Args((Addr));
+extern Addr AddrAt Args((Addr));
+extern Int InstrAt Args((Addr));
+#endif /* BYTECODE_PRIMS */
+
+extern Void abandon Args((String,Cell));
+extern Void outputString Args((FILE *));
+extern Void dialogue Args((Cell));
+#define consChar(c) ap(conCons,mkChar(c))
+
+#if BIGNUMS
+extern Bignum bigInt Args((Int));
+extern Bignum bigDouble Args((double));
+extern Bignum bigNeg Args((Bignum));
+extern Cell bigToInt Args((Bignum));
+extern Cell bigToFloat Args((Bignum));
+extern Bignum bigStr Args((String));
+extern Cell bigOut Args((Bignum,Cell,Bool));
+extern Bignum bigShift Args((Bignum,Int,Int));
+extern Int bigCmp Args((Bignum,Bignum));
+#endif
+#if IO_MONAD
+extern Void setHugsArgs Args((Int,String[]));
+#endif
+
+#if PROFILING
+extern String timeString Args((Void));
+#endif
+
+extern Int shellEsc Args((String));
+extern Int getTerminalWidth Args((Void));
+extern Void normalTerminal Args((Void));
+extern Void noechoTerminal Args((Void));
+extern Int readTerminalChar Args((Void));
+extern Void gcStarted Args((Void));
+extern Void gcScanning Args((Void));
+extern Void gcRecovered Args((Int));
+extern Void gcCStack Args((Void));
+extern Void needPrims Args((Int));
+
+extern Type primType( Int /*AsmMonad*/ monad, String a_kinds, String r_kinds );
+#define aVar mkOffset(0) /* Simple skeleton for type var */
+
+/*-------------------------------------------------------------------------*/
+
+/*---------------------------------------------------------------------------
+ * Interrupting execution (signals, allowBreak):
+ *-------------------------------------------------------------------------*/
+
+extern Bool breakOn Args((Bool));
+
+extern Bool broken; /* indicates interrupt received */
+
+#ifndef SIGBREAK /* Sigh, not defined in cygwin32 beta release 16 */
+# define SIGBREAK 21
+#endif
+
+/* allowBreak: call to allow user to interrupt computation
+ * ctrlbrk: set control break handler
+ */
+
+#if HUGS_FOR_WINDOWS
+# define ctrlbrk(bh)
+# define allowBreak() kbhit()
+#else /* !HUGS_FOR_WINDOWS */
+# define ctrlbrk(bh) signal(SIGINT,bh); signal(SIGBREAK,bh)
+# define allowBreak() if (broken) { broken=FALSE; sigRaise(breakHandler); }
+#endif /* !HUGS_FOR_WINDOWS */
+
+/*---------------------------------------------------------------------------
+ * Environment variables and the registry
+ *-------------------------------------------------------------------------*/
+
+/* On Win32 we can use the registry to supplement info in environment
+ * variables.
+ */
+#define USE_REGISTRY (HAVE_WINDOWS_H && !__MSDOS__)
+
+#ifdef USE_REGISTRY
+Bool writeRegString Args((String var, String val));
+String readRegString Args((String var, String def));
+Int readRegInt Args((String var, Int def));
+Bool writeRegInt Args((String var, Int val));
+#endif
+
+/*---------------------------------------------------------------------------
+ * File operations:
+ *-------------------------------------------------------------------------*/
+
+#if HAVE_UNISTD_H
+# include <sys/types.h>
+# include <unistd.h>
+#elif !HUGS_FOR_WINDOWS
+extern int chdir Args((const char*));
+#endif
+
+#if HAVE_STDLIB_H
+# include <stdlib.h>
+#else
+extern int system Args((const char *));
+extern double atof Args((const char *));
+extern void exit Args((int));
+#endif
+
+#ifndef FILENAME_MAX /* should already be defined in an ANSI compiler*/
+#define FILENAME_MAX 256
+#else
+#if FILENAME_MAX < 256
+#undef FILENAME_MAX
+#define FILENAME_MAX 256
+#endif
+#endif
+
+/* Hack, hack: if you have dos.h, you probably have a DOS filesystem */
+#define DOS_FILENAMES HAVE_DOS_H
+/* ToDo: can we replace this with a feature test? */
+#define MAC_FILENAMES SYMANTEC_C
+
+#define CASE_INSENSITIVE_FILENAMES (DOS_FILENAMES | RISCOS)
+
+#if CASE_INSENSITIVE_FILENAMES
+# if HAVE_STRCASECMP
+# define filenamecmp(s1,s2) strcasecmp(s1,s2)
+# elif HAVE__STRICMP
+# define filenamecmp(s1,s2) _stricmp(s1,s2)
+# elif HAVE_STRICMP
+# define filenamecmp(s1,s2) stricmp(s1,s2)
+# elif HAVE_STRCMPI
+# define filenamecmp(s1,s2) strcmpi(s1,s2)
+# endif
+#else
+# define filenamecmp(s1,s2) strcmp(s1,s2)
+#endif
+
+/*---------------------------------------------------------------------------
+ * Pipe-related operations:
+ *
+ * On Windows, many standard Unix names acquire a leading underscore.
+ * Irritating, but easy to work around.
+ *-------------------------------------------------------------------------*/
+
+#if !defined(HAVE_POPEN) && defined(HAVE__POPEN)
+#define popen(x,y) _popen(x,y)
+#endif
+#if !defined(HAVE_PCLOSE) && defined(HAVE__PCLOSE)
+#define pclose(x) _pclose(x)
+#endif
+
+/*---------------------------------------------------------------------------
+ * Bit manipulation:
+ *-------------------------------------------------------------------------*/
+
+#define bitArraySize(n) ((n)/bitsPerWord + 1)
+#define placeInSet(n) ((-(n)-1)>>wordShift)
+#define maskInSet(n) (1<<((-(n)-1)&wordMask))
+
+/*---------------------------------------------------------------------------
+ * Function prototypes for code in machdep.c
+ *-------------------------------------------------------------------------*/
+
+extern String findMPathname Args((String,String,String));
+extern String findPathname Args((String,String));
+
+extern Int shellEsc Args((String));
+extern Int getTerminalWidth Args((Void));
+extern Void normalTerminal Args((Void));
+extern Void noechoTerminal Args((Void));
+extern Int readTerminalChar Args((Void));
+extern Void gcStarted Args((Void));
+extern Void gcScanning Args((Void));
+extern Void gcRecovered Args((Int));
+extern Void gcCStack Args((Void));
/*-------------------------------------------------------------------------*/
+
+extern Type typeInt64;
+extern Type typeWord;
+extern Type typeFloat;
+extern Type typePrimArray;
+extern Type typePrimByteArray;
+extern Type typeRef;
+extern Type typePrimMutableArray;
+extern Type typePrimMutableByteArray;
+extern Type typeStable;
+extern Type typeWeak;
+extern Type typeIO;
+extern Type typeForeign;
+extern Type typeMVar;
+extern Type typeThreadId;
+extern Type typeException;
+extern Type typeIO;
+extern Type typeST;
+
+extern Void foreignImport Args((Cell,Pair,Cell,Cell));
+extern List foreignImports; /* foreign import declarations */
+extern Void implementForeignImport Args((Name));
+extern Void foreignExport Args((Cell,Cell,Cell,Cell));
+extern List foreignExports; /* foreign export declarations */
+extern Void implementForeignExport Args((Name));
+
+extern List diVars;
+extern Int diNum;
+
+Int userArity Args((Name));
+
+
+extern List deriveEq Args((Tycon));
+extern List deriveOrd Args((Tycon));
+extern List deriveEnum Args((Tycon));
+extern List deriveIx Args((Tycon));
+extern List deriveShow Args((Tycon));
+extern List deriveRead Args((Cell));
+extern List deriveBounded Args((Tycon));
+extern List checkPrimDefn Args((Triple));
+
+extern Bool typeMatches Args((Type,Type));
+extern Void evalExp Args((Void));
+extern Void linkControl Args((Int));
+extern Void deriveControl Args((Int));
+extern Void translateControl Args((Int));
+extern Void codegen Args((Int));
-/* -*- mode: hugs-c; -*- */
+
/* --------------------------------------------------------------------------
* Deriving
*
* Hugs version 1.4, December 1997
*
* $RCSfile: derive.c,v $
- * $Revision: 1.2 $
- * $Date: 1998/12/02 13:22:03 $
+ * $Revision: 1.3 $
+ * $Date: 1999/02/03 17:08:27 $
* ------------------------------------------------------------------------*/
#include "prelude.h"
#include "storage.h"
+#include "backend.h"
#include "connect.h"
#include "errors.h"
-#include "translate.h" /* for implementConTag */
-#include "derive.h"
static Cell varTrue;
static Cell varFalse;
static Cell varMaxBound;
#endif
#if DERIVE_SHOW
-static Cell conCons;
+ Cell conCons;
static Cell varShowField; /* display single field */
static Cell varShowParen; /* wrap with parens */
static Cell varCompose; /* function composition */
static Bool local isEnumType Args((Tycon));
#endif
+static Pair local mkAltEq Args((Int,List));
+static Pair local mkAltOrd Args((Int,List));
+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 mkIxBinds Args((Int,Cell,Int));
+static Cell local mkAltShow Args((Int,Cell,Int));
+static Cell local showsPrecRhs Args((Cell,Cell,Int));
+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));
+static List local mkBndBinds Args((Int,Cell,Int));
+
+
+
/* --------------------------------------------------------------------------
* 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 */
- List us = getDiVars(2*n);
- List vs = NIL;
- Cell p;
- Int i;
-
- for (i=0, p=h; i<n; ++i) { /* make first version of pattern */
- p = ap(p,hd(us));
- us = tl(us);
- }
- vs = cons(p,vs);
-
- for (i=0, p=h; i<n; ++i) { /* make second version of pattern */
- p = ap(p,hd(us));
- us = tl(us);
- }
- 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)) {
- List cs = tycon(t).defn;
- for (; hasCfun(cs); cs=tl(cs)) {
- if (name(hd(cs)).arity!=0) {
- return FALSE;
- }
- }
- return TRUE;
- }
- return FALSE;
-}
-#endif
-
/* --------------------------------------------------------------------------
* Given a datatype: data T a b = A a b | B Int | C deriving (Eq, Ord)
* The derived definitions of equality and ordering are given by:
* constructors in the datatype definition.
* ------------------------------------------------------------------------*/
-#if DERIVE_EQ
-
-static Pair local mkAltEq Args((Int,List));
+#define ap2(f,x,y) ap(ap(f,x),y)
-List deriveEq(t) /* generate binding for derived == */
+List local deriveEq(t) /* generate binding for derived == */
Type t; { /* for some TUPLE or DATATYPE t */
List alts = NIL;
if (isTycon(t)) { /* deal with type constrs */
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 */
+ }
+ else { /* special case for tuples */
alts = singleton(mkAltEq(0,makeDPats2(t,tupleOf(t))));
}
return singleton(mkBind("==",alts));
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));
List deriveOrd(t) /* make binding for derived compare*/
Type t; { /* for some TUPLE or DATATYPE t */
List alts = NIL;
if (isEnumType(t)) { /* special case for enumerations */
- Cell u = inventVar();
- Cell w = inventVar();
- Cell rhs = NIL;
- if (cfunOf(hd(tycon(t).defn))!=0) {
- implementConToTag(t);
- rhs = ap2(varCompare,
- ap(tycon(t).conToTag,u),
- ap(tycon(t).conToTag,w));
- } else {
- rhs = varEQ;
- }
- alts = singleton(pair(doubleton(u,w),pair(mkInt(tycon(t).line),rhs)));
+ alts = mkVarAlts(tycon(t).line,nameConCmp);
} 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) {
Cell u = inventVar();
Cell w = inventVar();
- implementConToTag(t);
- alts = cons(pair(doubleton(u,w),
+ alts = cons(pair(cons(u,singleton(w)),
pair(mkInt(tycon(t).line),
- ap2(varCompare,
- ap(tycon(t).conToTag,u),
- ap(tycon(t).conToTag,w)))),
- alts);
+ ap2(nameConCmp,u,w))),alts);
}
alts = rev(alts);
} else { /* special case for tuples */
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 = ap(ap2(nameCompAux,arg(p),arg(q)),e);
}
}
return pair(pats,pair(mkInt(line),e));
}
-#endif /* 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 */
+ List us = getDiVars(2*n);
+ List vs = NIL;
+ Cell p;
+ Int i;
+
+ for (i=0, p=h; i<n; ++i) { /* make first version of pattern */
+ p = ap(p,hd(us));
+ us = tl(us);
+ }
+ vs = cons(p,vs);
+
+ for (i=0, p=h; i<n; ++i) { /* make second version of pattern */
+ p = ap(p,hd(us));
+ us = tl(us);
+ }
+ return cons(p,vs);
+}
/* --------------------------------------------------------------------------
* 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();
- Cell first = hd(tycon(t).defn);
- Cell last = tycon(t).defn;
+ Int l = tycon(t).line;
if (!isEnumType(t)) {
ERRMSG(l) "Can only derive instances of Enum for enumeration types"
EEND;
}
- while (hasCfun(tl(last))) {
- last = tl(last);
- }
- last = hd(last);
- implementConToTag(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))));
-}
-#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));
+ return cons(mkBind("toEnum",mkVarAlts(l,ap(nameEnToEn,hd(tycon(t).defn)))),
+ cons(mkBind("fromEnum",mkVarAlts(l,nameEnFrEn)),
+ cons(mkBind("enumFrom",mkVarAlts(l,nameEnFrom)),
+ cons(mkBind("enumFromTo",mkVarAlts(l,nameEnFrTo)),
+ cons(mkBind("enumFromThen",mkVarAlts(l,nameEnFrTh)),NIL)))));
+}
List deriveIx(t) /* Construct definition of indexing */
Tycon t; {
- Int l = tycon(t).line;
if (isEnumType(t)) { /* Definitions for enumerations */
- implementConToTag(t);
- implementTagToCon(t);
- return mkIxBindsEnum(t);
+ return cons(mkBind("range",mkVarAlts(tycon(t).line,nameEnRange)),
+ cons(mkBind("index",mkVarAlts(tycon(t).line,nameEnIndex)),
+ cons(mkBind("inRange",mkVarAlts(tycon(t).line,nameEnInRng)),
+ NIL)));
} else if (isTuple(t)) { /* Definitions for product types */
return mkIxBinds(0,t,tupleOf(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"
return NIL;/* NOTREACHED*/
}
-/* instance Ix T where
- * range (c1,c2) = map tagToCon [conToTag c1 .. conToTag c2]
- * index b@(c1,c2) ci
- * | inRange b ci = conToTag ci - conToTag c1
- * | otherwise = error "Ix.index.T: Index out of range."
- * inRange (c1,c2) ci = conToTag c1 <= i && i <= conToTag c2
- * where i = conToTag ci
- */
-static List local mkIxBindsEnum(t)
-Tycon t; {
- Int l = tycon(t).line;
- Name tagToCon = tycon(t).tagToCon;
- Name conToTag = tycon(t).conToTag;
- Cell b = inventVar();
- 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 */
- NIL)));
+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)) {
+ List cs = tycon(t).defn;
+ for (; hasCfun(cs); cs=tl(cs)) {
+ if (name(hd(cs)).arity!=0) {
+ return FALSE;
+ }
+ }
+ /* ToDo: correct? addCfunTable(t); */
+ return TRUE;
+ }
+ return FALSE;
}
static List local mkIxBinds(line,h,n) /* build bindings for derived Ix on*/
pats = cons(pr,cons(is,NIL)); /* Build [(ls,us),is] */
return cons(prodRange(line,singleton(pr),ls,us,is),
- cons(prodIndex(line,pats,ls,us,is),
- cons(prodInRange(line,pats,ls,us,is),
- NIL)));
+ cons(prodIndex(line,pats,ls,us,is),
+ cons(prodInRange(line,pats,ls,us,is),NIL)));
}
static Cell local prodRange(line,pats,ls,us,is)
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(name(h).text)),
ap(showsBQ,rhs)));
} else {
- rhs = ap2(varCompose,ap(varAppend,mkStr(name(h).text)),rhs);
+ rhs = ap2(nameComp,ap(nameApp,mkStr(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:
+ * Derivation control:
* ------------------------------------------------------------------------*/
Void deriveControl(what)
-/* -*- mode: hugs-c; -*- */
+
/* --------------------------------------------------------------------------
* Dynamic loading (of .dll or .so files) for Hugs
*
* Hugs version 1.4, December 1997
*
* $RCSfile: dynamic.c,v $
- * $Revision: 1.2 $
- * $Date: 1998/12/02 13:22:06 $
+ * $Revision: 1.3 $
+ * $Date: 1999/02/03 17:08:28 $
* ------------------------------------------------------------------------*/
#include "prelude.h"
void* lookupSymbol(file,symbol)
ObjectFile file;
String symbol; {
- return dlsym(file,symbol)
+ return dlsym(file,symbol);
}
void* getDLLSymbol(dll,symbol) /* load dll and lookup symbol */
-/* -*- mode: hugs-c; -*- */
+
/* --------------------------------------------------------------------------
* Error handling support functions
*
- * 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
+ * Hugs 98 is Copyright (c) Mark P Jones, Alastair Reid and the Yale
+ * Haskell Group 1994-99, and is distributed as Open Source software
+ * under the Artistic License; see the file "Artistic" that is included
+ * in the distribution for details.
*
* $RCSfile: errors.h,v $
- * $Revision: 1.2 $
- * $Date: 1998/12/02 13:22:07 $
+ * $Revision: 1.3 $
+ * $Date: 1999/02/03 17:08:28 $
* ------------------------------------------------------------------------*/
-extern Void internal Args((String)) HUGS_noreturn;
-extern Void fatal Args((String)) HUGS_noreturn;
+extern Void internal Args((String)) HUGS_noreturn;
+extern Void fatal Args((String)) HUGS_noreturn;
#if HUGS_FOR_WINDOWS
#define Hilite() WinTextcolor(hWndText,RED);
extern sigProto(breakHandler);
-#include "output.h"
+extern Bool breakOn Args((Bool)); /* in machdep.c */
+
+extern Void printExp Args((FILE *,Cell)); /* in output.c */
+extern Void printType Args((FILE *,Cell));
+extern Void printContext Args((FILE *,List));
+extern Void printPred Args((FILE *,Cell));
+extern Void printKind Args((FILE *,Kind));
+extern Void printKinds Args((FILE *,Kinds));
/*-------------------------------------------------------------------------*/
-/* -*- mode: hugs-c; -*- */
+
/* --------------------------------------------------------------------------
* Free variable analysis
*
* Hugs version 1.4, December 1997
*
* $RCSfile: free.c,v $
- * $Revision: 1.2 $
- * $Date: 1998/12/02 13:22:08 $
+ * $Revision: 1.3 $
+ * $Date: 1999/02/03 17:08:29 $
* ------------------------------------------------------------------------*/
#include "prelude.h"
#include "storage.h"
+#include "backend.h"
#include "connect.h"
#include "errors.h"
-#include "stg.h"
-#include "free.h"
+
/* --------------------------------------------------------------------------
* Local functions
-/* -*- mode: hugs-c; -*- */
+
/* --------------------------------------------------------------------------
* Command interpreter
*
- * 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
+ * Hugs 98 is Copyright (c) Mark P Jones, Alastair Reid and the Yale
+ * Haskell Group 1994-99, and is distributed as Open Source software
+ * under the Artistic License; see the file "Artistic" that is included
+ * in the distribution for details.
*
* $RCSfile: hugs.c,v $
- * $Revision: 1.2 $
- * $Date: 1998/12/02 13:22:09 $
+ * $Revision: 1.3 $
+ * $Date: 1999/02/03 17:08:29 $
* ------------------------------------------------------------------------*/
+#include <setjmp.h>
+#include <ctype.h>
+#include <stdio.h>
+
#include "prelude.h"
-#include "version.h"
#include "storage.h"
#include "command.h"
+#include "backend.h"
#include "connect.h"
-#include "charset.h"
-#include "input.h"
-#include "type.h"
-#include "subst.h" /* for typeMatches */
-#include "link.h" /* for classShow, nameRunIO and namePrint */
-#include "static.h"
-#include "compiler.h"
-#include "interface.h"
-#include "hugs.h"
#include "errors.h"
-#include <setjmp.h>
-#include <ctype.h>
+#include "version.h"
+#include "link.h"
+
+#include "Rts.h"
+#include "RtsAPI.h"
+#include "Schedule.h"
-#include <stdio.h>
-#include "machdep.h"
+Bool haskell98 = TRUE; /* TRUE => Haskell 98 compatibility*/
/* --------------------------------------------------------------------------
* Local function prototypes:
static Void local whatScripts Args((Void));
static Void local editor Args((Void));
static Void local find Args((Void));
+static Bool local startEdit Args((Int,String));
static Void local runEditor Args((Void));
+#if IGNORE_MODULES
+#define findEvalModule() doNothing()
+#else
static Void local setModule Args((Void));
static Module local findEvalModule Args((Void));
+#endif
static Void local evaluator Args((Void));
+static Void local stopAnyPrinting Args((Void));
static Void local showtype Args((Void));
+static String local objToStr Args((Module, Cell));
static Void local info Args((Void));
+static Void local printSyntax Args((Name));
static Void local showInst Args((Inst));
static Void local describe Args((Text));
static Void local listNames Args((Void));
* Machine dependent code for Hugs interpreter:
* ------------------------------------------------------------------------*/
+#include "machdep.c"
#ifdef WANT_TIMER
#include "timer.c"
#endif
* Local data areas:
* ------------------------------------------------------------------------*/
+static Bool printing = FALSE; /* TRUE => currently printing value*/
+static Bool showStats = FALSE; /* TRUE => print stats after eval */
static Bool listScripts = TRUE; /* TRUE => list scripts after loading*/
-static Bool addType = FALSE; /* TRUE => print type with value */
+static Bool addType = FALSE; /* TRUE => print type with value */
+static Bool useShow = TRUE; /* TRUE => use Text/show printer */
static Bool chaseImports = TRUE; /* TRUE => chase imports on load */
static Bool useDots = RISCOS; /* TRUE => use dots in progress */
static Bool quiet = FALSE; /* TRUE => don't show progress */
CStackBase = &argc; /* Save stack base for use in gc */
- /* The startup banner now includes my name. Hugs is provided free of */
- /* charge. I ask however that you show your appreciation for the many */
- /* hours of work involved by retaining my name in the banner. Thanks! */
+ Printf("__ __ __ __ ____ ___ _______________________________________________\n");
+ Printf("|| || || || || || ||__ Hugs 98: The Nottingham and Yale Haskell system\n");
+ Printf("||___|| ||__|| ||__|| __|| Copyright (c) 1994-1999\n");
+ Printf("||---|| ___|| World Wide Web: http://haskell.org/hugs\n");
+ Printf("|| || Report bugs to: hugs-bugs@haskell.org\n");
+ Printf("|| || Version: %s _______________________________________________\n\n",HUGS_VERSION);
-#if SMALL_BANNER
- Printf("Hugs 1.4, %s release.\n", HUGS_VERSION);
- Printf("Copyright (c) The University of Nottingham and Yale University, 1994-1998.\n");
- Printf("Home page: http://haskell.org/hugs. Bug reports: hugs-bugs@haskell.org.\n");
-#else
-#ifdef OLD_LOGO
- Printf(" ___ ___ ___ ___ __________ __________ \n");
- Printf(" / / / / / / / / / _______/ / _______/ Hugs 1.4 \n");
- Printf(" / /___/ / / / / / / / _____ / /______ \n");
- Printf(" / ____ / / / / / / / /_ / /______ / The Nottingham and Yale\n");
- Printf(" / / / / / /___/ / / /___/ / _______/ / Haskell User's System \n");
- Printf(" /__/ /__/ /_________/ /_________/ /_________/ %s\n\n", HUGS_VERSION);
- Printf("Copyright (c) The University of Nottingham and Yale University, 1994-1998.\n");
- Printf("Home page: http://haskell.org/hugs. Bug reports: hugs-bugs@haskell.org.\n");
-#else
- /* There is now a new banner, designed to draw attention to the fact */
- /* that the version of Hugs being used is substantially different from */
- /* previous releases (and to correct the mistaken view that Hugs is */
- /* written in capitals). If you really prefer the old style banner, */
- /* you can still get it by compiling with -DOLD_LOGO. */
-
- printf(" __ __ __ __ ____ ___ __________________________________________\n");
- printf(" || || || || || || ||__ Hugs 1.4: The Haskell User's Gofer System\n");
- printf(" ||___|| ||__|| ||__|| __|| (c) The University of Nottingham\n");
- printf(" ||---|| ___|| and Yale University, 1994-1998.\n");
- printf(" || || Report bugs to hugs-bugs@haskell.org\n");
- printf(" || || "HUGS_VERSION" __________________________________________\n\n");
-#endif
-#endif
#if SYMANTEC_C
Printf(" Ported to Macintosh by Hans Aberg, compiled " __DATE__ ".\n\n");
#endif
scriptFile = 0;
numScripts = 0;
namesUpto = 1;
- initCharTab();
#if HUGS_FOR_WINDOWS
hugsEdit = strCopy(fromEnv("EDITOR","c:\\windows\notepad.exe"));
#else
hugsEdit = strCopy(fromEnv("EDITOR",NULL));
#endif
- hugsPath = strCopy(HUGSPATH);
- readOptions("-p\"%s> \" -r$$");
+ hugsPath = strCopy(HUGSPATH); readOptions("-p\"%s> \" -r$$");
#if USE_REGISTRY
- readOptions(readRegString("Options",""));
-#endif
+ projectPath = strCopy(readRegChildStrings(HKEY_LOCAL_MACHINE,ProjectRoot,
+ "HUGSPATH", PATHSEP, ""));
+ readOptions(readRegString(HKEY_LOCAL_MACHINE,HugsRoot,"Options",""));
+ readOptions(readRegString(HKEY_CURRENT_USER, HugsRoot,"Options",""));
+#endif /* USE_REGISTRY */
readOptions(fromEnv("HUGSFLAGS",""));
for (i=1; i<argc; ++i) { /* process command line arguments */
} else {
proj = argv[++i];
}
- } else if (!processOption(argv[i])) {
+ } else if (argv[i] && argv[i][0]/* workaround for /bin/sh silliness*/
+ && !processOption(argv[i])) {
addScriptName(argv[i],TRUE);
}
}
DEBUG_LoadSymbols(argv[0]);
#endif
- scriptName[0] = strCopy(findMPathname(NULL,STD_PRELUDE));
+ scriptName[0] = strCopy(findMPathname(NULL,STD_PRELUDE,hugsPath));
if (!scriptName[0]) {
Printf("Prelude not found on current path: \"%s\"\n",
hugsPath ? hugsPath : "");
fatal("Unable to load prelude");
}
+ if (haskell98) {
+ Printf("Haskell 98 mode: Restart with command line option -98 to enable extensions\n\n");
+ } else {
+ Printf("Hugs mode: Restart with command line option +98 for Haskell 98 mode\n\n");
+ }
+
everybody(INSTALL);
evalModule = findText(""); /* evaluate wrt last module by default */
if (proj) {
Printf(fmts,"rstr","Set repeat last expression string to str");
Printf(fmts,"Pstr","Set search path for modules to str");
Printf(fmts,"Estr","Use editor setting given by str");
+ Printf(fmts,"cnum","Set constraint cutoff limit");
#if USE_PREPROCESSOR && (defined(HAVE_POPEN) || defined(HAVE__POPEN))
Printf(fmts,"Fstr","Set preprocessor filter to str");
#endif
+#if PROFILING
+ Printf(fmts,"dnum","Gather profiling statistics every <num> reductions\n");
+#endif
Printf("\nCurrent settings: ");
togglesIn(TRUE);
printString(prompt);
Printf(" -r");
printString(repeatStr);
+ Printf(" -c%d",cutoff);
Printf("\nSearch path : -P");
printString(hugsPath);
+#if 0
+ToDo
+ if (projectPath!=NULL) {
+ Printf("\nProject Path : %s",projectPath);
+ }
+#endif
Printf("\nEditor setting : -E");
printString(hugsEdit);
#if USE_PREPROCESSOR && (defined(HAVE_POPEN) || defined(HAVE__POPEN))
Printf("\nPreprocessor : -F");
printString(preprocessor);
#endif
+#if PROFILING
+ Printf("\nProfile interval: -d%d", profiling ? profInterval : 0);
+#endif
+ Printf("\nCompatibility : %s", haskell98 ? "Haskell 98"
+ : "Hugs Extensions");
Putchar('\n');
}
PUTStr('r',repeatStr);
PUTStr('P',hugsPath);
PUTStr('E',hugsEdit);
+ PUTInt('c',cutoff); PUTC(' ');
#if USE_PREPROCESSOR && (defined(HAVE_POPEN) || defined(HAVE__POPEN))
PUTStr('F',preprocessor);
#endif
+#if PROFILING
+ PUTInt('d',profiling ? profInterval : 0);
+#endif
PUTC('\0');
return buffer;
}
return TRUE;
}
- default : toggleSet(*s,state);
+ default : if (strcmp("98",s)==0) {
+ if (heapBuilt() && ((state && !haskell98) ||
+ (!state && haskell98))) {
+ FPrintf(stderr,"Haskell 98 compatibility cannot be changed while the interpreter is running\n");
+ } else {
+ haskell98 = state;
+ }
+ return TRUE;
+ } else {
+ toggleSet(*s,state);
+ }
break;
}
return TRUE;
{":reload", RELOAD}, {":gc", COLLECT}, {":edit", EDIT},
{":quit", QUIT}, {":set", SET}, {":find", FIND},
{":names", NAMES}, {":info", INFO}, {":project", PROJECT},
- {":module", SETMODULE},
- {":version", SHOWVERSION},
+#if !IGNORE_MODULES
+ {":module",SETMODULE},
+#endif
{"", EVAL},
{0,0}
};
Printf(":project <filename> use project file\n");
Printf(":edit <filename> edit file\n");
Printf(":edit edit last module\n");
+#if !IGNORE_MODULES
Printf(":module <module> set module for evaluating expressions\n");
+#endif
Printf("<expr> evaluate expression\n");
Printf(":type <expr> print type of expression\n");
- Printf(":version show Hugs version\n");
Printf(":? display this list of commands\n");
Printf(":set <options> set command line options\n");
Printf(":set help on command line options\n");
* Setting of command line options:
* ------------------------------------------------------------------------*/
-struct options toggle[] = { /* List of command line toggles */
- {'t', "Print type after evaluation", &addType},
+struct options toggle[] = { /* List of command line toggles */
+ {'s', "Print no. reductions/cells after eval", &showStats},
+ {'t', "Print type after evaluation", &addType},
+ /*ToDo?? {'f', "Terminate evaluation on first error", &failOnError},*/
{'g', "Print no. cells recovered after gc", &gcMessages},
{'l', "Literate modules as default", &literateScripts},
{'e', "Warn about errors in literate modules", &literateErrors},
Printf("Reading file \"%s\":\n",fname);
setLastEdit(fname,0);
+#if 0
+ToDo: reinstate
if (isInterfaceFile(fname)) {
loadInterface(fname);
- } else {
+ } else
+#else
+ {
needsImports = FALSE;
parseScript(fname,len); /* process script file */
if (needsImports)
typeCheckDefns();
compileDefns();
}
+#endif
scriptFile = 0;
return TRUE;
}
* Read and evaluate an expression:
* ------------------------------------------------------------------------*/
+#if !IGNORE_MODULES
static Void local setModule(){/*set module in which to evaluate expressions*/
String s = readFilename();
if (!s) s = ""; /* :m clears the current module selection */
static Module local findEvalModule() { /*Module in which to eval expressions*/
Module m = findModule(evalModule);
- if (isNull(m)) {
+ if (isNull(m))
m = lastModule();
- }
return m;
}
+#endif
static Void local evaluator() { /* evaluate expr and print value */
Type type, bd;
- Kinds ks = NIL;
+ Kinds ks = NIL;
+ Cell temp = NIL;
setCurrModule(findEvalModule());
scriptFile = 0;
if (whatIs(bd)==QUAL) {
ERRMSG(0) "Unresolved overloading" ETHEN
- ERRTEXT "\n*** type : " ETHEN ERRTYPE(type);
- ERRTEXT "\n*** expression : " ETHEN ERREXPR(inputExpr);
+ ERRTEXT "\n*** Type : " ETHEN ERRTYPE(type);
+ ERRTEXT "\n*** Expression : " ETHEN ERREXPR(inputExpr);
ERRTEXT "\n"
EEND;
}
-
- /* ToDo: restore the code to print types, use show, etc */
+
+#if PROFILING
+ if (profiling)
+ profilerLog("profile.hp");
+ numReductions = 0;
+ garbageCollect();
+#endif
#ifdef WANT_TIMER
updateTimers();
}
}
+static Void local stopAnyPrinting() { /* terminate printing of expression,*/
+ if (printing) { /* after successful termination or */
+ printing = FALSE; /* runtime error (e.g. interrupt) */
+ Putchar('\n');
+ if (showStats) {
+#define plural(v) v, (v==1?"":"s")
+ /* Printf("(%lu reduction%s, ",plural(numReductions)); */
+ Printf("%lu cell%s",plural(numCells));
+ if (numGcs>0)
+ Printf(", %u garbage collection%s",plural(numGcs));
+ Printf(")\n");
+#undef plural
+ }
+ FlushStdout();
+ garbageCollect();
+ }
+}
+
/* --------------------------------------------------------------------------
* Print type of input expression:
* ------------------------------------------------------------------------*/
* about an object.
* ------------------------------------------------------------------------*/
-static String local objToStr Args((Module, Cell));
-
static String local objToStr(m,c)
Module m;
Cell c; {
-#if DISPLAY_QUANTIFIERS
+#if 1 || DISPLAY_QUANTIFIERS
static char newVar[60];
switch (whatIs(c)) {
- case NAME : if (m == name(c).mod) {
- sprintf(newVar,"%s", textToStr(name(c).text));
- } else {
- sprintf(newVar,"%s.%s",textToStr(module(name(c).mod).text),
- textToStr(name(c).text));
- }
- break;
- case TYCON : if (m == tycon(c).mod) {
- sprintf(newVar,"%s", textToStr(tycon(c).text));
- } else {
- sprintf(newVar,"%s.%s",textToStr(module(tycon(c).mod).text),
- textToStr(tycon(c).text));
- }
- break;
- case CLASS : if (m == cclass(c).mod) {
- sprintf(newVar,"%s", textToStr(cclass(c).text));
- } else {
- sprintf(newVar,"%s.%s",textToStr(module(cclass(c).mod).text),
- textToStr(cclass(c).text));
- }
- break;
- default : internal("objToStr");
+ case NAME : if (m == name(c).mod) {
+ sprintf(newVar,"%s", textToStr(name(c).text));
+ } else {
+ sprintf(newVar,"%s.%s",
+ textToStr(module(name(c).mod).text),
+ textToStr(name(c).text));
+ }
+ break;
+
+ case TYCON : if (m == tycon(c).mod) {
+ sprintf(newVar,"%s", textToStr(tycon(c).text));
+ } else {
+ sprintf(newVar,"%s.%s",
+ textToStr(module(tycon(c).mod).text),
+ textToStr(tycon(c).text));
+ }
+ break;
+
+ case CLASS : if (m == cclass(c).mod) {
+ sprintf(newVar,"%s", textToStr(cclass(c).text));
+ } else {
+ sprintf(newVar,"%s.%s",
+ textToStr(module(cclass(c).mod).text),
+ textToStr(cclass(c).text));
+ }
+ break;
+
+ default : internal("objToStr");
}
return newVar;
#else
static char newVar[33];
switch (whatIs(c)) {
- case NAME : sprintf(newVar,"%s", textToStr(name(c).text));
- break;
- case TYCON : sprintf(newVar,"%s", textToStr(tycon(c).text));
- break;
- case CLASS : sprintf(newVar,"%s", textToStr(cclass(c).text));
- default : internal("objToStr");
+ case NAME : sprintf(newVar,"%s", textToStr(name(c).text));
+ break;
+
+ case TYCON : sprintf(newVar,"%s", textToStr(tycon(c).text));
+ break;
+
+ case CLASS : sprintf(newVar,"%s", textToStr(cclass(c).text));
+ break;
+
+ default : internal("objToStr");
}
return newVar;
#endif
static Void local describe(t) /* describe an object */
Text t; {
- Tycon tc = findTycon(t);
- Class cl = findClass(t);
- Name nm = findName(t);
+ Tycon tc = findTycon(t);
+ Class cl = findClass(t);
+ Name nm = findName(t);
Module mod = findEvalModule();
if (nonNull(tc)) { /* as a type constructor */
- Type ty = tc;
+ Type t = tc;
Int i;
Inst in;
for (i=0; i<tycon(tc).arity; ++i) {
- ty = ap(ty,mkOffset(i));
+ t = ap(t,mkOffset(i));
}
Printf("-- type constructor");
if (kindExpert) {
Putchar('\n');
switch (tycon(tc).what) {
case SYNONYM : Printf("type ");
- printType(stdout,ty);
+ printType(stdout,t);
Printf(" = ");
printType(stdout,tycon(tc).defn);
break;
} else {
Printf("newtype ");
}
- printType(stdout,ty);
+ printType(stdout,t);
+ Putchar('\n');
+ mapProc(printSyntax,cs);
if (hasCfun(cs)) {
- Printf("\n\n-- constructors:");
+ Printf("\n-- constructors:");
}
for (; hasCfun(cs); cs=tl(cs)) {
Putchar('\n');
printType(stdout,name(hd(cs)).type);
}
if (nonNull(cs)) {
- Printf("\n\n-- selectors:");
+ Printf("\n-- selectors:");
}
for (; nonNull(cs); cs=tl(cs)) {
Putchar('\n');
break;
case RESTRICTSYN : Printf("type ");
- printType(stdout,ty);
+ printType(stdout,t);
Printf(" = <restricted>");
break;
}
List ins = cclass(cl).instances;
Kinds ks = cclass(cl).kinds;
if (nonNull(ks) && isNull(tl(ks)) && hd(ks)==STAR) {
- printf("-- type class");
+ Printf("-- type class");
} else {
- printf("-- constructor class");
+ Printf("-- constructor class");
if (kindExpert) {
- printf(" with arity ");
+ Printf(" with arity ");
printKinds(stdout,ks);
}
}
- printf("\nclass ");
+ Putchar('\n');
+ mapProc(printSyntax,cclass(cl).members);
+ Printf("class ");
if (nonNull(cclass(cl).supers)) {
printContext(stdout,cclass(cl).supers);
- printf(" => ");
+ Printf(" => ");
}
printPred(stdout,cclass(cl).head);
if (nonNull(cclass(cl).members)) {
List ms = cclass(cl).members;
- printf(" where");
+ Printf(" where");
do {
Type t = monotypeOf(name(hd(ms)).type);
- printf("\n ");
+ Printf("\n ");
printExp(stdout,hd(ms));
- printf(" :: ");
+ Printf(" :: ");
if (isNull(tl(fst(snd(t))))) {
t = snd(snd(t));
} else {
ms = tl(ms);
} while (nonNull(ms));
}
- putchar('\n');
+ Putchar('\n');
if (nonNull(ins)) {
- printf("\n-- instances:\n");
+ Printf("\n-- instances:\n");
do {
showInst(hd(ins));
ins = tl(ins);
} while (nonNull(ins));
}
- putchar('\n');
+ Putchar('\n');
}
if (nonNull(nm)) { /* as a function/name */
+ printSyntax(nm);
printExp(stdout,nm);
- printf(" :: ");
+ Printf(" :: ");
if (nonNull(name(nm).type)) {
printType(stdout,name(nm).type);
} else {
- printf("<unknown type>");
+ Printf("<unknown type>");
}
if (isCfun(nm)) {
- printf(" -- data constructor");
+ Printf(" -- data constructor");
} else if (isMfun(nm)) {
- printf(" -- class member");
+ Printf(" -- class member");
} else if (isSfun(nm)) {
- printf(" -- selector function");
+ Printf(" -- selector function");
}
- if (name(nm).primop) {
- printf(" -- primitive");
+#if 0
+ ToDo: reinstate
+ if (name(nm).primDef) {
+ Printf(" -- primitive");
}
- printf("\n\n");
+#endif
+ Printf("\n\n");
}
if (isNull(tc) && isNull(cl) && isNull(nm)) {
}
}
+static Void local printSyntax(nm)
+Name nm; {
+ Syntax sy = syntaxOf(nm);
+ Text t = name(nm).text;
+ String s = textToStr(t);
+ if (sy != defaultSyntax(t)) {
+ Printf("infix");
+ switch (assocOf(sy)) {
+ case LEFT_ASS : Putchar('l'); break;
+ case RIGHT_ASS : Putchar('r'); break;
+ case NON_ASS : break;
+ }
+ Printf(" %i ",precOf(sy));
+ if (isascii(*s) && isalpha(*s)) {
+ Printf("`%s`",s);
+ } else {
+ Printf("%s",s);
+ }
+ Putchar('\n');
+ }
+}
+
static Void local showInst(in) /* Display instance decl header */
Inst in; {
- printf("instance ");
+ Printf("instance ");
if (nonNull(inst(in).specifics)) {
printContext(stdout,inst(in).specifics);
- printf(" => ");
+ Printf(" => ");
}
printPred(stdout,inst(in).head);
- putchar('\n');
+ Putchar('\n');
}
/* --------------------------------------------------------------------------
break;
case PROJECT: project();
break;
+#if !IGNORE_MODULES
case SETMODULE :
setModule();
break;
- case SHOWVERSION :
- Printf("Hugs 1.4, %s release.\n", HUGS_VERSION);
- break;
+#endif
case EVAL : evaluator();
break;
case TYPEOF : showtype();
break;
case SET : set();
break;
- case SYSTEM : if (shellEsc(readLine()))
+ case SYSTEM : if (shellEsc(readLine()))
Printf("Warning: Shell escape terminated abnormally\n");
break;
case CHGDIR : changeDir();
millisecs(userElapsed), millisecs(systElapsed));
#endif
}
+ breakOn(FALSE);
}
/* --------------------------------------------------------------------------
Void errHead(l) /* print start of error message */
Int l; {
failed(); /* failed to reach target ... */
+ stopAnyPrinting();
FPrintf(errorStream,"ERROR");
if (scriptFile) {
Void errAbort() { /* altern. form of error handling */
failed(); /* used when suitable error message*/
- errFail(); /* has already been printed */
+ stopAnyPrinting(); /* has already been printed */
+ errFail();
}
Void internal(msg) /* handle internal error */
MessageBox(hWndMain, buf, appName, MB_ICONHAND | MB_OK);
#endif
failed();
+ stopAnyPrinting();
Printf("INTERNAL ERROR: %s\n",msg);
FlushStdout();
longjmp(catch_error,1);
Hilite();
Printf("{Interrupted!}\n");
Lolite();
- breakOn(TRUE);
+ breakOn(TRUE); /* reinstall signal handler - redundant on BSD systems */
+ /* but essential on POSIX (and other?) systems */
everybody(BREAK);
failed();
+ stopAnyPrinting();
FlushStdout();
clearerr(stdin);
longjmp(catch_error,1);
}
#endif /* REDIRECT_OUTPUT && !HUGS_FOR_WINDOWS */
+/* --------------------------------------------------------------------------
+ * Send message to each component of system:
+ * ------------------------------------------------------------------------*/
+
+Void everybody(what) /* send command `what' to each component of*/
+Int what; { /* system to respond as appropriate ... */
+ machdep(what); /* The order of calling each component is */
+ storage(what); /* important for the INSTALL command */
+ substitution(what);
+ input(what);
+ linkControl(what);
+ staticAnalysis(what);
+ deriveControl(what);
+ typeChecker(what);
+ translateControl(what);
+ compiler(what);
+ codegen(what);
+}
+
/* --------------------------------------------------------------------------
* Hugs for Windows code (WinMain and related functions)
-/* -*- mode: hugs-c; -*- */
+
/* --------------------------------------------------------------------------
* Input functions, lexical analysis parsing etc...
*
- * 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
+ * Hugs 98 is Copyright (c) Mark P Jones, Alastair Reid and the Yale
+ * Haskell Group 1994-99, and is distributed as Open Source software
+ * under the Artistic License; see the file "Artistic" that is included
+ * in the distribution for details.
*
* $RCSfile: input.c,v $
- * $Revision: 1.2 $
- * $Date: 1998/12/02 13:22:12 $
+ * $Revision: 1.3 $
+ * $Date: 1999/02/03 17:08:30 $
* ------------------------------------------------------------------------*/
#include "prelude.h"
#include "storage.h"
+#include "backend.h"
#include "connect.h"
-#include "charset.h"
-#include "input.h"
-#include "static.h"
-#include "interface.h"
#include "command.h"
#include "errors.h"
-#include "link.h"
-#include "hugs.h" /* for target */
#include <ctype.h>
#if HAVE_GETDELIM_H
#include "getdelim.h"
#endif
-#include "machdep.h" /* for findPathname */
-
#if HUGS_FOR_WINDOWS
#undef IN
#endif
List tyconDefns = NIL; /* type constructor definitions */
List typeInDefns = NIL; /* type synonym restrictions */
List valDefns = NIL; /* value definitions in script */
-List opDefns = NIL; /* operator defns in script */
List classDefns = NIL; /* class defns in script */
List instDefns = NIL; /* instance defns in script */
List selDefns = NIL; /* list of selector lists */
* Local function prototypes:
* ------------------------------------------------------------------------*/
+static Void local initCharTab Args((Void));
static Void local fileInput Args((String,Long));
static Bool local literateMode Args((String));
static Bool local linecmp Args((String,String));
static Text textBang, textDot, textAll, textImplies;
static Text textWildcard;
-static Text textModule, textImport, textPrelude, textPreludeHugs;
+static Text textModule, textImport;
static Text textHiding, textQualified, textAsMod;
static Text textExport, textInterface, textRequires, textUnsafe;
-#if NPLUSK
+Text textNum; /* Num */
+Text textPrelude; /* Prelude */
Text textPlus; /* (+) */
-#endif
-Cell conPrelude; /* Prelude */
static Cell conMain; /* Main */
static Cell varMain; /* main */
-static Cell conUnit; /* () */
-static Cell conList; /* [] */
-static Cell conNil; /* [] */
-static Cell conPreludeUnit; /* Prelude.() */
-static Cell conPreludeList; /* Prelude.[] */
-static Cell conPreludeNil; /* Prelude.[] */
-
static Cell varMinus; /* (-) */
+static Cell varPlus; /* (+) */
static Cell varBang; /* (!) */
static Cell varDot; /* (.) */
static Cell varHiding; /* hiding */
static Cell varQualified; /* qualified */
static Cell varAsMod; /* as */
-static Cell varNegate;
-static Cell varFlip;
-static Cell varEnumFrom;
-static Cell varEnumFromThen;
-static Cell varEnumFromTo;
-static Cell varEnumFromThenTo;
-
static List imps; /* List of imports to be chased */
+
+/* --------------------------------------------------------------------------
+ * Character set handling:
+ *
+ * Hugs follows Haskell 1.3 in assuming that input uses the ISO-8859-1
+ * character set. The following code provides methods for classifying
+ * input characters according to the lexical structure specified by the
+ * report. Hugs should still accept older programs because ASCII is
+ * essentially just a subset of the ISO character set.
+ *
+ * Notes: If you want to port Hugs to a machine that uses something
+ * substantially different from the ISO character set, then you will need
+ * to insert additional code to map between character sets.
+ *
+ * At some point, the following data structures may be exported in a .h
+ * file to allow the information contained here to be picked up in the
+ * implementation of LibChar is* primitives.
+ *
+ * Relies, implicitly but for this comment, on assumption that NUM_CHARS=256.
+ * ------------------------------------------------------------------------*/
+
+static Bool charTabBuilt;
+static unsigned char ctable[NUM_CHARS];
+#define isIn(c,x) (ctable[(unsigned char)(c)]&(x))
+#define isISO(c) (0<=(c) && (c)<NUM_CHARS)
+
+#define DIGIT 0x01
+#define SMALL 0x02
+#define LARGE 0x04
+#define SYMBOL 0x08
+#define IDAFTER 0x10
+#define SPACE 0x20
+#define PRINT 0x40
+
+static Void local initCharTab() { /* Initialize char decode table */
+#define setRange(x,f,t) {Int i=f; while (i<=t) ctable[i++] |=x;}
+#define setChar(x,c) ctable[c] |= (x)
+#define setChars(x,s) {char *p=s; while (*p) ctable[(Int)*p++]|=x;}
+#define setCopy(x,c) {Int i; \
+ for (i=0; i<NUM_CHARS; ++i) \
+ if (isIn(i,c)) \
+ ctable[i]|=x; \
+ }
+
+ setRange(DIGIT, '0','9'); /* ASCII decimal digits */
+
+ setRange(SMALL, 'a','z'); /* ASCII lower case letters */
+ setRange(SMALL, 223,246); /* ISO lower case letters */
+ setRange(SMALL, 248,255); /* (omits division symbol, 247) */
+ setChar (SMALL, '_');
+
+ setRange(LARGE, 'A','Z'); /* ASCII upper case letters */
+ setRange(LARGE, 192,214); /* ISO upper case letters */
+ setRange(LARGE, 216,222); /* (omits multiplication, 215) */
+
+ setRange(SYMBOL, 161,191); /* Symbol characters + ':' */
+ setRange(SYMBOL, 215,215);
+ setChar (SYMBOL, 247);
+ setChars(SYMBOL, ":!#$%&*+./<=>?@\\^|-~");
+
+ setChar (IDAFTER, '\''); /* Characters in identifier */
+ setCopy (IDAFTER, (DIGIT|SMALL|LARGE));
+
+ setChar (SPACE, ' '); /* ASCII space character */
+ setChar (SPACE, 160); /* ISO non breaking space */
+ setRange(SPACE, 9,13); /* special whitespace: \t\n\v\f\r */
+
+ setChars(PRINT, "(),;[]_`{}"); /* Special characters */
+ setChars(PRINT, " '\""); /* Space and quotes */
+ setCopy (PRINT, (DIGIT|SMALL|LARGE|SYMBOL));
+
+ charTabBuilt = TRUE;
+#undef setRange
+#undef setChar
+#undef setChars
+#undef setCopy
+}
+
+
/* --------------------------------------------------------------------------
* Single character input routines:
*
#if USE_READLINE /* for command line editors */
static String currentLine; /* editline or GNU readline */
static String nextChar;
-#define nextConsoleChar() (unsigned char)(*nextChar=='\0' ? '\n' : *nextChar++)
-extern Void add_history Args((String));
-extern String readline Args((String));
+#define nextConsoleChar() (unsigned char)(*nextChar=='\0' ? '\n' : *nextChar++)
+extern Void add_history Args((String));
+extern String readline Args((String));
#else
-#define nextConsoleChar() getc(stdin)
+#define nextConsoleChar() getc(stdin)
#endif
static Int litLines; /* count defn lines in lit script */
Long len; { /* used to set target for reading) */
#if USE_PREPROCESSOR && (defined(HAVE_POPEN) || defined(HAVE__POPEN))
if (preprocessor) {
- char cmd[100];
- strncpy(cmd,preprocessor,100);
- strncat(cmd," ",100);
- strncat(cmd,nm,100);
- cmd[99] = '\0'; /* paranoia */
+ Int reallen = strlen(preprocessor) + 1 + strlen(nm) + 1;
+ char *cmd = malloc(reallen);
+ if (cmd == NULL) {
+ ERRMSG(0) "Unable to allocate memory for filter command."
+ EEND;
+ }
+ strcpy(cmd,preprocessor);
+ strcat(cmd," ");
+ strcat(cmd,nm);
inputStream = popen(cmd,"r");
+ free(cmd);
} else {
inputStream = fopen(nm,"r");
}
row = 1;
nextStringChar = s;
+ if (!charTabBuilt)
+ initCharTab();
}
-static Bool local literateMode(nm) /* select literate mode for file */
+static Bool local literateMode(nm) /* Select literate mode for file */
String nm; {
char *dot = strrchr(nm,'.'); /* look for last dot in file name */
if (dot) {
return literateScripts; /* otherwise, use the default */
}
-Bool isInterfaceFile(nm) /* is nm an interface file? */
-String nm; {
- char *dot = strrchr(nm,'.'); /* look for last dot in file name */
- return (dot && filenamecmp(dot+1,"myhi")==0);
-}
-
/* This code originally came from Sigbjorn Finne (sof@dcs.gla.ac.uk).
* I've removed the loop (since newLineSkip contains a loop too) and
litLines++;
return;
}
- while (c0==' ' || c0=='\t')/* maybe line is blank? */
+ while (c0 != '\n' && isIn(c0,SPACE)) /* maybe line is blank? */
skip();
if (c0=='\n' || c0==EOF)
thisLineIs(BLANKLINE);
* entry to the routine.
* ------------------------------------------------------------------------*/
-#define MAX_TOKEN 500
+#define MAX_TOKEN 4000
#define startToken() tokPos = 0
#define saveTokenChar(c) if (tokPos<=MAX_TOKEN) saveChar(c); else ++tokPos
#define saveChar(c) tokenStr[tokPos++]=(char)(c)
static Cell local readRadixNumber(r) /* Read literal in specified radix */
Int r; { /* from input of the form 0c{digs} */
Int d;
- startToken();
- saveTokenChar(c0);
skip(); /* skip leading zero */
- if ((d=readHexDigit(c1))<0 || d>=r) {
- /* Special case; no digits, lex as */
- /* if it had been written "0 c..." */
- saveTokenChar('0');
- } else {
+ if ((d=readHexDigit(c1))<0 || d>=r)/* Special case; no digits, lex as */
+ return mkInt(0); /* if it had been written "0 c..." */
+ else {
Int n = 0;
- saveTokenChar(c0);
+#if BIGNUMS
+ Cell big = NIL;
+#endif
skip();
do {
- saveTokenChar(c0);
+#if BIGNUMS
+ if (nonNull(big))
+ big = bigShift(big,d,r);
+ else if (overflows(n,r,d,MAXPOSINT))
+ big = bigShift(bigInt(n),d,r);
+ else
+#else
+ if (overflows(n,r,d,MAXPOSINT)) {
+ ERRMSG(row) "Integer literal out of range"
+ EEND;
+ }
+ else
+#endif
+ n = r*n + d;
skip();
d = readHexDigit(c0);
} while (d>=0 && d<r);
+#if BIGNUMS
+ return nonNull(big) ? big : mkInt(n);
+#else
+ return mkInt(n);
+#endif
}
- endToken();
- /* ToDo: return an INTCELL if small enough */
- return stringToBignum(tokenStr);
}
static Cell local readNumber() { /* read numeric constant */
+ Int n = 0;
Bool intTooLarge = FALSE;
if (c0=='0') {
startToken();
do {
+ if (overflows(n,10,(c0-'0'),MAXPOSINT))
+ intTooLarge = TRUE;
+ n = 10*n + (c0-'0');
saveTokenChar(c0);
skip();
} while (isISO(c0) && isIn(c0,DIGIT));
if (c0!='.' || !isISO(c1) || !isIn(c1,DIGIT)) {
endToken();
- /* ToDo: return an INTCELL if small enough */
- return stringToBignum(tokenStr);
+ if (!intTooLarge)
+ return mkInt(n);
+#if BIGNUMS
+ return bigStr(tokenStr);
+#else
+ ERRMSG(row) "Integer literal out of range"
+ EEND;
+#endif
}
saveTokenChar(c0); /* save decimal point */
}
endToken();
- return stringToFloat(tokenStr);
+#ifndef HAVE_LIBM
+ ERRMSG(row) "No floating point numbers in this implementation"
+ EEND;
+#endif
+
+ return mkFloat(stringToFloat(tokenStr));
}
static Cell local readChar() { /* read character constant */
if (s) {
String t = s;
Char c;
- while ((c = *t)!=0 && isISO(c) && isIn(c,PRINT) && c!='"' && !isIn(c,SPACE)) {
+ while ((c = *t)!=0 && isISO(c)
+ && isIn(c,PRINT) && c!='"' && !isIn(c,SPACE)) {
t++;
}
if (*t) {
}
/* -------------------------------------------------------------------------
- * Handle special types of input for us in interpreter:
+ * Handle special types of input for use in interpreter:
* -----------------------------------------------------------------------*/
Command readCommand(cmds,start,sys) /* read command at start of input */
skip();
while (c0!=EOF && c0!='\"') {
Cell c = readAChar(TRUE);
- if (nonNull(c))
+ if (nonNull(c)) {
saveTokenChar(charOf(c));
+ }
}
if (c0=='"')
skip();
push(yylval = mkInt(row)); /* default token value is line no. */
/* subsequent changes to yylval must also set top() to the same value */
- if (indentDepth>=0) /* layout rule(s) active ? */
+ if (indentDepth>=0) { /* layout rule(s) active ? */
if (insertedToken) /* avoid inserting multiple `;'s */
insertedToken = FALSE; /* or putting `;' after `{' */
- else if (layout[indentDepth]!=HARD)
+ else
+ if (layout[indentDepth]!=HARD) {
if (column<layout[indentDepth]) {
unOffside();
return '}';
insertedToken = TRUE;
return ';';
}
+ }
+ }
/* ----------------------------------------------------------------------
* Now try to identify token type:
}
#if TREX
- if (c0=='#' && isIn(c1,SMALL)) { /* Look for record selector name */
- Text it;
+ if (c0=='#' && isIn(c1,SMALL) && !haskell98) {
+ Text it; /* Look for record selector name */
skip();
it = readIdent();
top() = yylval = ap(RECSEL,mkExt(it));
} else {
top() = yylval = mkCon(it);
return identType;
- } /* We could easily keep a record of*/
- } /* the qualifying name here ... */
- if (isIn(c0,(SMALL|LARGE)) || c0 == '_') {
+ }
+ }
+ if (isIn(c0,(SMALL|LARGE))) {
Text it = readIdent();
if (it==textCase) return CASEXP;
if (it==textWhere) lookAhead(WHERE);
if (it==textLet) lookAhead(LET);
if (it==textIn) return IN;
- if (it==textInfix) return INFIX;
+ if (it==textInfix) return INFIXN;
if (it==textInfixl) return INFIXL;
if (it==textInfixr) return INFIXR;
if (it==textForeign) return FOREIGN;
if (it==textDo) lookAhead(DO);
if (it==textClass) return TCLASS;
if (it==textInstance) return TINSTANCE;
- if (it==textModule) return MODULETOK;
- if (it==textInterface) return INTERFACE;
- if (it==textRequires) return REQUIRES;
+ if (it==textModule) return TMODULE;
if (it==textImport) return IMPORT;
if (it==textExport) return EXPORT;
if (it==textHiding) return HIDING;
if (it==textQualified) return QUALIFIED;
if (it==textAsMod) return ASMOD;
if (it==textWildcard) return '_';
- if (it==textAll) return ALL;
+ if (it==textAll && !haskell98) return ALL;
if (it==textRepeat && reading==KEYBOARD)
return repeatLast();
if (it==textBar) return '|';
if (it==textFrom) return FROM;
if (it==textMinus) return '-';
+ if (it==textPlus) return '+';
if (it==textBang) return '!';
if (it==textDot) return '.';
if (it==textArrow) return ARROW;
return REPEAT;
}
+Syntax defaultSyntax(t) /* Find default syntax of var named*/
+Text t; { /* by t ... */
+ String s = textToStr(t);
+ return isIn(s[0],SYMBOL) ? DEF_OPSYNTAX : APPLIC;
+}
+
+Syntax syntaxOf(n) /* Find syntax for name */
+Name n; {
+ if (name(n).syntax==NO_SYNTAX) /* Return default if no syntax set */
+ return defaultSyntax(name(n).text);
+ return name(n).syntax;
+}
+
/* --------------------------------------------------------------------------
* main entry points to parser/lexer:
* ------------------------------------------------------------------------*/
EEND; /* in the parser... */
}
drop();
- assert(stackEmpty()); /* stack should now be empty */
+ if (!stackEmpty()) /* stack should now be empty */
+ internal("parseInput");
}
-Void parseScript(nm,len) /* Read a script */
-String nm;
-Long len; { /* Used to set a target for reading */
+#ifdef HSCRIPT
+static String memPrefix = "@mem@";
+static Int lenMemPrefix = 5; /* strlen(memPrefix)*/
+
+Void makeMemScript(mem,fname)
+String mem;
+String fname; {
+ strcat(fname,memPrefix);
+ itoa((int)mem, fname+strlen(fname), 10);
+}
+
+Bool isMemScript(fname)
+String fname; {
+ return (strstr(fname,memPrefix) != NULL);
+}
+
+String memScriptString(fname)
+String fname; {
+ String p = strstr(fname,memPrefix);
+ if (p) {
+ return (String)atoi(p+lenMemPrefix);
+ } else {
+ return NULL;
+ }
+}
+
+Void parseScript(fname,len) /* Read a script, possibly from mem */
+String fname;
+Long len; {
input(RESET);
- fileInput(nm,len);
+ if (isMemScript(fname)) {
+ char* s = memScriptString(fname);
+ stringInput(s);
+ } else {
+ fileInput(fname,len);
+ }
parseInput(SCRIPT);
}
-
-Void parseInterface(nm,len) /* Read a GHC interface file */
+#else
+Void parseScript(nm,len) /* Read a script */
String nm;
Long len; { /* Used to set a target for reading */
input(RESET);
fileInput(nm,len);
- parseInput(INTERFACE);
+ parseInput(SCRIPT);
}
+#endif
Void parseExp() { /* Read an expression to evaluate */
parseInput(EXPR);
textLambda = findText("\\");
textBar = findText("|");
textMinus = findText("-");
+ textPlus = findText("+");
textFrom = findText("<-");
textArrow = findText("->");
textLazy = findText("~");
textBang = findText("!");
textDot = findText(".");
textImplies = findText("=>");
-#if NPLUSK
- textPlus = findText("+");
-#endif
+ textPrelude = findText("Prelude");
+ textNum = findText("Num");
textModule = findText("module");
- textInterface = findText("__interface");
- textRequires = findText("__requires");
textImport = findText("import");
- textExport = findText("__export");
textHiding = findText("hiding");
textQualified = findText("qualified");
textAsMod = findText("as");
textWildcard = findText("_");
textAll = findText("forall");
varMinus = mkVar(textMinus);
+ varPlus = mkVar(textPlus);
varBang = mkVar(textBang);
varDot = mkVar(textDot);
varHiding = mkVar(textHiding);
varAsMod = mkVar(textAsMod);
conMain = mkCon(findText("Main"));
varMain = mkVar(findText("main"));
- textPrelude = findText("Prelude");
- textPreludeHugs= findText("PreludeBuiltin");
- conPrelude = mkCon(textPrelude);
- conNil = mkCon(findText("[]"));
- conList = mkCon(findText("[]"));
- conUnit = mkCon(findText("()"));
- conPreludeNil = mkQCon(textPreludeHugs,findText("[]"));
- conPreludeList = mkQCon(textPreludeHugs,findText("[]"));
- conPreludeUnit = mkQCon(textPreludeHugs,findText("()"));
- varNegate = mkQVar(textPreludeHugs,findText("negate"));
- varFlip = mkQVar(textPreludeHugs,findText("flip"));
- varEnumFrom = mkQVar(textPreludeHugs,findText("enumFrom"));
- varEnumFromThen = mkQVar(textPreludeHugs,findText("enumFromThen"));
- varEnumFromTo = mkQVar(textPreludeHugs,findText("enumFromTo"));
- varEnumFromThenTo = mkQVar(textPreludeHugs,findText("enumFromThenTo"));
-
evalDefaults = NIL;
input(RESET);
case RESET : tyconDefns = NIL;
typeInDefns = NIL;
valDefns = NIL;
- opDefns = NIL;
classDefns = NIL;
instDefns = NIL;
selDefns = NIL;
genDefns = NIL;
+ //primDefns = NIL;
unqualImports= NIL;
foreignImports= NIL;
foreignExports= NIL;
case MARK : mark(tyconDefns);
mark(typeInDefns);
mark(valDefns);
- mark(opDefns);
mark(classDefns);
mark(instDefns);
mark(selDefns);
mark(genDefns);
+ //mark(primDefns);
mark(unqualImports);
mark(foreignImports);
mark(foreignExports);
mark(evalDefaults);
mark(inputExpr);
mark(varMinus);
- mark(varNegate);
- mark(varFlip);
- mark(varEnumFrom);
- mark(varEnumFromThen);
- mark(varEnumFromTo);
- mark(varEnumFromThenTo);
+ mark(varPlus);
mark(varBang);
mark(varDot);
mark(varHiding);
mark(varQualified);
mark(varAsMod);
mark(varMain);
- mark(conPrelude);
mark(conMain);
- mark(conNil);
- mark(conList);
- mark(conUnit);
- mark(conPreludeNil);
- mark(conPreludeList);
- mark(conPreludeUnit);
mark(imps);
break;
}
-/* -*- mode: hugs-c; -*- */
+
/* --------------------------------------------------------------------------
* Lambda Lifter
*
* Hugs version 1.4, December 1997
*
* $RCSfile: lift.c,v $
- * $Revision: 1.2 $
- * $Date: 1998/12/02 13:22:17 $
+ * $Revision: 1.3 $
+ * $Date: 1999/02/03 17:08:31 $
* ------------------------------------------------------------------------*/
#include "prelude.h"
#include "storage.h"
+#include "backend.h"
#include "connect.h"
#include "errors.h"
-#include "stg.h"
-#include "lift.h"
-#include "free.h"
-#include "stgSubst.h"
-/* #include "pp.h" */
+
/* --------------------------------------------------------------------------
* Local function prototypes:
* Hugs version 1.4, December 1997
*
* $RCSfile: link.c,v $
- * $Revision: 1.3 $
- * $Date: 1999/01/13 16:47:27 $
+ * $Revision: 1.4 $
+ * $Date: 1999/02/03 17:08:31 $
* ------------------------------------------------------------------------*/
#include "prelude.h"
#include "storage.h"
+#include "backend.h"
#include "connect.h"
-#include "static.h"
-#include "translate.h"
-#include "type.h"
#include "errors.h"
#include "Assembler.h" /* for asmPrimOps and AsmReps */
Class classNum;
Class classMonad; /* Monads and monads with a zero */
-Class classMonad0;
+/*Class classMonad0;*/
List stdDefaults; /* standard default values */
Name nameForce;
+Name nameAnd;
+Name nameHw;
+Name nameConCmp;
+Name nameCompAux;
+Name nameEnFrTh;
+Name nameEnFrTo;
+Name nameEnFrom;
+Name nameEnFrEn;
+Name nameEnToEn;
+Name nameEnInRng;
+Name nameEnIndex;
+Name nameEnRange;
+Name nameRangeSize;
+Name nameComp;
+Name nameShowField;
+Name nameApp;
+Name nameShowParen;
+Name nameReadParen;
+Name nameLex;
+Name nameReadField;
+Name nameFlip;
+Name nameFromTo;
+Name nameFromThen;
+Name nameFrom;
+Name nameFromThenTo;
+Name nameNegate;
+
/* these names are required before we've had a chance to do the right thing */
Name nameSel;
Name nameUnsafeUnpackCString;
*
* ------------------------------------------------------------------------*/
-static Tycon linkTycon( String s );
-static Tycon linkClass( String s );
-static Name linkName ( String s );
+static Tycon linkTycon ( String s );
+static Tycon linkClass ( String s );
+static Name linkName ( String s );
+static Void mkTypes ();
+
static Tycon linkTycon( String s )
{
static Name predefinePrim ( String s );
static Name predefinePrim ( String s )
{
- Name nm = newName(findText(s));
+ Name nm = newName(findText(s),NIL);
name(nm).defn=PREDEFINED;
return nm;
}
classFloating = linkClass("Floating");
classNum = linkClass("Num");
classMonad = linkClass("Monad");
- classMonad0 = linkClass("MonadZero");
+ /*classMonad0 = linkClass("MonadZero");*/
stdDefaults = NIL;
stdDefaults = cons(typeDouble,stdDefaults);
}
}
+static Void mkTypes()
+{
+ arrow = fn(aVar,mkOffset(1));
+ listof = ap(typeList,aVar);
+ predNum = ap(classNum,aVar);
+ predFractional = ap(classFractional,aVar);
+ predIntegral = ap(classIntegral,aVar);
+ predMonad = ap(classMonad,aVar);
+ /*predMonad0 = ap(classMonad0,aVar);*/
+}
+
Void linkPreludeCM() { /* Hook to cfuns and mfuns in */
static Bool initialised = FALSE; /* prelude when first loaded */
if (!initialised) {
Text t = findText(asmPrimOps[i].name);
Name n = findName(t);
if (isNull(n)) {
- n = newName(t);
+ n = newName(t,NIL);
}
name(n).line = 0;
name(n).defn = NIL;
- name(n).type = primType(asmPrimOps[i].monad,asmPrimOps[i].args,asmPrimOps[i].results);
+ name(n).type = primType(asmPrimOps[i].monad,
+ asmPrimOps[i].args,
+ asmPrimOps[i].results);
name(n).arity = strlen(asmPrimOps[i].args);
name(n).primop = &(asmPrimOps[i]);
implementPrim(n);
}
/*-------------------------------------------------------------------------*/
+
+
+#if 0
+--## this stuff from 98
+--##
+--##
+--## Void linkPreludeTC() { /* Hook to tycons and classes in */
+--## if (isNull(typeBool)) { /* prelude when first loaded */
+--## Int i;
+--##
+--## typeBool = findTycon(findText("Bool"));
+--## typeChar = findTycon(findText("Char"));
+--## typeString = findTycon(findText("String"));
+--## typeInt = findTycon(findText("Int"));
+--## typeInteger = findTycon(findText("Integer"));
+--## typeDouble = findTycon(findText("Double"));
+--## typeAddr = findTycon(findText("Addr"));
+--## typeMaybe = findTycon(findText("Maybe"));
+--## typeOrdering = findTycon(findText("Ordering"));
+--## if (isNull(typeBool) || isNull(typeChar) || isNull(typeString) ||
+--## isNull(typeInt) || isNull(typeDouble) || isNull(typeInteger) ||
+--## isNull(typeAddr) || isNull(typeMaybe) || isNull(typeOrdering)) {
+--## ERRMSG(0) "Prelude does not define standard types"
+--## EEND;
+--## }
+--## stdDefaults = cons(typeInteger,cons(typeDouble,NIL));
+--##
+--## classEq = findClass(findText("Eq"));
+--## classOrd = findClass(findText("Ord"));
+--## classIx = findClass(findText("Ix"));
+--## classEnum = findClass(findText("Enum"));
+--## classShow = findClass(findText("Show"));
+--## classRead = findClass(findText("Read"));
+--## #if EVAL_INSTANCES
+--## classEval = findClass(findText("Eval"));
+--## #endif
+--## classBounded = findClass(findText("Bounded"));
+--## if (isNull(classEq) || isNull(classOrd) || isNull(classRead) ||
+--## isNull(classShow) || isNull(classIx) || isNull(classEnum) ||
+--## #if EVAL_INSTANCES
+--## isNull(classEval) ||
+--## #endif
+--## isNull(classBounded)) {
+--## ERRMSG(0) "Prelude does not define standard classes"
+--## EEND;
+--## }
+--##
+--## classReal = findClass(findText("Real"));
+--## classIntegral = findClass(findText("Integral"));
+--## classRealFrac = findClass(findText("RealFrac"));
+--## classRealFloat = findClass(findText("RealFloat"));
+--## classFractional = findClass(findText("Fractional"));
+--## classFloating = findClass(findText("Floating"));
+--## classNum = findClass(findText("Num"));
+--## if (isNull(classReal) || isNull(classIntegral) ||
+--## isNull(classRealFrac) || isNull(classRealFloat) ||
+--## isNull(classFractional) || isNull(classFloating) ||
+--## isNull(classNum)) {
+--## ERRMSG(0) "Prelude does not define numeric classes"
+--## EEND;
+--## }
+--## predNum = ap(classNum,aVar);
+--## predFractional = ap(classFractional,aVar);
+--## predIntegral = ap(classIntegral,aVar);
+--##
+--## classMonad = findClass(findText("Monad"));
+--## if (isNull(classMonad)) {
+--## ERRMSG(0) "Prelude does not define Monad class"
+--## EEND;
+--## }
+--## predMonad = ap(classMonad,aVar);
+--##
+--## #if IO_MONAD
+--## { Type typeIO = findTycon(findText("IO"));
+--## if (isNull(typeIO)) {
+--## ERRMSG(0) "Prelude does not define IO monad constructor"
+--## EEND;
+--## }
+--## typeProgIO = ap(typeIO,aVar);
+--## }
+--## #endif
+--##
+--## /* The following primitives are referred to in derived instances and
+--## * hence require types; the following types are a little more general
+--## * than we might like, but they are the closest we can get without a
+--## * special datatype class.
+--## */
+--## name(nameConCmp).type
+--## = mkPolyType(starToStar,fn(aVar,fn(aVar,typeOrdering)));
+--## name(nameEnRange).type
+--## = mkPolyType(starToStar,fn(boundPair,listof));
+--## name(nameEnIndex).type
+--## = mkPolyType(starToStar,fn(boundPair,fn(aVar,typeInt)));
+--## name(nameEnInRng).type
+--## = mkPolyType(starToStar,fn(boundPair,fn(aVar,typeBool)));
+--## name(nameEnToEn).type
+--## = mkPolyType(starToStar,fn(aVar,fn(typeInt,aVar)));
+--## name(nameEnFrEn).type
+--## = mkPolyType(starToStar,fn(aVar,typeInt));
+--## name(nameEnFrom).type
+--## = mkPolyType(starToStar,fn(aVar,listof));
+--## name(nameEnFrTo).type
+--## = name(nameEnFrTh).type
+--## = mkPolyType(starToStar,fn(aVar,fn(aVar,listof)));
+--##
+--## #if EVAL_INSTANCES
+--## addEvalInst(0,typeArrow,2,NIL); /* Add Eval instances for builtins */
+--## addEvalInst(0,typeList,1,NIL);
+--## addEvalInst(0,typeUnit,0,NIL);
+--## #endif
+--## for (i=2; i<=NUM_DTUPLES; i++) {/* Add derived instances of tuples */
+--## #if EVAL_INSTANCES
+--## addEvalInst(0,mkTuple(i),i,NIL);
+--## #endif
+--## addTupInst(classEq,i);
+--## addTupInst(classOrd,i);
+--## addTupInst(classShow,i);
+--## addTupInst(classRead,i);
+--## addTupInst(classIx,i);
+--## }
+--## }
+--## }
+--##
+--##
+--## static Void linkPreludeCM() { /* Hook to cfuns and mfuns in */
+--## if (isNull(nameFalse)) { /* prelude when first loaded */
+--## nameFalse = findName(findText("False"));
+--## nameTrue = findName(findText("True"));
+--## nameJust = findName(findText("Just"));
+--## nameNothing = findName(findText("Nothing"));
+--## nameLeft = findName(findText("Left"));
+--## nameRight = findName(findText("Right"));
+--## nameLT = findName(findText("LT"));
+--## nameEQ = findName(findText("EQ"));
+--## nameGT = findName(findText("GT"));
+--## if (isNull(nameFalse) || isNull(nameTrue) ||
+--## isNull(nameJust) || isNull(nameNothing) ||
+--## isNull(nameLeft) || isNull(nameRight) ||
+--## isNull(nameLT) || isNull(nameEQ) || isNull(nameGT)) {
+--## ERRMSG(0) "Prelude does not define standard constructors"
+--## EEND;
+--## }
+--##
+--## nameFromInt = findName(findText("fromInt"));
+--## nameFromInteger = findName(findText("fromInteger"));
+--## nameFromDouble = findName(findText("fromDouble"));
+--## nameEq = findName(findText("=="));
+--## nameCompare = findName(findText("compare"));
+--## nameLe = findName(findText("<="));
+--## nameGt = findName(findText(">"));
+--## nameShowsPrec = findName(findText("showsPrec"));
+--## nameReadsPrec = findName(findText("readsPrec"));
+--## nameIndex = findName(findText("index"));
+--## nameInRange = findName(findText("inRange"));
+--## nameRange = findName(findText("range"));
+--## nameMult = findName(findText("*"));
+--## namePlus = findName(findText("+"));
+--## nameMinBnd = findName(findText("minBound"));
+--## nameMaxBnd = findName(findText("maxBound"));
+--## #if EVAL_INSTANCES
+--## nameStrict = findName(findText("strict"));
+--## nameSeq = findName(findText("seq"));
+--## #endif
+--## nameReturn = findName(findText("return"));
+--## nameBind = findName(findText(">>="));
+--## nameMFail = findName(findText("fail"));
+--## if (isNull(nameFromInt) || isNull(nameFromDouble) ||
+--## isNull(nameEq) || isNull(nameCompare) ||
+--## isNull(nameLe) || isNull(nameGt) ||
+--## isNull(nameShowsPrec) || isNull(nameReadsPrec) ||
+--## isNull(nameIndex) || isNull(nameInRange) ||
+--## isNull(nameRange) || isNull(nameMult) ||
+--## isNull(namePlus) || isNull(nameFromInteger) ||
+--## isNull(nameMinBnd) || isNull(nameMaxBnd) ||
+--## #if EVAL_INSTANCES
+--## isNull(nameStrict) || isNull(nameSeq) ||
+--## #endif
+--## isNull(nameReturn) || isNull(nameBind) ||
+--## isNull(nameMFail)) {
+--## ERRMSG(0) "Prelude does not define standard members"
+--## EEND;
+--## }
+--## }
+--## }
+--##
+#endif
-/* -*- mode: hugs-c; -*- */
-extern Void linkPreludeTC Args((Void));
-extern Void linkPreludeCM Args((Void));
-extern Void linkPreludeNames Args((Void));
-extern Module modulePreludeHugs;
-
-/* --------------------------------------------------------------------------
- * Primitive constructor functions
- * ------------------------------------------------------------------------*/
-
-extern Name nameFalse, nameTrue;
-extern Name nameNil, nameCons;
-extern Name nameUnit;
-
-extern Name nameFromInt, nameFromDouble;/*coercion of numerics */
-extern Name nameFromInteger;
-extern Name nameReturn, nameBind; /* for translating monad comps */
-extern Name nameZero; /* for monads with a zero */
-#if EVAL_INSTANCES
-extern Name nameStrict, nameSeq; /* Members of class Eval */
-#endif
-
-extern Name nameId;
-extern Name nameRunIO;
-extern Name namePrint;
+extern Cell conCons;
extern Name nameForce;
-
-#if TREX
-extern Name nameInsFld; /* Field insertion routine */
-extern Type typeRec; /* Record formation */
-extern Name nameNoRec; /* The empty record */
-extern Type typeNoRow; /* The empty row */
-#endif
+extern Name nameRunIO;
/* The following data constructors are used to box unboxed
* arguments and are treated differently by the code generator.
extern Name nameMkMVar;
#endif
-extern Type typeArrow; /* Builtin type constructors */
-
-#define fn(from,to) ap2(typeArrow,from,to) /* make type: from -> to */
-
/* For every primitive type provided by the runtime system,
* we construct a Haskell type using a declaration of the form:
*
#warning BIGNUMTYPE undefined
#endif
-extern List stdDefaults; /* List of standard default types */
-
-extern Class classEq; /* `standard' classes */
-extern Class classOrd;
-extern Class classShow;
-extern Class classRead;
-extern Class classIx;
-extern Class classEnum;
-extern Class classBounded;
-#if EVAL_INSTANCES
-extern Class classEval;
-#endif
-
-extern Class classReal; /* `numeric' classes */
-extern Class classIntegral;
-extern Class classRealFrac;
-extern Class classRealFloat;
-extern Class classFractional;
-extern Class classFloating;
-extern Class classNum;
-
-extern Class classMonad; /* Monads and monads with a zero */
-extern Class classMonad0;
-
-/* used in typechecker */
-extern Name nameError;
-extern Name nameInd;
-
/* used while desugaring */
extern Name nameId;
extern Name nameOtherwise;
extern Name nameMkIO;
extern Name nameUnpackString;
+extern Type arrow; /* mkOffset(0) -> mkOffset(1) */
+extern Type listof; /* [ mkOffset(0) ] */
+extern Cell predNum; /* Num (mkOffset(0)) */
+extern Cell predFractional; /* Fractional (mkOffset(0)) */
+extern Cell predIntegral; /* Integral (mkOffset(0)) */
+extern Cell predMonad; /* Monad (mkOffset(0)) */
+
-/* -*- mode: hugs-c; -*- */
+
/* --------------------------------------------------------------------------
* Machine dependent code
* RISCOS specific code provided by Bryan Scatergood, JBS
* Macintosh specific code provided by Hans Aberg (haberg@matematik.su.se)
+ * HaskellScript code and recursive directory search provided by
+ * Daan Leijen (leijen@fwi.uva.nl)
*
- * 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
+ * Hugs 98 is Copyright (c) Mark P Jones, Alastair Reid and the Yale
+ * Haskell Group 1994-99, and is distributed as Open Source software
+ * under the Artistic License; see the file "Artistic" that is included
+ * in the distribution for details.
*
* $RCSfile: machdep.c,v $
- * $Revision: 1.2 $
- * $Date: 1998/12/02 13:22:20 $
+ * $Revision: 1.3 $
+ * $Date: 1999/02/03 17:08:32 $
* ------------------------------------------------------------------------*/
-#include "prelude.h"
-#include "storage.h"
-#include "connect.h"
-#include "hugs.h" /* for fromEnv */
-#include "errors.h"
-#include "version.h"
-
-#include "machdep.h"
-
-#include <stdio.h>
#ifdef HAVE_SIGNAL_H
# include <signal.h>
#endif
#endif
/* --------------------------------------------------------------------------
+ * Prototypes for registry reading
+ * ------------------------------------------------------------------------*/
+
+#if USE_REGISTRY
+
+/* where have we hidden things in the registry? */
+#if HSCRIPT
+#define HScriptRoot ("SOFTWARE\\Haskell\\HaskellScript\\")
+#endif
+
+#define HugsRoot ("SOFTWARE\\Haskell\\Hugs\\" HUGS_VERSION "\\")
+#define ProjectRoot ("SOFTWARE\\Haskell\\Hugs\\Projects\\")
+
+static Bool local createKey Args((HKEY, String, PHKEY, REGSAM));
+static Bool local queryValue Args((HKEY, String, String, LPDWORD, LPBYTE, DWORD));
+static Bool local setValue Args((HKEY, String, String, DWORD, LPBYTE, DWORD));
+static String local readRegString Args((HKEY, String, String, String));
+static Int local readRegInt Args((String,Int));
+static Bool local writeRegString Args((String,String));
+static Bool local writeRegInt Args((String,Int));
+
+static String local readRegChildStrings Args((HKEY, String, String, Char, String));
+#endif /* USE_REGISTRY */
+
+/* --------------------------------------------------------------------------
* Find information about a file:
* ------------------------------------------------------------------------*/
+#if RISCOS
+typedef struct { unsigned hi, lo; } Time;
+#define timeChanged(now,thn) (now.hi!=thn.hi || now.lo!=thn.lo)
+#define timeSet(var,tm) var.hi = tm.hi; var.lo = tm.lo
+#else
+typedef time_t Time;
+#define timeChanged(now,thn) (now!=thn)
+#define timeSet(var,tm) var = tm
+#endif
+
+static Void local getFileInfo Args((String, Time *, Long *));
static Bool local readable Args((String));
-Void getFileInfo(f,tm,sz) /* find time stamp and size of file*/
+static Void local getFileInfo(f,tm,sz) /* find time stamp and size of file*/
String f;
Time *tm;
Long *sz; {
* ------------------------------------------------------------------------*/
static String local hugsdir Args((Void));
+#if HSCRIPT
+static String local hscriptDir Args((Void));
+#endif
static String local RealPath Args((String));
+static int local pathCmp Args((String, String));
static String local normPath Args((String));
static Void local searchChr Args((Int));
static Void local searchStr Args((String));
#endif
static String local hugsdir() { /* directory containing lib/Prelude.hs */
-#if HAVE_GETMODULEFILENAME && !DOS
+#if HSCRIPT
+ /* In HaskellScript (Win32 only), we lookup InstallDir in the registry. */
+ static char dir[FILENAME_MAX+1] = "";
+ if (dir[0] == '\0') { /* not initialised yet */
+ String s = readRegString(HKEY_LOCAL_MACHINE,HugsRoot,"InstallDir",
+ HUGSDIR);
+ if (s) {
+ strcpy(dir,s);
+ }
+ }
+ return dir;
+#elif HAVE_GETMODULEFILENAME && !DOS
/* On Windows, we can find the binary we're running and it's
* conventional to put the libraries in the same place.
*/
return HUGSDIR;
#endif
}
-
+
+#if HSCRIPT
+static String local hscriptDir() { /* directory containing ?? what Daan? */
+ static char dir[FILENAME_MAX+1] = "";
+ if (dir[0] == '\0') { /* not initialised yet */
+ String s = readRegString(HKEY_LOCAL_MACHINE,HScriptRoot,"InstallDir","");
+ if (s) {
+ strcpy(dir,s);
+ }
+ }
+ return dir;
+}
+#endif
+
+
static String local RealPath(s) /* Find absolute pathname of file */
String s; {
#if HAVE__FULLPATH /* eg DOS */
return path;
}
-int pathCmp(p1,p2) /* Compare paths after normalisation */
+static int local pathCmp(p1,p2) /* Compare paths after normalisation */
String p1;
String p2; {
#if HAVE__FULLPATH /* eg DOS */
#endif /* ! PATH_CANONICALIZATION */
}
-static String endings[] = { "", ".myhi", ".hs", ".lhs", 0 };
+#if HSCRIPT
+static String endings[] = { "", ".hs", ".lhs", ".hsx", ".hash", 0 };
+#else
+static String endings[] = { "", ".hs", ".lhs", 0 };
+#endif
static char searchBuf[FILENAME_MAX+1];
static Int searchPos;
static Void local searchChr(c) /* Add single character to search buffer */
Int c; {
if (searchPos<FILENAME_MAX) {
- searchBuf[searchPos++] = c;
+ searchBuf[searchPos++] = (char)c;
searchBuf[searchPos] = '\0';
}
}
return FALSE;
}
+
+
+#if SEARCH_DIR
+
+/* scandir, June 98 Daan Leijen
+ searches the base directory and its direct subdirectories for a file
+
+ input: searchbuf contains SLASH terminated base directory
+ argument s contains the (base) filename
+ output: TRUE: searchBuf contains the full filename
+ FALSE: searchBuf is garbage, file not found
+*/
+
+
+#ifdef HAVE_WINDOWS_H
+
+static Bool scanSubDirs(s)
+String s;
+{
+ struct _finddata_t findInfo;
+ long handle;
+ int save;
+
+ save = searchPos;
+ /* is it in the current directory ? */
+ if (tryEndings(s)) return TRUE;
+
+ searchReset(save);
+ searchStr("*");
+
+ /* initiate the search */
+ handle = _findfirst( searchBuf, &findInfo );
+ if (handle==-1) { errno = 0; return FALSE; }
+
+ /* search all subdirectories */
+ do {
+ /* if we have a valid sub directory */
+ if (((findInfo.attrib & _A_SUBDIR) == _A_SUBDIR) &&
+ (findInfo.name[0] != '.')) {
+ searchReset(save);
+ searchStr(findInfo.name);
+ searchChr(SLASH);
+ if (tryEndings(s)) {
+ return TRUE;
+ }
+ }
+ } while (_findnext( handle, &findInfo ) == 0);
+
+ _findclose( handle );
+ return FALSE;
+}
+
+#elif defined(HAVE_FTW_H)
+
+#include <ftw.h>
+
+static char baseFile[FILENAME_MAX+1];
+static char basePath[FILENAME_MAX+1];
+static int basePathLen;
+
+static int scanitem( const char* path,
+ const struct stat* statinfo,
+ int info )
+{
+ if (info == FTW_D) { /* is it a directory */
+ searchReset(0);
+ searchStr(path);
+ searchChr(SLASH);
+ if (tryEndings(baseFile)) {
+ return 1;
+ }
+ }
+ return 0;
+}
+
+static Bool scanSubDirs(s)
+String s;
+{
+ int r;
+ strcpy(baseFile,s);
+ strcpy(basePath,searchBuf);
+ basePathLen = strlen(basePath);
+
+ /* is it in the current directory ? */
+ if (tryEndings(s)) return TRUE;
+
+ /* otherwise scan the subdirectories */
+ r = ftw( basePath, scanitem, 2 );
+ errno = 0;
+ return (r > 0);
+}
+
+#endif /* HAVE_WINDOWS_H || HAVE_FTW_H */
+#endif /* SEARCH_DIR */
+
String findPathname(along,nm) /* Look for a file along specified path */
String along; /* Return NULL if file does not exist */
String nm; {
- String s = findMPathname(along,nm);
+ /* AC, 1/21/99: modified to search hugsPath first, then projectPath */
+ String s = findMPathname(along,nm,hugsPath);
+#if USE_REGISTRY
+#if 0
+ ToDo:
+ if (s==NULL) {
+ s = findMPathname(along,nm,projectPath);
+ }
+#endif /* 0 */
+#endif /* USE_REGISTRY */
return s ? s : normPath(searchBuf);
}
-String findMPathname(along,nm) /* Look for a file along specified path */
+/* AC, 1/21/99: modified to pass in path to search explicitly */
+String findMPathname(along,nm,path)/* Look for a file along specified path */
String along; /* If nonzero, a path prefix from along is */
-String nm; { /* used as the first prefix in the search. */
- String pathpt = hugsPath;
+String nm; /* used as the first prefix in the search. */
+String path; {
+ String pathpt = path;
searchReset(0);
if (along) { /* Was a path for an existing file given? */
if (pathpt && *pathpt) { /* Otherwise, we look along the HUGSPATH */
Bool more = TRUE;
do {
+ Bool recurse = FALSE; /* DL: shall we recurse ? */
searchReset(0);
if (*pathpt) {
if (*pathpt!=PATHSEP) {
searchStr(hugsdir());
pathpt += 6;
}
- do
+#if HSCRIPT
+ /* And another - we ought to generalise this stuff */
+ else if (strncmp(pathpt,"{HScript}",9)==0) {
+ searchStr(hscriptDir());
+ pathpt += 9;
+ }
+#endif
+ do {
searchChr(*pathpt++);
- while (*pathpt && *pathpt!=PATHSEP);
- searchChr(SLASH);
+ } while (*pathpt && *pathpt!=PATHSEP);
+ recurse = (pathpt[-1] == SLASH);
+ if (!recurse) {
+ searchChr(SLASH);
+ }
}
if (*pathpt==PATHSEP)
pathpt++;
else
more = FALSE;
- }
- else
+ } else {
more = FALSE;
- if (tryEndings(nm))
+ }
+#if SEARCH_DIR
+ if (recurse ? scanSubDirs(nm) : tryEndings(nm)) {
+ return normPath(searchBuf);
+ }
+#else
+ if (tryEndings(nm)) {
return normPath(searchBuf);
+ }
+#endif
} while (more);
}
* eg substPath("a:b:c::d:e","x:y:z") = "a:b:c:x:y:z:d:e"
* ------------------------------------------------------------------------*/
-String substPath(new,sub) /* substitute sub path into new path*/
+static String local substPath Args((String,String));
+
+static String local substPath(new,sub) /* substitute sub path into new path*/
String new;
String sub; {
Bool substituted = FALSE; /* only allow one replacement */
/* --------------------------------------------------------------------------
+ * Get time/date stamp for inclusion in compiled files:
+ * ------------------------------------------------------------------------*/
+
+#if PROFILING
+String timeString() { /* return time&date string */
+ time_t clock; /* must end with '\n' character */
+ time(&clock);
+ return(ctime(&clock));
+}
+#endif
+
+/* --------------------------------------------------------------------------
* Garbage collection notification:
* ------------------------------------------------------------------------*/
Bool gcMessages = FALSE; /* TRUE => print GC messages */
-Void gcStarted() { /* notify garbage collector start */
+Void gcStarted() { /* Notify garbage collector start */
#if HUGS_FOR_WINDOWS
SaveCursor = SetCursor(GarbageCursor);
#endif
if (gcMessages) {
- printf("{{Gc");
+ Printf("{{Gc");
FlushStdout();
}
}
-Void gcScanning() { /* notify garbage collector scans */
+Void gcScanning() { /* Notify garbage collector scans */
if (gcMessages) {
Putchar(':');
FlushStdout();
}
}
-Void gcRecovered(recovered) /* notify garbage collection done */
+Void gcRecovered(recovered) /* Notify garbage collection done */
Int recovered; {
if (gcMessages) {
- printf("%d}}",recovered);
- fflush(stdout);
+ Printf("%d}}",recovered);
+ FlushStdout();
}
#if HUGS_FOR_WINDOWS
SetCursor(SaveCursor);
#if (HAVE_TERMIO_H | HAVE_SGTTY_H | HAVE_TERMIOS_H)
-/* This is believed to be redundant! ADR */
+/* grab the varargs prototype for ioctl */
#if HAVE_SYS_IOCTL_H
# include <sys/ioctl.h>
#endif
if (broken) { /* repond to break signal received */
broken = FALSE; /* whilst break trap disabled */
sigRaise(breakHandler);
+ /* not reached */
}
+#if HANDLERS_CANT_LONGJMP
ctrlbrk(ignoreBreak);
+#else
+ ctrlbrk(breakHandler);
+#endif
} else {
ctrlbrk(ignoreBreak);
}
}
static sigHandler(ignoreBreak) { /* record but don't respond to break*/
- ctrlbrk(ignoreBreak);
+ ctrlbrk(ignoreBreak); /* reinstall signal handler */
+ /* redundant on BSD systems but essential */
+ /* on POSIX and other systems */
broken = TRUE;
interruptStgRts();
sigResume;
* Shell escapes:
* ------------------------------------------------------------------------*/
-Bool startEdit(line,nm) /* Start editor on file name at */
+static Bool local startEdit(line,nm) /* Start editor on file name at */
Int line; /* given line. Both name and line */
String nm; { /* or just line may be zero */
static char editorCmd[FILENAME_MAX+1];
== ERROR_SUCCESS;
}
-static Bool local queryValue(hKey, var, type, buf, bufSize)
+static Bool local queryValue(hKey, regPath, var, type, buf, bufSize)
HKEY hKey;
+String regPath;
String var;
LPDWORD type;
LPBYTE buf;
DWORD bufSize; {
HKEY hRootKey;
- if (!createKey(hKey, &hRootKey, KEY_READ)) {
+ if (!createKey(hKey, regPath, &hRootKey, KEY_READ)) {
return FALSE;
} else {
LONG res = RegQueryValueEx(hRootKey, var, NULL, type, buf, &bufSize);
}
}
-static Bool local setValue(hKey, var, type, buf, bufSize)
+static Bool local setValue(hKey, regPath, var, type, buf, bufSize)
HKEY hKey;
+String regPath;
String var;
DWORD type;
LPBYTE buf;
DWORD bufSize; {
HKEY hRootKey;
- if (!createKey(hKey, &hRootKey, KEY_WRITE)) {
+ if (!createKey(hKey, regPath, &hRootKey, KEY_WRITE)) {
return FALSE;
} else {
LONG res = RegSetValueEx(hRootKey, var, 0, type, buf, bufSize);
}
}
-String readRegString(var,def) /* read String from registry */
+static String local readRegString(key,regPath,var,def) /* read String from registry */
+HKEY key;
+String regPath;
String var;
String def; {
static char buf[300];
DWORD type;
-
- if (queryValue(HKEY_CURRENT_USER, var, &type, buf, sizeof(buf))
+ if (queryValue(key, regPath,var, &type, buf, sizeof(buf))
&& type == REG_SZ) {
return (String)buf;
- } else if (queryValue(HKEY_LOCAL_MACHINE, var, &type, buf, sizeof(buf))
- && type == REG_SZ) {
- return (String)buf;
} else {
- return NULL;
+ return def;
}
}
-
-Int readRegInt(var, def) /* read Int from registry */
+
+static Int local readRegInt(var, def) /* read Int from registry */
String var;
Int def; {
DWORD buf;
DWORD type;
- if (queryValue(HKEY_CURRENT_USER, var, &type,
+ if (queryValue(HKEY_CURRENT_USER, HugsRoot, var, &type,
(LPBYTE)&buf, sizeof(buf))
&& type == REG_DWORD) {
return (Int)buf;
- } else if (queryValue(HKEY_LOCAL_MACHINE, var, &type,
+ } else if (queryValue(HKEY_LOCAL_MACHINE, HugsRoot, var, &type,
(LPBYTE)&buf, sizeof(buf))
&& type == REG_DWORD) {
return (Int)buf;
}
}
-Bool writeRegString(var,val) /* write String to registry */
+static Bool local writeRegString(var,val) /* write String to registry */
String var;
String val; {
if (NULL == val) {
val = "";
}
- return setValue(HKEY_CURRENT_USER, var,
+ return setValue(HKEY_CURRENT_USER, HugsRoot, var,
REG_SZ, (LPBYTE)val, lstrlen(val)+1);
}
-Bool writeRegInt(var,val) /* write String to registry */
+static Bool local writeRegInt(var,val) /* write String to registry */
String var;
Int val; {
- return setValue(HKEY_CURRENT_USER, var,
+ return setValue(HKEY_CURRENT_USER, HugsRoot, var,
REG_DWORD, (LPBYTE)&val, sizeof(val));
}
-/* -*- mode: hugs-c; -*- */
+
/* --------------------------------------------------------------------------
* Optimiser
*
* Hugs version 1.4, December 1997
*
* $RCSfile: optimise.c,v $
- * $Revision: 1.2 $
- * $Date: 1998/12/02 13:22:23 $
+ * $Revision: 1.3 $
+ * $Date: 1999/02/03 17:08:33 $
* ------------------------------------------------------------------------*/
#include "prelude.h"
#include "storage.h"
+#include "backend.h"
#include "connect.h"
#include "errors.h"
-#include "stg.h"
-#include "optimise.h"
/* --------------------------------------------------------------------------
* Local functions
-/* -*- mode: hugs-c; -*- */
+
/* --------------------------------------------------------------------------
* Unparse expressions and types - for use in error messages, type checker
* and for debugging.
*
- * 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
+ * Hugs 98 is Copyright (c) Mark P Jones, Alastair Reid and the Yale
+ * Haskell Group 1994-99, and is distributed as Open Source software
+ * under the Artistic License; see the file "Artistic" that is included
+ * in the distribution for details.
*
* $RCSfile: output.c,v $
- * $Revision: 1.2 $
- * $Date: 1998/12/02 13:22:24 $
+ * $Revision: 1.3 $
+ * $Date: 1999/02/03 17:08:33 $
* ------------------------------------------------------------------------*/
#include "prelude.h"
#include "storage.h"
#include "connect.h"
-#include "input.h" /* for textPlus */
#include "errors.h"
-#include "link.h"
#include <ctype.h>
+/*#define DEBUG_SHOWSC*/ /* Must also be set in compiler.c */
+
#define DEPTH_LIMIT 15
/* --------------------------------------------------------------------------
static Void local unlexStrConst Args((Text));
static Void local putSigType Args((Cell));
-static Void local putContext Args((List,Int));
+static Void local putContext Args((List,List,Int));
static Void local putPred Args((Cell,Int));
static Void local putType Args((Cell,Int,Int));
static Void local putTyVar Args((Int));
* ------------------------------------------------------------------------*/
static FILE *outputStream; /* current output stream */
+#ifdef DEBUG_SHOWSC
+static Int outColumn = 0; /* current output column number */
+#endif
#define OPEN(b) if (b) putChr('(');
#define CLOSE(b) if (b) putChr(')');
static Void local putChr(c) /* print single character */
Int c; {
Putc(c,outputStream);
+#ifdef DEBUG_SHOWSC
+ outColumn++;
+#endif
}
static Void local putStr(s) /* print string */
String s; {
for (; *s; s++) {
Putc(*s,outputStream);
+#ifdef DEBUG_SHOWSC
+ outColumn++;
+#endif
}
}
case COMP : putComp(fst(snd(e)),snd(snd(e)));
break;
+ case MONADCOMP : putComp(fst(snd(snd(e))),snd(snd(snd(e))));
+ break;
+
case CHARCELL : unlexCharConst(charOf(e));
break;
- case INTCELL : putInt(intOf(e));
+ case INTCELL : { Int i = intOf(e);
+ if (i<0 && d>=UMINUS_PREC) putChr('(');
+ putInt(i);
+ if (i<0 && d>=UMINUS_PREC) putChr(')');
+ }
break;
- case BIGCELL : putStr(bignumToString(e));
+#if BIGNUMS
+ case NEGNUM :
+ case ZERONUM :
+ case POSNUM : xs = bigOut(e,NIL,d>=UMINUS_PREC);
+ for (; nonNull(xs); xs=tl(xs))
+ putChr(charOf(arg(hd(xs))));
break;
+#endif
- case FLOATCELL : putStr(floatToString(e));
+ case FLOATCELL : { Float f = floatOf(e);
+ if (f<0 && d>=UMINUS_PREC) putChr('(');
+ putStr(floatToString(f));
+ if (f<0 && d>=UMINUS_PREC) putChr(')');
+ }
break;
case STRCELL : unlexStrConst(textOf(e));
case LAMBDA : xs = fst(snd(e));
if (whatIs(xs)==BIGLAM)
- xs = snd(snd(e));
+ xs = snd(snd(xs));
while (nonNull(xs) && isDictVal(hd(xs)))
xs = tl(xs);
if (isNull(xs)) {
putDepth--;
}
-static Void local putFlds(exp,fs) /* Output exp using labelled fields*/
+static Void local putFlds(exp,fs) /* Output exp using labelled fields*/
Cell exp;
List fs; {
put(ALWAYS,exp);
isVar(e) ? textOf(e) : inventText();
put(NEVER,f);
- if (s!=t) {
+ if (haskell98 || s!=t) {
putStr(" = ");
put(NEVER,e);
}
#if !DEBUG_CODE
Cell h = getHead(e);
switch (whatIs(h)) {
- case DICTVAR : return TRUE;
- case NAME : return isDfun(h);
+ case DICTVAR : return TRUE;
+ case NAME : return isDfun(h);
}
#endif
return FALSE;
switch (whatIs(h)) {
#if NPLUSK
case ADDPAT : if (args==1)
- putInfix(d,textPlus,syntaxOf(textPlus),
- arg(e),snd(h));
+ putInfix(d,textPlus,syntaxOf(namePlus),
+ arg(e),mkInt(intValOf(fun(e))));
else
putStr("ADDPAT");
return;
case NAME : if (args==1 &&
((h==nameFromInt && isInt(arg(e))) ||
+#if BIGNUMS
(h==nameFromInteger && isBignum(arg(e))) ||
+#endif
(h==nameFromDouble && isFloat(arg(e))))) {
put(d,arg(e));
return;
}
- sy = syntaxOf(t = name(h).text);
+ t = name(h).text;
+ sy = syntaxOf(h);
break;
case VARIDCELL :
case VAROPCELL :
case DICTVAR :
case CONIDCELL :
- case CONOPCELL : sy = syntaxOf(t = textOf(h));
+ case CONOPCELL : sy = defaultSyntax(t = textOf(h));
break;
#if TREX
putType(t,NEVER,fr); /* Finally, print rest of type ... */
}
-static Void local putContext(qs,fr) /* print context list */
+static Void local putContext(ps,qs,fr) /* print context list */
+List ps;
List qs;
Int fr; {
- if (isNull(qs))
- putStr("()");
- else {
- Int nq = length(qs);
- if (nq!=1) putChr('(');
+ Int len = length(ps) + length(qs);
+ Int c = len;
+ if (len!=1) {
+ putChr('(');
+ }
+ for (; nonNull(ps); ps=tl(ps)) {
+ putPred(hd(ps),fr);
+ if (--c > 0) {
+ putStr(", ");
+ }
+ }
+ for (; nonNull(qs); qs=tl(qs)) {
putPred(hd(qs),fr);
- while (nonNull(qs=tl(qs))) {
+ if (--c > 0) {
putStr(", ");
- putPred(hd(qs),fr);
}
- if (nq!=1) putChr(')');
+ }
+ if (len!=1) {
+ putChr(')');
}
}
Int prec;
Int fr; {
switch(whatIs(t)) {
- case TYCON : putStr(textToStr(tycon(t).text));
- break;
+ case TYCON : putStr(textToStr(tycon(t).text));
+ break;
- case TUPLE : { Int n = tupleOf(t);
- putChr('(');
- while (--n > 0)
- putChr(',');
- putChr(')');
- }
- break;
+ case TUPLE : { Int n = tupleOf(t);
+ putChr('(');
+ while (--n > 0)
+ putChr(',');
+ putChr(')');
+ }
+ break;
case POLYTYPE : { Kinds ks = polySigOf(t);
OPEN(prec>=ARROW_PREC);
}
break;
+ case CDICTS :
case QUAL : OPEN(prec>=ARROW_PREC);
- putContext(fst(snd(t)),fr);
- putStr(" => ");
- putType(snd(snd(t)),NEVER,fr);
+ if (whatIs(snd(snd(t)))==CDICTS) {
+ putContext(fst(snd(t)),fst(snd(snd(snd(t)))),fr);
+ putStr(" => ");
+ putType(snd(snd(snd(snd(t)))),NEVER,fr);
+ } else {
+ putContext(fst(snd(t)),NIL,fr);
+ putStr(" => ");
+ putType(snd(snd(t)),NEVER,fr);
+ }
CLOSE(prec>=ARROW_PREC);
break;
case RANK2 : putType(snd(snd(t)),prec,fr);
break;
- case OFFSET : putTyVar(offsetOf(t));
- break;
+ case OFFSET : putTyVar(offsetOf(t));
+ break;
case VARIDCELL :
case VAROPCELL : putChr('_');
unlexVar(textOf(t));
break;
- case INTCELL : putChr('_');
- putInt(intOf(t));
- break;
+ case INTCELL : putChr('_');
+ putInt(intOf(t));
+ break;
-/* #ifdef DEBUG_TYPES */
- case STAR : putChr('*');
- break;
-/* #endif */
-
- case AP : { Cell typeHead = getHead(t);
- Bool brackets = (argCount!=0 && prec>=ALWAYS);
- Int args = argCount;
-
- if (typeHead==typeList) {
- if (argCount==1) {
- putChr('[');
- putType(arg(t),NEVER,fr);
- putChr(']');
- return;
- }
- }
- else if (typeHead==typeArrow) {
- if (argCount==2) {
- OPEN(prec>=ARROW_PREC);
- putType(arg(fun(t)),ARROW_PREC,fr);
- putStr(" -> ");
- putType(arg(t),NEVER,fr);
- CLOSE(prec>=ARROW_PREC);
- return;
- }
- else if (argCount==1) {
- putChr('(');
- putType(arg(t),ARROW_PREC,fr);
- putStr("->)");
- return;
- }
- }
- else if (isTuple(typeHead)) {
- if (argCount==tupleOf(typeHead)) {
- putChr('(');
- putTupleType(t,fr);
- putChr(')');
- return;
- }
- }
+ case AP : { Cell typeHead = getHead(t);
+ Bool brackets = (argCount!=0 && prec>=ALWAYS);
+ Int args = argCount;
+
+ if (typeHead==typeList) {
+ if (argCount==1) {
+ putChr('[');
+ putType(arg(t),NEVER,fr);
+ putChr(']');
+ return;
+ }
+ }
+ else if (typeHead==typeArrow) {
+ if (argCount==2) {
+ OPEN(prec>=ARROW_PREC);
+ putType(arg(fun(t)),ARROW_PREC,fr);
+ putStr(" -> ");
+ putType(arg(t),NEVER,fr);
+ CLOSE(prec>=ARROW_PREC);
+ return;
+ }
+ else if (argCount==1) {
+ putChr('(');
+ putType(arg(t),ARROW_PREC,fr);
+ putStr("->)");
+ return;
+ }
+ }
+ else if (isTuple(typeHead)) {
+ if (argCount==tupleOf(typeHead)) {
+ putChr('(');
+ putTupleType(t,fr);
+ putChr(')');
+ return;
+ }
+ }
#if TREX
- else if (isExt(typeHead)) {
+ else if (isExt(typeHead)) {
if (args==2) {
String punc = "(";
do {
args-=2;
}
#endif
- OPEN(brackets);
- putApType(t,args,fr);
- CLOSE(brackets);
- }
- break;
+ OPEN(brackets);
+ putApType(t,args,fr);
+ CLOSE(brackets);
+ }
+ break;
- default : putStr("(bad type)");
+ default : putStr("(bad type)");
}
}
FILE *fp;
List qs; {
outputStream = fp;
- putContext(qs,0);
+ putContext(qs,NIL,0);
}
Void printPred(fp,pi) /* print predicate pi on stream */
}
Void printKinds(fp,ks) /* print list of kinds on stream */
-FILE *fp;
+FILE *fp;
Kinds ks; {
outputStream = fp;
putKinds(ks);
-/* -*- mode: hugs-c; -*- */
+
/* --------------------------------------------------------------------------
* Hugs parser (included as part of input.c)
*
- * 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
+ * Expect 6 shift/reduce conflicts when passing this grammar through yacc,
+ * but don't worry; they should all be resolved in an appropriate manner.
*
- * Expect 24 shift/reduce conflicts when passing this grammar through yacc,
- * but don't worry; they will all be resolved in an appropriate manner.
+ * Hugs 98 is Copyright (c) Mark P Jones, Alastair Reid and the Yale
+ * Haskell Group 1994-99, and is distributed as Open Source software
+ * under the Artistic License; see the file "Artistic" that is included
+ * in the distribution for details.
*
* $RCSfile: parser.y,v $
- * $Revision: 1.2 $
- * $Date: 1998/12/02 13:22:26 $
+ * $Revision: 1.3 $
+ * $Date: 1999/02/03 17:08:34 $
* ------------------------------------------------------------------------*/
%{
#endif
#define defTycon(n,l,lhs,rhs,w) tyconDefn(intOf(l),lhs,rhs,w); sp-=n
#define sigdecl(l,vs,t) ap(SIGDECL,triple(l,vs,t))
+#define fixdecl(l,ops,a,p) ap(FIXDECL,\
+ triple(l,ops,mkInt(mkSyntax(a,intOf(p)))))
#define grded(gs) ap(GUARDED,gs)
#define bang(t) ap(BANG,t)
#define only(t) ap(ONLY,t)
#define letrec(bs,e) (nonNull(bs) ? ap(LETREC,pair(bs,e)) : e)
+#define qualify(ps,t) (nonNull(ps) ? ap(QUAL,pair(ps,t)) : t)
+#if IGNORE_MODULES
+#define exportSelf() NIL
+#else
#define exportSelf() singleton(ap(MODULEENT,mkCon(module(currentModule).text)))
+#endif
#define yyerror(s) /* errors handled elsewhere */
#define YYSTYPE Cell
static Void local syntaxError Args((String));
static String local unexpected Args((Void));
static Cell local checkPrec Args((Cell));
-static Void local fixDefn Args((Syntax,Cell,Cell,List));
-static Void local setSyntax Args((Int,Syntax,Cell));
static Cell local buildTuple Args((List));
static List local checkContext Args((List));
static Cell local checkPred Args((Cell));
#if !TREX
static Void local noTREX Args((String));
#endif
-static Cell local tidyInfix Args((Cell));
/* For the purposes of reasonably portable garbage collection, it is
* necessary to simulate the YACC stack on the Hugs stack to keep
* taking account of look-ahead tokens as described by gcShadow()
* below.
*
- * Of the non-terminals used below, only start, topDecl, fixDecl & begin
+ * Of the non-terminals used below, only start, topDecl & begin
* do not leave any values on the Hugs stack. The same is true for the
* terminals EXPR and SCRIPT. At the end of a successful parse, there
* should only be one element left on the stack, containing the result
* of the parse.
*/
-#define gc0(e) gcShadow(0,e)
-#define gc1(e) gcShadow(1,e)
-#define gc2(e) gcShadow(2,e)
-#define gc3(e) gcShadow(3,e)
-#define gc4(e) gcShadow(4,e)
-#define gc5(e) gcShadow(5,e)
-#define gc6(e) gcShadow(6,e)
-#define gc7(e) gcShadow(7,e)
+#define gc0(e) gcShadow(0,e)
+#define gc1(e) gcShadow(1,e)
+#define gc2(e) gcShadow(2,e)
+#define gc3(e) gcShadow(3,e)
+#define gc4(e) gcShadow(4,e)
+#define gc5(e) gcShadow(5,e)
+#define gc6(e) gcShadow(6,e)
+#define gc7(e) gcShadow(7,e)
%}
%token EXPR SCRIPT
%token CASEXP OF DATA TYPE IF
%token THEN ELSE WHERE LET IN
-%token INFIX INFIXL INFIXR FOREIGN TNEWTYPE
+%token INFIXN INFIXL INFIXR FOREIGN TNEWTYPE
%token DEFAULT DERIVING DO TCLASS TINSTANCE
-%token REPEAT ALL
-%token VAROP VARID NUMLIT CHARLIT STRINGLIT
-%token CONOP CONID
+%token REPEAT ALL NUMLIT CHARLIT STRINGLIT
+%token VAROP VARID CONOP CONID
%token QVAROP QVARID QCONOP QCONID
/*#if TREX*/
%token RECSELID
%token '|' '-' FROM ARROW '~'
%token '!' IMPLIES '(' ',' ')'
%token '[' ';' ']' '`' '.'
-%token MODULETOK IMPORT HIDING QUALIFIED ASMOD
-%token EXPORT INTERFACE REQUIRES UNSAFE
+%token TMODULE IMPORT HIDING QUALIFIED ASMOD
+%token EXPORT UNSAFE
%%
-/*- Top level script/module structure: ------------------------------------*/
+/*- Top level script/module structure -------------------------------------*/
start : EXPR exp wherePart {inputExpr = letrec($3,$2); sp-=2;}
| SCRIPT topModule {valDefns = $2; sp-=1;}
- | INTERFACE iface {sp-=1;}
| error {syntaxError("input");}
;
-/*- GHC interface file parsing: -------------------------------------------*/
-
-/* Reading in an interface file is surprisingly like reading
- * a normal Haskell module: we read in a bunch of declarations,
- * construct symbol table entries, etc. The "only" differences
- * are that there's no syntactic sugar to deal with and we don't
- * have to read in expressions.
- */
-
-iface : INTERFACE ifaceName NUMLIT checkVersion ifaceDecls { $$ = gc5(NIL); }
- | INTERFACE error {syntaxError("interface file");}
- ;
-
-ifaceName : CONID {openGHCIface(textOf($1)); $$ = gc1(NIL);}
- ;
-
-ifaceDecls: {$$=gc0(NIL);}
- | ifaceDecl ';' ifaceDecls {$$=gc3(cons($1,$2));}
- ;
-
-/* We use ifaceData in data decls so as to include () */
-ifaceDecl : IMPORT CONID NUMLIT { extern String scriptFile;
- String fileName = findPathname(scriptFile,textToStr(textOf($2)));
- addGHCImport(intOf($1),textOf($2),fileName);
- $$ = gc3(NIL);
- }
- | EXPORT CONID ifaceEntities {}
- | REQUIRES STRINGLIT { extern String scriptFile;
- String fileName = findPathname(scriptFile,textToStr(textOf($2)));
- loadSharedLib(fileName);
- $$ = gc2(NIL);
- }
- | INFIXL optdigit op { fixDefn(LEFT_ASS,$1,$2,$3); $$ = gc3(NIL); }
- | INFIXR optdigit op { fixDefn(RIGHT_ASS,$1,$2,$3); $$ = gc3(NIL); }
- | INFIX optdigit op { fixDefn(NON_ASS,$1,$2,$3); $$ = gc3(NIL); }
- | TINSTANCE ifaceQuant ifaceClass '=' ifaceVar { addGHCInstance(intOf($1),$2,$3,textOf($5)); $$ = gc5(NIL); }
- | NUMLIT TYPE ifaceTCName ifaceTVBndrs '=' ifaceType { addGHCSynonym(intOf($2),$3,$4,$6); $$ = gc6(NIL); }
- | NUMLIT DATA ifaceData ifaceTVBndrs ifaceConstrs ifaceSels { addGHCDataDecl(intOf($2),$3,$4,$5,$6); $$ = gc6(NIL); }
- | NUMLIT TNEWTYPE ifaceTCName ifaceTVBndrs ifaceNewTypeConstr { addGHCNewType(intOf($2),$3,$4,$5); $$ = gc5(NIL); }
- | NUMLIT TCLASS ifaceDeclContext ifaceTCName ifaceTVBndrs ifaceCSigs { addGHCClass(intOf($2),$3,$4,$5,$6); $$ = gc6(NIL); }
- | NUMLIT ifaceVar COCO ifaceType { addGHCVar(intOf($3),textOf($2),$4); $$ = gc4(NIL); }
- | error { syntaxError("interface declaration"); }
- ;
-
-checkVersion
- : NUMLIT { $$ = gc1(NIL); }
- ;
-
-ifaceSels /* [(VarId,Type)] */
- : { $$ = gc0(NIL); }
- | WHERE '{' ifaceSels1 '}' { $$ = gc4($3); }
- ;
-
-ifaceSels1 /* [(VarId,Type)] */
- : ifaceSel { $$ = gc1(singleton($1)); }
- | ifaceSel ';' ifaceSels1 { $$ = gc3(cons($1,$3)); }
- ;
-
-ifaceSel /* (VarId,Type) */
- : ifaceVarName COCO ifaceType { $$ = gc3(pair($1,$3)); }
- ;
-
-ifaceCSigs /* [(VarId,Type)] */
- : { $$ = gc0(NIL); }
- | WHERE '{' ifaceCSigs1 '}' { $$ = gc4($3); }
- ;
-
-ifaceCSigs1 /* [(VarId,Type)] */
- : ifaceCSig { $$ = gc1(singleton($1)); }
- | ifaceCSig ';' ifaceCSigs1 { $$ = gc3(cons($1,$3)); }
- ;
-
-ifaceCSig /* (VarId,Type) */
- : ifaceVarName COCO ifaceType { $$ = gc3(pair($1,$3)); }
- | ifaceVarName '=' COCO ifaceType { $$ = gc4(pair($1,$4)); } /* has default method */
- ;
-
-ifaceConstrs /* [(ConId,[VarId],Type)] */
- : { $$ = gc0(NIL); }
- | '=' ifaceConstrs1 { $$ = gc2($2); }
- ;
-
-ifaceConstrs1 /* [(ConId,[VarId],Type)] */
- : ifaceConstr { $$ = gc1(singleton($1)); }
- | ifaceConstr '|' ifaceConstrs1 { $$ = gc3(cons($1,$3)); }
- ;
-
-/* We use ifaceData so as to include () */
-ifaceConstr /* (ConId,[VarId],Type) */
- : ifaceData COCO ifaceType { $$ = gc3(triple($1,NIL,$3)); }
- | ifaceData '{' ifaceVarNames1 '}' COCO ifaceType { $$ = gc6(triple($1,$3,$6)); }
- ;
-
-ifaceNewTypeConstr /* (ConId,Type) */
- : { $$ = gc0(NIL); }
- | '=' ifaceDataName COCO ifaceType { $$ = gc4(pair($2,$4)); }
- ;
-
-ifaceQuant /* Maybe ([(VarId,Kind)],[(ConId, [Type])]) */
- : { $$ = gc0(NIL); }
- | ALL ifaceForall ifaceContext IMPLIES { $$ = gc4(pair($2,$3)); }
- ;
-
-ifaceType
- : ALL ifaceForall ifaceContext IMPLIES ifaceType { $$ = gc5(ap(POLYTYPE,triple($2,$3,$5))); }
- | ifaceBType ARROW ifaceType { $$ = gc3(fn($1,$3)); }
- | ifaceBType { $$ = gc1($1); }
- ;
-
-ifaceForall /* [(VarId,Kind)] */
- : '[' ifaceTVBndrs ']' { $$ = gc3($2); }
- ;
-
-ifaceDeclContext /* [(ConId, [Type])] */
- : { $$ = gc0(NIL); }
- | '{' ifaceContextList1 '}' IMPLIES { $$ = gc4($2); }
- ;
-
-ifaceContext /* [(ConId, [Type])] */
- : { $$ = gc0(NIL); }
- | '{' ifaceContextList1 '}' { $$ = gc3($2); }
- ;
-
-ifaceContextList1 /* [(ConId, [Type])] */
- : ifaceClass { $$ = gc1(singleton($1)); }
- | ifaceClass ',' ifaceContextList1 { $$ = gc3(cons($1,$3)); }
- ;
-
-ifaceClass /* (ConId, [Type]) */
- : ifaceQTCName ifaceATypes { $$ = gc2(pair($1,$2)); }
- ;
-
-ifaceTypes2
- : ifaceType ',' ifaceType { $$ = gc3(doubleton($1,$3)); }
- | ifaceType ',' ifaceTypes2 { $$ = gc3(cons($1,$3)); }
- ;
-
-ifaceBType
- : ifaceAType { $$ = gc1($1); }
- | ifaceBType ifaceAType { $$ = gc2(ap($1,$2)); }
- ;
-
-ifaceAType
- : ifaceQTCName { $$ = gc1($1); }
- | ifaceTVName { $$ = gc1($1); }
- | '(' ')' { $$ = gc2(conPreludeUnit); }
- | '(' ifaceTypes2 ')' { $$ = gc3(buildTuple($2)); }
- | '[' ifaceType ']' { $$ = gc3(ap(conPreludeList,$2));}
- | '{' ifaceQTCName ifaceATypes '}' { $$ = gc4(ap(DICTAP,pair($2,$3))); }
- | '(' ifaceType ')' { $$ = gc3($2); }
- ;
-
-ifaceATypes
- : { $$ = gc0(NIL); }
- | ifaceAType ifaceATypes { $$ = gc2(cons($1,$2)); }
- ;
-
-ifaceEntities
- : { $$ = gc0(NIL); }
- | ifaceEntity ifaceEntities { $$ = gc2(cons($1,$2)); }
- ;
-
-ifaceEntity
- : ifaceEntityOcc {}
- | ifaceEntityOcc ifaceStuffInside {}
-| ifaceEntityOcc '|' ifaceStuffInside {} /* exporting datacons but not tycon */
- ;
-
-ifaceEntityOcc
- : ifaceVar { $$ = gc1($1); }
- | ifaceData { $$ = gc1($1); }
- | ARROW { $$ = gc3(typeArrow); }
- | '(' ARROW ')' { $$ = gc3(typeArrow); } /* why allow both? */
- ;
-
-ifaceStuffInside
- : '{' ifaceValOccs '}' { $$ = gc1($1); }
- ;
-
-
-ifaceValOccs
- : ifaceValOcc { $$ = gc1(singleton($1)); }
- | ifaceValOcc ifaceValOccs { $$ = gc2(cons($1,$2)); }
- ;
-
-ifaceValOcc
- : ifaceVar {$$ = gc1($1); }
- | ifaceData {$$ = gc1($1); }
- ;
-
-ifaceVar : VARID {$$ = gc1($1); }
- | VAROP {$$ = gc1($1); }
- | '!' {$$ = gc1(varBang); }
- | '.' {$$ = gc1(varDot); }
- | '-' {$$ = gc1(varMinus);}
- ;
-
-ifaceData /* ConId | QualConId */
- : CONID {$$ = gc1($1);}
- | CONOP {$$ = gc1($1);}
- | '(' ')' {$$ = gc2(conPreludeUnit);}
- | '[' ']' {$$ = gc2(conPreludeList);}
- ;
-
-ifaceVarName /* VarId */
- : ifaceVar { $$ = gc1($1); }
- ;
-
-ifaceDataName /* ConId|QualConId */
- : ifaceData { $$ = gc1($1); }
- ;
-
-ifaceVarNames1 /* [VarId] */
- : ifaceVarName { $$ = gc1(singleton($1)); }
- | ifaceVarName ifaceVarNames1 { $$ = gc2(cons($1,$2)); }
- ;
-
-ifaceTVName /* VarId */
- : VARID { $$ = gc1($1); }
- ;
-
-ifaceTVBndrs /* [(VarId,Kind)] */
- : { $$ = gc0(NIL); }
- | ifaceTVBndr ifaceTVBndrs { $$ = gc2(cons($1,$2)); }
- ;
-
-ifaceTVBndr /* (VarId,Kind) */
- : ifaceTVName { $$ = gc1(pair($1,STAR)); }
- | ifaceTVName COCO ifaceAKind { $$ = gc3(pair($1,$3)); }
- ;
-
-ifaceKind
- : ifaceAKind { $$ = gc1($1); }
- | ifaceAKind ARROW ifaceKind { $$ = gc3(fn($1,$3)); }
- ;
-
-ifaceAKind
- : VAROP { $$ = gc1(STAR); } /* should be '*' */
- | '(' ifaceKind ')' { $$ = gc1($1); }
- ;
-
-ifaceTCName
- : CONID { $$ = gc1($1); }
- | CONOP { $$ = gc1($1); }
- | '(' ARROW ')' { $$ = gc3(typeArrow); }
- | '[' ']' { $$ = gc1(conPreludeList); }
- ;
-
-ifaceQTCName
- : ifaceTCName { $$ = gc1($1); }
- | QCONID { $$ = gc1($1); }
- | QCONOP { $$ = gc1($1); }
- ;
-
-/*- Haskell module header/import parsing: ---------------------------------*/
+/*- Haskell module header/import parsing: -----------------------------------
+ * Syntax for Haskell modules (module headers and imports) is parsed but
+ * most of it is ignored. However, module names in import declarations
+ * are used, of course, if import chasing is turned on.
+ *-------------------------------------------------------------------------*/
/* In Haskell 1.2, the default module header was "module Main where"
* In 1.3, this changed to "module Main(main) where".
setExportList(singleton(ap(MODULEENT,mkCon(module(currentModule).text))));
$$ = gc3($3);
}
- | MODULETOK modname expspec WHERE '{' modBody end
+ | TMODULE modname expspec WHERE '{' modBody end
{setExportList($3); $$ = gc7($6);}
- | MODULETOK error {syntaxError("module definition");}
+ | TMODULE error {syntaxError("module definition");}
;
/* To implement the Haskell module system, we have to keep track of the
* current module. We rely on the use of LALR parsing to ensure that this
;
modname : CONID {startModule($1); $$ = gc1(NIL);}
;
-modid : CONID {$$ = gc1($1);}
+modid : CONID {$$ = $1;}
| STRINGLIT { extern String scriptFile;
String modName = findPathname(scriptFile,textToStr(textOf($1)));
if (modName) { /* fillin pathname if known */
}
}
;
-modBody : topDecls {$$ = gc1($1);}
- | fixDecls ';' topDecls {$$ = gc3($3);}
+modBody : topDecls {$$ = $1;}
| impDecls chase {$$ = gc2(NIL);}
| impDecls ';' chase topDecls {$$ = gc4($4);}
- | impDecls ';' chase fixDecls ';' topDecls
- {$$ = gc6($6);}
;
/*- Exports: --------------------------------------------------------------*/
/* The qcon should be qconid.
* Relaxing the rule lets us explicitly export (:) from the Prelude.
*/
-export : qvar {$$ = gc1($1);}
- | qcon {$$ = gc1($1);}
- | qcon2 '(' UPTO ')' {$$ = gc4(pair($1,DOTDOT));}
- | qcon2 '(' qnames ')' {$$ = gc4(pair($1,$3));}
- | MODULETOK modid {$$ = gc2(ap(MODULEENT,$2));}
+export : qvar {$$ = $1;}
+ | qcon {$$ = $1;}
+ | qconid '(' UPTO ')' {$$ = gc4(pair($1,DOTDOT));}
+ | qconid '(' qnames ')' {$$ = gc4(pair($1,$3));}
+ | TMODULE modid {$$ = gc2(ap(MODULEENT,$2));}
;
qnames : /* empty */ {$$ = gc0(NIL);}
| ',' {$$ = gc1(NIL);}
- | qnames1 {$$ = gc1($1);}
+ | qnames1 {$$ = $1;}
| qnames1 ',' {$$ = gc2($1);}
;
qnames1 : qnames1 ',' qname {$$ = gc3(cons($3,$1));}
| qname {$$ = gc1(singleton($1));}
;
-qname : qvar {$$ = gc1($1);}
- | qcon {$$ = gc1($1);}
- | '(' ')' {$$ = gc2(conPreludeUnit);}
- | '[' ']' {$$ = gc2(conPreludeList);}
- ;
-qcon2 : '(' ')' {$$ = gc2(conPreludeUnit);}
- | '[' ']' {$$ = gc2(conPreludeList);}
- | qconid {$$ = gc1($1);}
+qname : qvar {$$ = $1;}
+ | qcon {$$ = $1;}
;
/*- Import declarations: --------------------------------------------------*/
;
imports : /* empty */ {$$ = gc0(NIL);}
| ',' {$$ = gc1(NIL);}
- | imports1 {$$ = gc1($1);}
+ | imports1 {$$ = $1;}
| imports1 ',' {$$ = gc2($1);}
;
imports1 : imports1 ',' import {$$ = gc3(cons($3,$1));}
| import {$$ = gc1(singleton($1));}
;
-import : var {$$ = gc1($1);}
- | CONID {$$ = gc1($1);}
+import : var {$$ = $1;}
+ | CONID {$$ = $1;}
| CONID '(' UPTO ')' {$$ = gc4(pair($1,DOTDOT));}
| CONID '(' names ')' {$$ = gc4(pair($1,$3));}
;
names : /* empty */ {$$ = gc0(NIL);}
| ',' {$$ = gc1(NIL);}
- | names1 {$$ = gc1($1);}
+ | names1 {$$ = $1;}
| names1 ',' {$$ = gc2($1);}
;
names1 : names1 ',' name {$$ = gc3(cons($3,$1));}
| name {$$ = gc1(singleton($1));}
;
-name : var {$$ = gc1($1);}
- | con {$$ = gc1($1);}
- ;
-
-/*- Fixity declarations: --------------------------------------------------*/
-
-fixDecls : fixDecls ';' fixDecl {$$ = gc2(NIL);}
- | fixDecl {$$ = gc0(NIL);}
- ;
-fixDecl : INFIXL optdigit ops {fixDefn(LEFT_ASS,$1,$2,$3); sp-=3;}
- | INFIXR optdigit ops {fixDefn(RIGHT_ASS,$1,$2,$3);sp-=3;}
- | INFIX optdigit ops {fixDefn(NON_ASS,$1,$2,$3); sp-=3;}
- ;
-optdigit : NUMLIT {$$ = gc1(checkPrec($1));}
- | /* empty */ {$$ = gc0(mkInt(DEF_PREC));}
- ;
-ops : ops ',' op {$$ = gc3(cons($3,$1));}
- | op {$$ = gc1(cons($1,NIL));}
+name : var {$$ = $1;}
+ | con {$$ = $1;}
;
/*- Top-level declarations: -----------------------------------------------*/
topDecls : /* empty */ {$$ = gc0(NIL);}
| ';' {$$ = gc1(NIL);}
- | topDecls1 {$$ = gc1($1);}
+ | topDecls1 {$$ = $1;}
| topDecls1 ';' {$$ = gc2($1);}
;
topDecls1 : topDecls1 ';' topDecl {$$ = gc2($1);}
| TYPE tyLhs '=' type IN invars
{defTycon(6,$3,$2,
ap($4,$6),RESTRICTSYN);}
+ | TYPE error {syntaxError("type definition");}
| DATA btype2 '=' constrs deriving
{defTycon(5,$3,checkTyLhs($2),
ap(rev($4),$5),DATATYPE);}
| DATA context IMPLIES tyLhs '=' constrs deriving
{defTycon(7,$5,$4,
- ap(ap(QUAL,pair($2,rev($6))),
+ ap(qualify($2,rev($6)),
$7),DATATYPE);}
| DATA btype2 {defTycon(2,$1,checkTyLhs($2),
ap(NIL,NIL),DATATYPE);}
| DATA context IMPLIES tyLhs {defTycon(4,$1,$4,
- ap(ap(QUAL,pair($2,NIL)),
+ ap(qualify($2,NIL),
NIL),DATATYPE);}
+ | DATA error {syntaxError("data definition");}
| TNEWTYPE btype2 '=' nconstr deriving
{defTycon(5,$3,checkTyLhs($2),
ap($4,$5),NEWTYPE);}
| TNEWTYPE context IMPLIES tyLhs '=' nconstr deriving
{defTycon(7,$5,$4,
- ap(ap(QUAL,pair($2,$6)),
+ ap(qualify($2,$6),
$7),NEWTYPE);}
+ | TNEWTYPE error {syntaxError("newtype definition");}
;
-tyLhs : tyLhs varid1 {$$ = gc2(ap($1,$2));}
- | CONID {$$ = gc1($1);}
- | '[' type ']' {$$ = gc3(ap(conList,$2));}
- | '(' ')' {$$ = gc2(conUnit);}
- | '(' typeTuple ')' {$$ = gc3(buildTuple($2));}
+tyLhs : tyLhs varid {$$ = gc2(ap($1,$2));}
+ | CONID {$$ = $1;}
| error {syntaxError("type defn lhs");}
;
invars : invars ',' invar {$$ = gc3(cons($3,$1));}
| invar {$$ = gc1(cons($1,NIL));}
;
-invar : qvar COCO topType {$$ = gc3(sigdecl($2,singleton($1),
- $3));}
- | qvar {$$ = gc1($1);}
+invar : var COCO topType {$$ = gc3(sigdecl($2,singleton($1),
+ $3));}
+ | var {$$ = $1;}
;
-constrs : constrs '|' constr {$$ = gc3(cons($3,$1));}
- | constr {$$ = gc1(cons($1,NIL));}
+constrs : constrs '|' pconstr {$$ = gc3(cons($3,$1));}
+ | pconstr {$$ = gc1(cons($1,NIL));}
;
-constr : '!' btype conop bbtype {$$ = gc4(ap2($3,bang($2),$4));}
- | btype1 conop bbtype {$$ = gc3(ap2($2,$1,$3));}
- | btype2 conop bbtype {$$ = gc3(ap2($2,$1,$3));}
- | bpolyType conop bbtype {$$ = gc3(ap2($2,$1,$3));}
- | btype2 {$$ = gc1($1);}
- | btype3 {$$ = gc1($1);}
- | btype4 {$$ = gc1($1);}
+pconstr : ALL varids '.' qconstr {$$ = gc4(ap(POLYTYPE,
+ pair(rev($2),$4)));}
+ | qconstr {$$ = $1;}
+ ;
+qconstr : context IMPLIES constr {$$ = gc3(qualify($1,$3));}
+ | constr {$$ = $1;}
+ ;
+constr : '!' btype conop bbtype {$$ = gc4(ap(ap($3,bang($2)),$4));}
+ | btype1 conop bbtype {$$ = gc3(ap(ap($2,$1),$3));}
+ | btype2 conop bbtype {$$ = gc3(ap(ap($2,$1),$3));}
+ | bpolyType conop bbtype {$$ = gc3(ap(ap($2,$1),$3));}
+ | btype2 {$$ = $1;}
+ | btype3 {$$ = $1;}
+ | btype4 {$$ = $1;}
| con '{' fieldspecs '}' {$$ = gc4(ap(LABC,pair($1,rev($3))));}
- | '[' ']' {$$ = gc2(conNil);}
- | '(' ')' {$$ = gc2(conUnit);}
- | '(' typeTuple ')' {$$ = gc3(buildTuple($2));}
+ | con '{' '}' {$$ = gc3(ap(LABC,pair($1,NIL)));}
| error {syntaxError("data type definition");}
;
btype3 : btype2 '!' atype {$$ = gc3(ap($1,bang($3)));}
| btype4 '!' atype {$$ = gc3(ap($1,bang($3)));}
;
bbtype : '!' btype {$$ = gc2(bang($2));}
- | btype {$$ = gc1($1);}
- | bpolyType {$$ = gc1($1);}
+ | btype {$$ = $1;}
+ | bpolyType {$$ = $1;}
+ ;
+nconstr : pconstr {$$ = gc1(singleton($1));}
;
fieldspecs: fieldspecs ',' fieldspec {$$ = gc3(cons($3,$1));}
| fieldspec {$$ = gc1(cons($1,NIL));}
;
fieldspec : vars COCO polyType {$$ = gc3(pair(rev($1),$3));}
| vars COCO type {$$ = gc3(pair(rev($1),$3));}
- ;
-nconstr : con atype {$$ = gc2(singleton(ap($1,$2)));}
- | con bpolyType {$$ = gc2(singleton(ap($1,$2)));}
+ | vars COCO '!' type {$$ = gc4(pair(rev($1),bang($4)));}
;
deriving : /* empty */ {$$ = gc0(NIL);}
| DERIVING qconid {$$ = gc2(singleton($2));}
topDecl : TCLASS crule wherePart {classDefn(intOf($1),$2,$3); sp-=3;}
| TINSTANCE irule wherePart {instDefn(intOf($1),$2,$3); sp-=3;}
| DEFAULT '(' dtypes ')' {defaultDefn(intOf($1),$3); sp-=4;}
+ | TCLASS error {syntaxError("class declaration");}
+ | TINSTANCE error {syntaxError("instance declaration");}
+ | DEFAULT error {syntaxError("default declaration");}
;
crule : context IMPLIES btype2 {$$ = gc3(pair($1,checkPred($3)));}
| btype2 {$$ = gc1(pair(NIL,checkPred($1)));}
/*- Type expressions: -----------------------------------------------------*/
-sigType : context IMPLIES type {$$ = gc3(ap(QUAL,pair($1,$3)));}
- | type {$$ = gc1($1);}
- ;
-topType : context IMPLIES topType1 {$$ = gc3(ap(QUAL,pair($1,$3)));}
- | topType1 {$$ = gc1($1);}
+topType : context IMPLIES topType1 {$$ = gc3(qualify($1,$3));}
+ | topType1 {$$ = $1;}
;
topType1 : bpolyType ARROW topType1 {$$ = gc3(fn($1,$3));}
| btype1 ARROW topType1 {$$ = gc3(fn($1,$3));}
| btype2 ARROW topType1 {$$ = gc3(fn($1,$3));}
- | btype {$$ = gc1($1);}
+ | btype {$$ = $1;}
;
-polyType : ALL varid1s '.' sigType {$$ = gc4(ap(POLYTYPE,
+polyType : ALL varids '.' sigType {$$ = gc4(ap(POLYTYPE,
pair(rev($2),$4)));}
- | bpolyType {$$ = gc1($1);}
+ | bpolyType {$$ = $1;}
;
bpolyType : '(' polyType ')' {$$ = gc3($2);}
;
-varid1s : varid1s ',' varid1 {$$ = gc3(cons($3,$1));}
- | varid1 {$$ = gc1(cons($1,NIL));}
+varids : varids ',' varid {$$ = gc3(cons($3,$1));}
+ | varid {$$ = gc1(singleton($1));}
+ ;
+sigType : context IMPLIES type {$$ = gc3(qualify($1,$3));}
+ | type {$$ = $1;}
;
context : '(' ')' {$$ = gc2(NIL);}
| btype2 {$$ = gc1(singleton(checkPred($1)));}
| '(' btype2 ')' {$$ = gc3(singleton(checkPred($2)));}
- | '(' btypes2 ')' {$$ = gc3(checkContext($2));}
+ | '(' btypes2 ')' {$$ = gc3(checkContext(rev($2)));}
/*#if TREX*/
| lacks {$$ = gc1(singleton($1));}
- | '(' lacks1 ')' {$$ = gc3(checkContext($2));}
+ | '(' lacks1 ')' {$$ = gc3(checkContext(rev($2)));}
;
-lacks : varid1 '\\' varid1 {
+lacks : varid '\\' varid {
#if TREX
$$ = gc3(ap(mkExt(textOf($3)),$1));
#else
;
/*#endif*/
-type : type1 {$$ = gc1($1);}
- | btype2 {$$ = gc1($1);}
+type : type1 {$$ = $1;}
+ | btype2 {$$ = $1;}
;
-type1 : btype1 {$$ = gc1($1);}
+type1 : btype1 {$$ = $1;}
| btype1 ARROW type {$$ = gc3(fn($1,$3));}
| btype2 ARROW type {$$ = gc3(fn($1,$3));}
| error {syntaxError("type expression");}
;
-btype : btype1 {$$ = gc1($1);}
- | btype2 {$$ = gc1($1);}
+btype : btype1 {$$ = $1;}
+ | btype2 {$$ = $1;}
;
btype1 : btype1 atype {$$ = gc2(ap($1,$2));}
- | atype1 {$$ = gc1($1);}
+ | atype1 {$$ = $1;}
;
btype2 : btype2 atype {$$ = gc2(ap($1,$2));}
- | qconid {$$ = gc1($1);}
+ | qconid {$$ = $1;}
;
-atype : atype1 {$$ = gc1($1);}
- | qconid {$$ = gc1($1);}
+atype : atype1 {$$ = $1;}
+ | qconid {$$ = $1;}
;
-atype1 : varid1 {$$ = gc1($1);}
- | '(' ')' {$$ = gc2(conPreludeUnit);}
+atype1 : varid {$$ = $1;}
+ | '(' ')' {$$ = gc2(typeUnit);}
| '(' ARROW ')' {$$ = gc3(typeArrow);}
| '(' type1 ')' {$$ = gc3($2);}
| '(' btype2 ')' {$$ = gc3($2);}
}
| '(' tfields '|' type ')' {$$ = gc5(revOnto($2,$4));}
/*#endif*/
- | '[' type ']' {$$ = gc3(ap(conPreludeList,$2));}
- | '[' ']' {$$ = gc2(conPreludeList);}
+ | '[' type ']' {$$ = gc3(ap(typeList,$2));}
+ | '[' ']' {$$ = gc2(typeList);}
| '_' {$$ = gc1(inventVar());}
;
-tupCommas : tupCommas ',' {$$ = gc2(mkTuple(tupleOf($1)+1));}
- | ',' {$$ = gc1(mkTuple(2));}
- ;
btypes2 : btypes2 ',' btype2 {$$ = gc3(cons($3,$1));}
| btype2 ',' btype2 {$$ = gc3(cons($3,cons($1,NIL)));}
;
/*- Value declarations: ---------------------------------------------------*/
-decllist : '{' decls end {$$ = gc3($2);}
+gendecl : INFIXN optDigit ops {$$ = gc3(fixdecl($1,$3,NON_ASS,$2));}
+ | INFIXN error {syntaxError("fixity decl");}
+ | INFIXL optDigit ops {$$ = gc3(fixdecl($1,$3,LEFT_ASS,$2));}
+ | INFIXL error {syntaxError("fixity decl");}
+ | INFIXR optDigit ops {$$ = gc3(fixdecl($1,$3,RIGHT_ASS,$2));}
+ | INFIXR error {syntaxError("fixity decl");}
+ | vars COCO topType {$$ = gc3(sigdecl($2,$1,$3));}
+ | vars COCO error {syntaxError("type signature");}
;
-decls : /* empty */ {$$ = gc0(NIL);}
- | ';' {$$ = gc1(NIL);}
- | decls1 {$$ = gc1($1);}
+optDigit : NUMLIT {$$ = gc1(checkPrec($1));}
+ | /* empty */ {$$ = gc0(mkInt(DEF_PREC));}
+ ;
+ops : ops ',' op {$$ = gc3(cons($3,$1));}
+ | op {$$ = gc1(singleton($1));}
+ ;
+vars : vars ',' var {$$ = gc3(cons($3,$1));}
+ | var {$$ = gc1(singleton($1));}
+ ;
+decls : '{' decls0 end {$$ = gc3($2);}
+ | '{' decls1 end {$$ = gc3($2);}
+ ;
+decls0 : /* empty */ {$$ = gc0(NIL);}
+ | decls0 ';' {$$ = gc2($1);}
| decls1 ';' {$$ = gc2($1);}
;
-decls1 : decls1 ';' decl {$$ = gc3(cons($3,$1));}
- | decl {$$ = gc1(cons($1,NIL));}
+decls1 : decls0 decl {$$ = gc2(cons($2,$1));}
+ ;
+decl : gendecl {$$ = $1;}
+ | funlhs rhs {$$ = gc2(ap(FUNBIND,pair($1,$2)));}
+ | funlhs COCO type rhs {$$ = gc4(ap(FUNBIND,
+ pair($1,ap(RSIGN,
+ ap($4,$3)))));}
+ | pat0 rhs {$$ = gc2(ap(PATBIND,pair($1,$2)));}
+ ;
+funlhs : funlhs0 {$$ = $1;}
+ | funlhs1 {$$ = $1;}
+ | npk {$$ = $1;}
+ ;
+funlhs0 : pat10_vI varop pat0 {$$ = gc3(ap2($2,$1,$3));}
+ | infixPat varop pat0 {$$ = gc3(ap2($2,$1,$3));}
+ | NUMLIT varop pat0 {$$ = gc3(ap2($2,$1,$3));}
+ | var varop_pl pat0 {$$ = gc3(ap2($2,$1,$3));}
+ | var '+' pat0_INT {$$ = gc3(ap2(varPlus,$1,$3));}
;
-/* Sneakily using qvars to eliminate a conflict... */
-decl : qvars COCO topType {$$ = gc3(sigdecl($2,$1,$3));}
- | opExp rhs {$$ = gc2(pair($1,$2));}
+funlhs1 : '(' funlhs0 ')' apat {$$ = gc4(ap($2,$4));}
+ | '(' funlhs1 ')' apat {$$ = gc4(ap($2,$4));}
+ | '(' npk ')' apat {$$ = gc4(ap($2,$4));}
+ | var apat {$$ = gc2(ap($1,$2));}
+ | funlhs1 apat {$$ = gc2(ap($1,$2));}
;
rhs : rhs1 wherePart {$$ = gc2(letrec($2,$1));}
| error {syntaxError("declaration");}
;
rhs1 : '=' exp {$$ = gc2(pair($1,$2));}
- | gdefs {$$ = gc1(grded(rev($1)));}
+ | gdrhs {$$ = gc1(grded(rev($1)));}
;
-wherePart : WHERE decllist {$$ = gc2($2);}
- | /*empty*/ {$$ = gc0(NIL);}
+gdrhs : gdrhs gddef {$$ = gc2(cons($2,$1));}
+ | gddef {$$ = gc1(singleton($1));}
;
-gdefs : gdefs gdef {$$ = gc2(cons($2,$1));}
- | gdef {$$ = gc1(cons($1,NIL));}
+gddef : '|' exp0 '=' exp {$$ = gc4(pair($3,pair($2,$4)));}
;
-gdef : '|' exp '=' exp {$$ = gc4(pair($3,pair($2,$4)));}
+wherePart : /* empty */ {$$ = gc0(NIL);}
+ | WHERE decls {$$ = gc2($2);}
;
-vars : vars ',' var {$$ = gc3(cons($3,$1));}
- | var {$$ = gc1(cons($1,NIL));}
- ;
-qvars : qvars ',' qvar {$$ = gc3(cons($3,$1));}
- | qvar {$$ = gc1(cons($1,NIL));}
- ;
-
+/*- Patterns: -------------------------------------------------------------*/
-var : varid {$$ = gc1($1);}
- | '(' '-' ')' {$$ = gc3(varMinus);}
+pat : npk {$$ = $1;}
+ | pat_npk {$$ = $1;}
;
-varid : varid1 {$$ = gc1($1);}
- | '(' VAROP ')' {$$ = gc3($2);}
- | '(' '!' ')' {$$ = gc3(varBang);}
- | '(' '.' ')' {$$ = gc3(varDot);}
+pat_npk : pat0 COCO type {$$ = gc3(ap(ESIGN,pair($1,$3)));}
+ | pat0 {$$ = $1;}
;
-varid1 : VARID {$$ = gc1($1);}
- | HIDING {$$ = gc1(varHiding);}
- | QUALIFIED {$$ = gc1(varQualified);}
- | ASMOD {$$ = gc1(varAsMod);}
+npk : var '+' NUMLIT {$$ = gc3(ap2(varPlus,$1,$3));}
;
-qvar : qvarid {$$ = gc1($1);}
- | '(' qvarsym ')' {$$ = gc3($2);}
- | '(' '.' ')' {$$ = gc3(varDot);}
- | '(' '!' ')' {$$ = gc3(varBang);}
- | '(' '-' ')' {$$ = gc3(varMinus);}
+pat0 : var {$$ = $1;}
+ | NUMLIT {$$ = $1;}
+ | pat0_vI {$$ = $1;}
;
-qvarid : varid1 {$$ = gc1($1);}
- | QVARID {$$ = gc1($1);}
+pat0_INT : var {$$ = $1;}
+ | pat0_vI {$$ = $1;}
;
-
-op : varop {$$ = gc1($1);}
- | conop {$$ = gc1($1);}
- | '-' {$$ = gc1(varMinus);}
+pat0_vI : pat10_vI {$$ = $1;}
+ | infixPat {$$ = gc1(ap(INFIX,$1));}
;
-qop : qvarop {$$ = gc1($1);}
- | qconop {$$ = gc1($1);}
- | '-' {$$ = gc1(varMinus);}
+infixPat : '-' pat10 {$$ = gc2(ap(NEG,only($2)));}
+ | var qconop pat10 {$$ = gc3(ap(ap($2,only($1)),$3));}
+ | var qconop '-' pat10 {$$ = gc4(ap(NEG,ap2($2,only($1),$4)));}
+ | NUMLIT qconop pat10 {$$ = gc3(ap(ap($2,only($1)),$3));}
+ | NUMLIT qconop '-' pat10 {$$ = gc4(ap(NEG,ap2($2,only($1),$4)));}
+ | pat10_vI qconop pat10 {$$ = gc3(ap(ap($2,only($1)),$3));}
+ | pat10_vI qconop '-' pat10 {$$ = gc4(ap(NEG,ap2($2,only($1),$4)));}
+ | infixPat qconop pat10 {$$ = gc3(ap(ap($2,$1),$3));}
+ | infixPat qconop '-' pat10 {$$ = gc4(ap(NEG,ap(ap($2,$1),$4)));}
;
-
-varop : VAROP {$$ = gc1($1);}
- | '!' {$$ = gc1(varBang);}
- | '.' {$$ = gc1(varDot);}
- | '`' varid1 '`' {$$ = gc3($2);}
+pat10 : fpat {$$ = $1;}
+ | apat {$$ = $1;}
;
-qvarop : qvarsym {$$ = gc1($1);}
- | '!' {$$ = gc1(varBang);}
- | '.' {$$ = gc1(varDot);}
- | '`' qvarid '`' {$$ = gc3($2);}
+pat10_vI : fpat {$$ = $1;}
+ | apat_vI {$$ = $1;}
;
-qvarsym : VAROP {$$ = gc1($1);}
- | QVAROP {$$ = gc1($1);}
+fpat : fpat apat {$$ = gc2(ap($1,$2));}
+ | gcon apat {$$ = gc2(ap($1,$2));}
;
-
-con : CONID {$$ = gc1($1);}
- | '(' CONOP ')' {$$ = gc3($2);}
+apat : NUMLIT {$$ = $1;}
+ | var {$$ = $1;}
+ | apat_vI {$$ = $1;}
;
-qcon : qconid {$$ = gc1($1);}
- | '(' qconsym ')' {$$ = gc3($2);}
+apat_vI : var '@' apat {$$ = gc3(ap(ASPAT,pair($1,$3)));}
+ | gcon {$$ = $1;}
+ | qcon '{' patbinds '}' {$$ = gc4(ap(CONFLDS,pair($1,$3)));}
+ | CHARLIT {$$ = $1;}
+ | STRINGLIT {$$ = $1;}
+ | '_' {$$ = gc1(WILDCARD);}
+ | '(' pat_npk ')' {$$ = gc3($2);}
+ | '(' npk ')' {$$ = gc3($2);}
+ | '(' pats2 ')' {$$ = gc3(buildTuple($2));}
+ | '[' pats1 ']' {$$ = gc3(ap(FINLIST,rev($2)));}
+ | '~' apat {$$ = gc2(ap(LAZYPAT,$2));}
+/*#if TREX*/
+ | '(' patfields ')' {
+#if TREX
+ $$ = gc3(revOnto($2,nameNoRec));
+#else
+ $$ = gc3(NIL);
+#endif
+ }
+ | '(' patfields '|' pat ')' {$$ = gc5(revOnto($2,$4));}
+/*#endif TREX*/
;
-qconid : CONID {$$ = gc1($1);}
- | QCONID {$$ = gc1($1);}
+pats2 : pats2 ',' pat {$$ = gc3(cons($3,$1));}
+ | pat ',' pat {$$ = gc3(cons($3,singleton($1)));}
;
-qconsym : CONOP {$$ = gc1($1);}
- | QCONOP {$$ = gc1($1);}
+pats1 : pats1 ',' pat {$$ = gc3(cons($3,$1));}
+ | pat {$$ = gc1(singleton($1));}
;
-
-conop : CONOP {$$ = gc1($1);}
- | '`' CONID '`' {$$ = gc3($2);}
+patbinds : /* empty */ {$$ = gc0(NIL);}
+ | patbinds1 {$$ = gc1(rev($1));}
+ ;
+patbinds1 : patbinds1 ',' patbind {$$ = gc3(cons($3,$1));}
+ | patbind {$$ = gc1(singleton($1));}
;
-qconop : qconsym {$$ = gc1($1);}
- | '`' qconid '`' {$$ = gc3($2);}
+patbind : qvar '=' pat {$$ = gc3(pair($1,$3));}
+ | var {$$ = $1;}
+ ;
+/*#if TREX*/
+patfields : patfields ',' patfield {$$ = gc3(cons($3,$1));}
+ | patfield {$$ = gc1(singleton($1));}
;
+patfield : varid '=' pat {
+#if TREX
+ $$ = gc3(ap(mkExt(textOf($1)),$3));
+#else
+ noTREX("a pattern");
+#endif
+ }
+ ;
+/*#endif TREX*/
/*- Expressions: ----------------------------------------------------------*/
-exp : exp1 {$$ = gc1($1);}
+exp : exp_err {$$ = $1;}
| error {syntaxError("expression");}
;
-exp1 : opExp COCO sigType {$$ = gc3(ap(ESIGN,pair($1,$3)));}
- | opExp {$$ = gc1($1);}
+exp_err : exp0a COCO sigType {$$ = gc3(ap(ESIGN,pair($1,$3)));}
+ | exp0 {$$ = $1;}
+ ;
+exp0 : exp0a {$$ = $1;}
+ | exp0b {$$ = $1;}
+ ;
+exp0a : infixExpa {$$ = gc1(ap(INFIX,$1));}
+ | exp10a {$$ = $1;}
;
-opExp : opExp0 {$$ = gc1(tidyInfix($1));}
- | pfxExp {$$ = gc1($1);}
+exp0b : infixExpb {$$ = gc1(ap(INFIX,$1));}
+ | exp10b {$$ = $1;}
;
-opExp0 : opExp0 qop '-' pfxExp {$$ = gc4(ap(NEG,ap(ap($2,$1),$4)));}
- | opExp0 qop pfxExp {$$ = gc3(ap2($2,$1,$3));}
- | '-' pfxExp {$$ = gc2(ap(NEG,only($2)));}
- | pfxExp qop pfxExp {$$ = gc3(ap(ap($2,only($1)),$3));}
- | pfxExp qop '-' pfxExp {$$ = gc4(ap(NEG,
+infixExpa : infixExpa qop '-' exp10a {$$ = gc4(ap(NEG,ap(ap($2,$1),$4)));}
+ | infixExpa qop exp10a {$$ = gc3(ap(ap($2,$1),$3));}
+ | '-' exp10a {$$ = gc2(ap(NEG,only($2)));}
+ | exp10a qop '-' exp10a {$$ = gc4(ap(NEG,
ap(ap($2,only($1)),$4)));}
+ | exp10a qop exp10a {$$ = gc3(ap(ap($2,only($1)),$3));}
+ ;
+infixExpb : infixExpa qop '-' exp10b {$$ = gc4(ap(NEG,ap(ap($2,$1),$4)));}
+ | infixExpa qop exp10b {$$ = gc3(ap(ap($2,$1),$3));}
+ | '-' exp10b {$$ = gc2(ap(NEG,only($2)));}
+ | exp10a qop '-' exp10b {$$ = gc4(ap(NEG,
+ ap(ap($2,only($1)),$4)));}
+ | exp10a qop exp10b {$$ = gc3(ap(ap($2,only($1)),$3));}
+ ;
+exp10a : CASEXP exp OF '{' alts end {$$ = gc6(ap(CASE,pair($2,rev($5))));}
+ | DO '{' stmts end {$$ = gc4(ap(DOCOMP,checkDo($3)));}
+ | appExp {$$ = $1;}
;
-pfxExp : '\\' pats ARROW exp {$$ = gc4(ap(LAMBDA,
+exp10b : '\\' pats ARROW exp {$$ = gc4(ap(LAMBDA,
pair(rev($2),
pair($3,$4))));}
- | LET decllist IN exp {$$ = gc4(letrec($2,$4));}
+ | LET decls IN exp {$$ = gc4(letrec($2,$4));}
| IF exp THEN exp ELSE exp {$$ = gc6(ap(COND,triple($2,$4,$6)));}
- | CASEXP exp OF '{' alts end {$$ = gc6(ap(CASE,pair($2,rev($5))));}
- | DO '{' stmts end {$$ = gc4(ap(DOCOMP,checkDo($3)));}
- | appExp {$$ = gc1($1);}
;
-pats : pats atomic {$$ = gc2(cons($2,$1));}
- | atomic {$$ = gc1(cons($1,NIL));}
+pats : pats apat {$$ = gc2(cons($2,$1));}
+ | apat {$$ = gc1(cons($1,NIL));}
;
-appExp : appExp atomic {$$ = gc2(ap($1,$2));}
- | atomic {$$ = gc1($1);}
+appExp : appExp aexp {$$ = gc2(ap($1,$2));}
+ | aexp {$$ = $1;}
;
-atomic : qvar {$$ = gc1($1);}
- | qvar '@' atomic {$$ = gc3(ap(ASPAT,pair($1,$3)));}
- | '~' atomic {$$ = gc2(ap(LAZYPAT,$2));}
+aexp : qvar {$$ = $1;}
+ | qvar '@' aexp {$$ = gc3(ap(ASPAT,pair($1,$3)));}
+ | '~' aexp {$$ = gc2(ap(LAZYPAT,$2));}
| '_' {$$ = gc1(WILDCARD);}
- | qcon {$$ = gc1($1);}
+ | gcon {$$ = $1;}
| qcon '{' fbinds '}' {$$ = gc4(ap(CONFLDS,pair($1,$3)));}
- | atomic '{' fbinds '}' {$$ = gc4(ap(UPDFLDS,
+ | aexp '{' fbinds '}' {$$ = gc4(ap(UPDFLDS,
triple($1,NIL,$3)));}
- | '(' ')' {$$ = gc2(conPreludeUnit);}
- | NUMLIT {$$ = gc1($1);}
- | CHARLIT {$$ = gc1($1);}
- | STRINGLIT {$$ = gc1($1);}
- | REPEAT {$$ = gc1($1);}
+ | NUMLIT {$$ = $1;}
+ | CHARLIT {$$ = $1;}
+ | STRINGLIT {$$ = $1;}
+ | REPEAT {$$ = $1;}
| '(' exp ')' {$$ = gc3($2);}
| '(' exps2 ')' {$$ = gc3(buildTuple($2));}
/*#if TREX*/
#endif
}
| '(' vfields '|' exp ')' {$$ = gc5(revOnto($2,$4));}
- | RECSELID {$$ = gc1($1);}
+ | RECSELID {$$ = $1;}
/*#endif*/
| '[' list ']' {$$ = gc3($2);}
- | '(' pfxExp qop ')' {$$ = gc4(ap($3,$2));}
- | '(' qvarop atomic ')' {$$ = gc4(ap2(varFlip,$2,$3));}
- | '(' qconop atomic ')' {$$ = gc4(ap2(varFlip,$2,$3));}
- | '(' tupCommas ')' {$$ = gc3($2);}
+ | '(' exp10a qop ')' {$$ = gc4(ap($3,$2));}
+ | '(' qvarop_mi exp0 ')' {$$ = gc4(ap(ap(nameFlip,$2),$3));}
+ | '(' qconop exp0 ')' {$$ = gc4(ap(ap(nameFlip,$2),$3));}
;
exps2 : exps2 ',' exp {$$ = gc3(cons($3,$1));}
| exp ',' exp {$$ = gc3(cons($3,cons($1,NIL)));}
vfields : vfields ',' vfield {$$ = gc3(cons($3,$1));}
| vfield {$$ = gc1(singleton($1));}
;
-vfield : qvarid '=' exp {
+vfield : varid '=' exp {
#if TREX
$$ = gc3(ap(mkExt(textOf($1)),$3));
#else
}
;
/*#endif*/
-alts : alts1 {$$ = gc1($1);}
+alts : alts1 {$$ = $1;}
| alts1 ';' {$$ = gc2($1);}
;
alts1 : alts1 ';' alt {$$ = gc3(cons($3,$1));}
| alt {$$ = gc1(cons($1,NIL));}
;
-alt : opExp altRhs wherePart {$$ = gc3(pair($1,letrec($3,$2)));}
+alt : pat altRhs wherePart {$$ = gc3(pair($1,letrec($3,$2)));}
;
altRhs : guardAlts {$$ = gc1(grded(rev($1)));}
| ARROW exp {$$ = gc2(pair($1,$2));}
guardAlts : guardAlts guardAlt {$$ = gc2(cons($2,$1));}
| guardAlt {$$ = gc1(cons($1,NIL));}
;
-guardAlt : '|' opExp ARROW exp {$$ = gc4(pair($3,pair($2,$4)));}
+guardAlt : '|' exp0 ARROW exp {$$ = gc4(pair($3,pair($2,$4)));}
;
stmts : stmts1 ';' {$$ = gc2($1);}
- | stmts1 {$$ = gc1($1);}
+ | stmts1 {$$ = $1;}
;
stmts1 : stmts1 ';' stmt {$$ = gc3(cons($3,$1));}
| stmt {$$ = gc1(cons($1,NIL));}
;
-stmt : exp1 FROM exp {$$ = gc3(ap(FROMQUAL,pair($1,$3)));}
- | LET decllist {$$ = gc2(ap(QWHERE,$2));}
- | IF exp {$$ = gc2(ap(BOOLQUAL,$2));}
- | exp1 {$$ = gc1(ap(DOQUAL,$1));}
+stmt : exp_err FROM exp {$$ = gc3(ap(FROMQUAL,pair($1,$3)));}
+ | LET decls {$$ = gc2(ap(QWHERE,$2));}
+/* | IF exp {$$ = gc2(ap(BOOLQUAL,$2));}*/
+ | exp_err {$$ = gc1(ap(DOQUAL,$1));}
;
fbinds : /* empty */ {$$ = gc0(NIL);}
| fbinds1 {$$ = gc1(rev($1));}
fbinds1 : fbinds1 ',' fbind {$$ = gc3(cons($3,$1));}
| fbind {$$ = gc1(singleton($1));}
;
-fbind : var {$$ = gc1($1);}
+fbind : var {$$ = $1;}
| qvar '=' exp {$$ = gc3(pair($1,$3));}
;
/*- List Expressions: -------------------------------------------------------*/
-list : /* empty */ {$$ = gc0(conPreludeNil);}
- | exp {$$ = gc1(ap(FINLIST,cons($1,NIL)));}
+list : exp {$$ = gc1(ap(FINLIST,cons($1,NIL)));}
| exps2 {$$ = gc1(ap(FINLIST,rev($1)));}
| exp '|' quals {$$ = gc3(ap(COMP,pair($1,rev($3))));}
- | exp UPTO exp {$$ = gc3(ap2(varEnumFromTo,$1,$3));}
- | exp ',' exp UPTO {$$ = gc4(ap2(varEnumFromThen,$1,$3));}
- | exp UPTO {$$ = gc2(ap1(varEnumFrom,$1));}
- | exp ',' exp UPTO exp {$$ = gc5(ap3(varEnumFromThenTo,
- $1,$3,$5));}
+ | exp UPTO exp {$$ = gc3(ap(ap(nameFromTo,$1),$3));}
+ | exp ',' exp UPTO {$$ = gc4(ap(ap(nameFromThen,$1),$3));}
+ | exp UPTO {$$ = gc2(ap(nameFrom,$1));}
+ | exp ',' exp UPTO exp {$$ = gc5(ap(ap(ap(nameFromThenTo,
+ $1),$3),$5));}
;
quals : quals ',' qual {$$ = gc3(cons($3,$1));}
| qual {$$ = gc1(cons($1,NIL));}
;
qual : exp FROM exp {$$ = gc3(ap(FROMQUAL,pair($1,$3)));}
| exp {$$ = gc1(ap(BOOLQUAL,$1));}
- | LET decllist {$$ = gc2(ap(QWHERE,$2));}
+ | LET decls {$$ = gc2(ap(QWHERE,$2));}
+ ;
+
+/*- Identifiers and symbols: ----------------------------------------------*/
+
+gcon : qcon {$$ = $1;}
+ | '(' ')' {$$ = gc2(nameUnit);}
+ | '[' ']' {$$ = gc2(nameNil);}
+ | '(' tupCommas ')' {$$ = gc3($2);}
+ ;
+tupCommas : tupCommas ',' {$$ = gc2(mkTuple(tupleOf($1)+1));}
+ | ',' {$$ = gc1(mkTuple(2));}
+ ;
+varid : VARID {$$ = $1;}
+ | HIDING {$$ = gc1(varHiding);}
+ | QUALIFIED {$$ = gc1(varQualified);}
+ | ASMOD {$$ = gc1(varAsMod);}
+ ;
+qconid : QCONID {$$ = $1;}
+ | CONID {$$ = $1;}
+ ;
+var : varid {$$ = $1;}
+ | '(' VAROP ')' {$$ = gc3($2);}
+ | '(' '+' ')' {$$ = gc3(varPlus);}
+ | '(' '-' ')' {$$ = gc3(varMinus);}
+ | '(' '!' ')' {$$ = gc3(varBang);}
+ | '(' '.' ')' {$$ = gc3(varDot);}
+ ;
+qvar : QVARID {$$ = $1;}
+ | '(' QVAROP ')' {$$ = gc3($2);}
+ | var {$$ = $1;}
+ ;
+con : CONID {$$ = $1;}
+ | '(' CONOP ')' {$$ = gc3($2);}
+ ;
+qcon : QCONID {$$ = $1;}
+ | '(' QCONOP ')' {$$ = gc3($2);}
+ | con {$$ = $1;}
+ ;
+varop : '+' {$$ = gc1(varPlus);}
+ | '-' {$$ = gc1(varMinus);}
+ | varop_mipl {$$ = $1;}
+ ;
+varop_mi : '+' {$$ = gc1(varPlus);}
+ | varop_mipl {$$ = $1;}
+ ;
+varop_pl : '-' {$$ = gc1(varMinus);}
+ | varop_mipl {$$ = $1;}
+ ;
+varop_mipl: VAROP {$$ = $1;}
+ | '`' varid '`' {$$ = gc3($2);}
+ | '!' {$$ = gc1(varBang);}
+ | '.' {$$ = gc1(varDot);}
+ ;
+qvarop : '-' {$$ = gc1(varMinus);}
+ | qvarop_mi {$$ = $1;}
+ ;
+qvarop_mi : QVAROP {$$ = $1;}
+ | '`' QVARID '`' {$$ = gc3($2);}
+ | varop_mi {$$ = $1;}
+ ;
+
+conop : CONOP {$$ = $1;}
+ | '`' CONID '`' {$$ = gc3($2);}
+ ;
+qconop : QCONOP {$$ = $1;}
+ | '`' QCONID '`' {$$ = gc3($2);}
+ | conop {$$ = $1;}
+ ;
+op : varop {$$ = $1;}
+ | conop {$$ = $1;}
+ ;
+qop : qvarop {$$ = $1;}
+ | qconop {$$ = $1;}
+ ;
+
+/*- Stuff from STG hugs ---------------------------------------------------*/
+
+qvarid : varid1 {$$ = gc1($1);}
+ | QVARID {$$ = gc1($1);}
+
+varid1 : VARID {$$ = gc1($1);}
+ | HIDING {$$ = gc1(varHiding);}
+ | QUALIFIED {$$ = gc1(varQualified);}
+ | ASMOD {$$ = gc1(varAsMod);}
;
/*- Tricks to force insertion of leading and closing braces ---------------*/
begin : error {yyerrok; goOffside(startColumn);}
;
/* deal with trailing semicolon */
-end : '}' {$$ = gc1($1);}
+end : '}' {$$ = $1;}
| error {yyerrok;
if (canUnOffside()) {
unOffside();
return e;
}
-static Void local syntaxError(s) /* report on syntax error */
+static Void local syntaxError(s) /* report on syntax error */
String s; {
ERRMSG(row) "Syntax error in %s (unexpected %s)", s, unexpected()
EEND;
#define keyword(kw) sprintf(buffer,fmt,kwd,kw); return buffer;
case INFIXL : keyword("infixl");
case INFIXR : keyword("infixr");
- case INFIX : keyword("infix");
+ case INFIXN : keyword("infix");
case FOREIGN : keyword("foreign");
case UNSAFE : keyword("unsafe");
case TINSTANCE : keyword("instance");
case DERIVING : keyword("deriving");
case DEFAULT : keyword("default");
case IMPORT : keyword("import");
- case EXPORT : keyword("export");
- case MODULETOK : keyword("module");
- case INTERFACE : keyword("interface");
- case WILDCARD : keyword("_");
+ case TMODULE : keyword("module");
case ALL : keyword("forall");
#undef keyword
}
}
-static Cell local checkPrec(p) /* Check for valid precedence value */
+static Cell local checkPrec(p) /* Check for valid precedence value*/
Cell p; {
- if ((!isInt(p) || intOf(p)<MIN_PREC || intOf(p)>MAX_PREC)
- && (!isBignum(p) || bignumOf(p)<MIN_PREC || bignumOf(p)>MAX_PREC)
- ) {
+ if (!isInt(p) || intOf(p)<MIN_PREC || intOf(p)>MAX_PREC) {
ERRMSG(row) "Precedence value must be an integer in the range [%d..%d]",
MIN_PREC, MAX_PREC
EEND;
}
- if (isBignum(p)) {
- return mkInt(bignumOf(p));
- } else {
- return p;
- }
-}
-
-static Void local fixDefn(a,line,p,ops)/* Declare syntax of operators */
-Syntax a;
-Cell line;
-Cell p;
-List ops; {
- Int l = intOf(line);
- a = mkSyntax(a,intOf(p));
- map2Proc(setSyntax,l,a,ops);
+ return p;
}
-static Void local setSyntax(line,sy,op)/* set syntax of individ. operator */
-Int line;
-Syntax sy;
-Cell op; {
- addSyntax(line,textOf(op),sy);
- opDefns = cons(op,opDefns);
-}
-
-static Cell local buildTuple(tup) /* build tuple (x1,...,xn) from list*/
-List tup; { /* [xn,...,x1] */
+static Cell local buildTuple(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 */
+ 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;
}
ERRMSG(row) "Illegal left hand side in datatype definition"
EEND;
}
+ assert(0); return 0; /* NOTREACHED */
}
#if !TREX
static Void local noTREX(where)
String where; {
- ERRMSG(row) "Attempt to use Typed Records with Extensions\nwhile parsing %s. This feature is disabled in this build of Hugs.",
- where
+ ERRMSG(row) "Attempt to use TREX records while parsing %s.\n", where ETHEN
+ ERRTEXT "(TREX is disabled in this build of Hugs)"
EEND;
}
#endif
-/* Expressions involving infix operators or unary minus are parsed as elements
- * of the following type:
- *
- * data OpExp = Only Exp | Neg OpExp | Infix OpExp Op Exp
- *
- * (The algorithms here do not assume that negation can be applied only once,
- * i.e., that - - x is a syntax error, as required by the Haskell report.
- * Instead, that restriction is captured by the grammar itself, given above.)
- *
- * There are rules of precedence and grouping, expressed by two functions:
- *
- * prec :: Op -> Int; assoc :: Op -> Assoc (Assoc = {L, N, R})
- *
- * OpExp values are rearranged accordingly when a complete expression has
- * been read using a simple shift-reduce parser whose result may be taken
- * to be a value of the following type:
- *
- * data Exp = Atom Int | Negate Exp | Apply Op Exp Exp | Error String
- *
- * The machine on which this parser is based can be defined as follows:
- *
- * tidy :: OpExp -> [(Op,Exp)] -> Exp
- * tidy (Only a) [] = a
- * tidy (Only a) ((o,b):ss) = tidy (Only (Apply o a b)) ss
- * tidy (Infix a o b) [] = tidy a [(o,b)]
- * tidy (Infix a o b) ((p,c):ss)
- * | shift o p = tidy a ((o,b):(p,c):ss)
- * | red o p = tidy (Infix a o (Apply p b c)) ss
- * | ambig o p = Error "ambiguous use of operators"
- * tidy (Neg e) [] = tidy (tidyNeg e) []
- * tidy (Neg e) ((o,b):ss)
- * | nshift o = tidy (Neg (underNeg o b e)) ss
- * | nred o = tidy (tidyNeg e) ((o,b):ss)
- * | nambig o = Error "illegal use of negation"
- *
- * At each stage, the parser can either shift, reduce, accept, or error.
- * The transitions when dealing with juxtaposed operators o and p are
- * determined by the following rules:
- *
- * shift o p = (prec o > prec p)
- * || (prec o == prec p && assoc o == L && assoc p == L)
- *
- * red o p = (prec o < prec p)
- * || (prec o == prec p && assoc o == R && assoc p == R)
- *
- * ambig o p = (prec o == prec p)
- * && (assoc o == N || assoc p == N || assoc o /= assoc p)
- *
- * The transitions when dealing with juxtaposed unary minus and infix operators
- * are as follows. The precedence of unary minus (infixl 6) is hardwired in
- * to these definitions, as it is to the definitions of the Haskell grammar
- * in the official report.
- *
- * nshift o = (prec o > 6)
- * nred o = (prec o < 6) || (prec o == 6 && assoc o == L)
- * nambig o = prec o == 6 && (assoc o == R || assoc o == N)
- *
- * An OpExp of the form (Neg e) means negate the last thing in the OpExp e;
- * we can force this negation using:
- *
- * tidyNeg :: OpExp -> OpExp
- * tidyNeg (Only e) = Only (Negate e)
- * tidyNeg (Infix a o b) = Infix a o (Negate b)
- * tidyNeg (Neg e) = tidyNeg (tidyNeg e)
- *
- * On the other hand, if we want to sneak application of an infix operator
- * under a negation, then we use:
- *
- * underNeg :: Op -> Exp -> OpExp -> OpExp
- * underNeg o b (Only e) = Only (Apply o e b)
- * underNeg o b (Neg e) = Neg (underNeg o b e)
- * underNeg o b (Infix e p f) = Infix e p (Apply o f b)
- *
- * As a concession to efficiency, we lower the number of calls to syntaxOf
- * by keeping track of the values of sye, sys throughout the process. The
- * value APPLIC is used to indicate that the syntax value is unknown.
- */
-
-#define UMINUS_PREC 6 /* Change these settings at your */
-#define UMINUS_ASSOC LEFT_ASS /* own risk; they may not work! */
-
-static Cell local tidyInfix(e) /* convert OpExp to Expr */
-Cell e; { /* :: OpExp */
- Cell s = NIL; /* :: [(Op,Exp)] */
- Syntax sye = APPLIC; /* Syntax of op in e (init unknown)*/
- Syntax sys = APPLIC; /* Syntax of op in s (init unknown)*/
-
- for (;;)
- switch (whatIs(e)) {
- case ONLY : e = snd(e);
- while (nonNull(s)) {
- Cell next = arg(fun(s));
- arg(fun(s)) = e;
- e = s;
- s = next;
- }
- return e;
-
- case NEG : if (nonNull(s)) {
-
- if (sys==APPLIC) { /* calculate sys */
- sys = identSyntax(fun(fun(s)));
- if (sys==APPLIC) sys=DEF_OPSYNTAX;
- }
-
- if (precOf(sys)==UMINUS_PREC && /* nambig */
- assocOf(sys)!=UMINUS_ASSOC) {
- ERRMSG(row)
- "Ambiguous use of unary minus with \"%s\"",
- textToStr(textOf(fun(fun(s))))
- EEND;
- }
-
- if (precOf(sys)>UMINUS_PREC) { /* nshift */
- Cell e1 = snd(e);
- Cell t = s;
- s = arg(fun(s));
- while (whatIs(e1)==NEG)
- e1 = snd(e1);
- arg(fun(t)) = arg(e1);
- arg(e1) = t;
- sys = APPLIC;
- continue;
- }
-
- }
-
- /* Intentional fall-thru for nreduce and isNull(s) */
- { Cell prev = e; /* e := tidyNeg e */
- Cell temp = arg(prev);
- Int nneg = 1;
- for (; whatIs(temp)==NEG; nneg++) {
- fun(prev) = varNegate;
- prev = temp;
- temp = arg(prev);
- }
- /* These special cases are required for
- * pattern matching.
- */
- if (isInt(arg(temp))) { /* special cases */
- if (nneg&1) /* for literals */
- arg(temp) = intNegate(arg(temp));
- }
- else if (isBignum(arg(temp))) {
- if (nneg&1)
- arg(temp) = bignumNegate(arg(temp));
- }
- else if (isFloat(arg(temp))) {
- if (nneg&1)
- arg(temp) = floatNegate(arg(temp));
- }
- else {
- fun(prev) = varNegate;
- arg(prev) = arg(temp);
- arg(temp) = e;
- }
- e = temp;
- }
- continue;
-
- default : if (isNull(s)) {/* Move operation onto empty stack */
- Cell next = arg(fun(e));
- s = e;
- arg(fun(s)) = NIL;
- e = next;
- sys = sye;
- sye = APPLIC;
- }
- else { /* deal with pair of operators */
-
- if (sye==APPLIC) { /* calculate sys and sye */
- sye = identSyntax(fun(fun(e)));
- if (sye==APPLIC) sye=DEF_OPSYNTAX;
- }
- if (sys==APPLIC) {
- sys = identSyntax(fun(fun(s)));
- if (sys==APPLIC) sys=DEF_OPSYNTAX;
- }
-
- if (precOf(sye)==precOf(sys) && /* ambig */
- (assocOf(sye)!=assocOf(sys) ||
- assocOf(sye)==NON_ASS)) {
- ERRMSG(row)
- "Ambiguous use of operator \"%s\" with \"%s\"",
- textToStr(textOf(fun(fun(e)))),
- textToStr(textOf(fun(fun(s))))
- EEND;
- }
-
- if (precOf(sye)>precOf(sys) || /* shift */
- (precOf(sye)==precOf(sys) &&
- assocOf(sye)==LEFT_ASS &&
- assocOf(sys)==LEFT_ASS)) {
- Cell next = arg(fun(e));
- arg(fun(e)) = s;
- s = e;
- e = next;
- sys = sye;
- sye = APPLIC;
- }
- else { /* reduce */
- Cell next = arg(fun(s));
- arg(fun(s)) = arg(e);
- arg(e) = s;
- s = next;
- sys = APPLIC;
- /* sye unchanged */
- }
- }
- continue;
- }
-}
-
/*-------------------------------------------------------------------------*/
-/* -*- mode: hugs-c; -*- */
+
/* --------------------------------------------------------------------------
- * preds.c: Copyright (c) Mark P Jones 1991-1998. All rights reserved.
- * See NOTICE for details and conditions of use etc...
- * Hugs version 1.3c, March 1998
+ * Part of the type checker dealing with predicates and entailment
+ *
+ * Hugs 98 is Copyright (c) Mark P Jones, Alastair Reid and the Yale
+ * Haskell Group 1994-99, and is distributed as Open Source software
+ * under the Artistic License; see the file "Artistic" that is included
+ * in the distribution for details.
*
- * Part of type checker dealing with predicates and entailment.
+ * $RCSfile: preds.c,v $
+ * $Revision: 1.3 $
+ * $Date: 1999/02/03 17:08:35 $
* ------------------------------------------------------------------------*/
/* --------------------------------------------------------------------------
static Cell local qualifyExpr Args((Int,List,Cell));
static Void local overEvid Args((Cell,Cell));
-static Cell local scFind Args((Cell,Cell,Int,Cell,Int));
-static Cell local scEntail Args((List,Cell,Int));
-static Cell local entail Args((List,Cell,Int));
-static Cell local inEntail Args((List,Cell,Int));
+static Void local cutoffExceeded Args((Cell,Int,Cell,Int,List));
+static Cell local scFind Args((Cell,Cell,Int,Cell,Int,Int));
+static Cell local scEntail Args((List,Cell,Int,Int));
+static Cell local entail Args((List,Cell,Int,Int));
+static Cell local inEntail Args((List,Cell,Int,Int));
#if TREX
static Cell local lacksNorm Args((Type,Int,Cell));
#endif
*
* ------------------------------------------------------------------------*/
-static Cell local scFind(e,pi1,o1,pi,o) /* Use superclass entailment to */
+Int cutoff = 16; /* Used to limit depth of recursion*/
+
+static Void local cutoffExceeded(pi,o,pi1,o1,ps)
+Cell pi, pi1; /* Display error msg when cutoff */
+Int o, o1;
+List ps; {
+ clearMarks();
+ ERRMSG(0)
+ "\n*** The type checker has reached the cutoff limit while trying to\n"
+ ETHEN ERRTEXT
+ "*** determine whether:\n*** " ETHEN ERRPRED(copyPred(pi,o));
+ ps = (isNull(pi1)) ? copyPreds(ps) : singleton(copyPred(pi1,o1));
+ ERRTEXT
+ "\n*** can be deduced from:\n*** " ETHEN ERRCONTEXT(ps);
+ ERRTEXT
+ "\n*** This may indicate that the problem is undecidable. However,\n"
+ ETHEN ERRTEXT
+ "*** you may still try to increase the cutoff limit using the -c\n"
+ ETHEN ERRTEXT
+ "*** option and then try again. (The current setting is -c%d)\n",
+ cutoff
+ EEND;
+}
+
+static Cell local scFind(e,pi1,o1,pi,o,d)/* Use superclass entailment to */
Cell e; /* find evidence for (pi,o) using */
Cell pi1; /* the evidence e for (pi1,o1). */
Int o1;
Cell pi;
-Int o; {
+Int o;
+Int d; {
Class h1 = getHead(pi1);
Class h = getHead(pi);
List dsels = cclass(h1).dsels;
if (!matchPred(pi1,o1,cclass(h1).head,beta))
internal("scFind");
+
+ if (d++ >= cutoff)
+ cutoffExceeded(pi,o,pi1,o1,NIL);
+
for (; nonNull(scs); scs=tl(scs), dsels=tl(dsels)) {
- Cell ev = scFind(ap(hd(dsels),e),hd(scs),beta,pi,o);
+ Cell ev = scFind(ap(hd(dsels),e),hd(scs),beta,pi,o,d);
if (nonNull(ev))
return ev;
}
return NIL;
}
-static Cell local scEntail(ps,pi,o) /* Calc evidence for (pi,o) from ps*/
+static Cell local scEntail(ps,pi,o,d) /* Calc evidence for (pi,o) from ps*/
List ps; /* Using superclasses and equality.*/
Cell pi;
-Int o; {
+Int o;
+Int d; {
for (; nonNull(ps); ps=tl(ps)) {
Cell pi1 = hd(ps);
- Cell ev = scFind(thd3(pi1),fst3(pi1),intOf(snd3(pi1)),pi,o);
+ Cell ev = scFind(thd3(pi1),fst3(pi1),intOf(snd3(pi1)),pi,o,d);
if (nonNull(ev))
return ev;
}
* to cause any further concern, except in pathological cases.)
* ------------------------------------------------------------------------*/
-static Cell local entail(ps,pi,o) /* Calc evidence for (pi,o) from ps*/
+static Cell local entail(ps,pi,o,d) /* Calc evidence for (pi,o) from ps*/
List ps; /* Uses superclasses, equality, */
Cell pi; /* tautology, and construction */
-Int o; {
- Cell ev = scEntail(ps,pi,o);
- return nonNull(ev) ? ev : inEntail(ps,pi,o);
+Int o;
+Int d; {
+ Cell ev = scEntail(ps,pi,o,d);
+ return nonNull(ev) ? ev : inEntail(ps,pi,o,d);
}
-static Cell local inEntail(ps,pi,o) /* Calc evidence for (pi,o) from ps*/
+static Cell local inEntail(ps,pi,o,d) /* Calc evidence for (pi,o) from ps*/
List ps; /* using a top-level instance */
Cell pi; /* entailment */
-Int o; {
+Int o;
+Int d; {
#if TREX
if (isAp(pi) && isExt(fun(pi))) { /* Lacks predicates */
Cell e = fun(pi);
else {
#endif
Inst in = findInstFor(pi,o); /* Class predicates */
+
if (nonNull(in)) {
Int beta = typeOff;
- Cell d = inst(in).builder;
- Cell ds = inst(in).specifics;
- for (; nonNull(ds); ds=tl(ds)) {
- Cell ev = entail(ps,hd(ds),beta);
+ Cell e = inst(in).builder;
+ Cell es = inst(in).specifics;
+ if (d++ >= cutoff)
+ cutoffExceeded(pi,o,NIL,0,ps);
+ for (; nonNull(es); es=tl(es)) {
+ Cell ev = entail(ps,hd(es),beta,d);
if (nonNull(ev))
- d = ap(d,ev);
+ e = ap(e,ev);
else
return NIL;
}
- return d;
+ return e;
}
return NIL;
#if TREX
emptySubstitution();
beta = newKindedVars(ks); /* (ks provides kinds for any */
ps = makePredAss(ps,beta); /* vars that appear in pi.) */
- ev = entail(ps,pi,beta);
+ ev = entail(ps,pi,beta,0);
emptySubstitution();
return ev;
}
while (0<n--) {
Cell pi = hd(qs);
- Cell ev = scEntail(tl(qs),fst3(pi),intOf(snd3(pi)));
+ Cell ev = scEntail(tl(qs),fst3(pi),intOf(snd3(pi)),0);
if (nonNull(ev)) {
overEvid(thd3(pi),ev); /* Overwrite dict var with evidence*/
qs = tl(qs); /* ... and discard predicate */
* ------------------------------------------------------------------------*/
static Void local elimTauts() { /* Remove tautological constraints */
- List ps = preds; /* from preds */
- preds = NIL;
- while (nonNull(ps)) {
- Cell pi = hd(ps);
- Cell ev = entail(NIL,fst3(pi),intOf(snd3(pi)));
- if (nonNull(ev)) {
- overEvid(thd3(pi),ev);
- ps = tl(ps);
- }
- else {
- List tmp = tl(ps);
- tl(ps) = preds;
- preds = ps;
- ps = tmp;
+ if (haskell98) { /* from preds */
+ reducePreds(); /* (or context reduce for Hask98) */
+ } else {
+ List ps = preds;
+ preds = NIL;
+ while (nonNull(ps)) {
+ Cell pi = hd(ps);
+ Cell ev = entail(NIL,fst3(pi),intOf(snd3(pi)),0);
+ if (nonNull(ev)) {
+ overEvid(thd3(pi),ev);
+ ps = tl(ps);
+ }
+ else {
+ List tmp = tl(ps);
+ tl(ps) = preds;
+ preds = ps;
+ ps = tmp;
+ }
}
}
}
Cell p = preds;
Cell pi = fst3(hd(p));
Int o = intOf(snd3(hd(p)));
- Cell ev = entail(ps,pi,o);
+ Cell ev = entail(ps,pi,o,0);
preds = tl(preds);
if (nonNull(ev)) /* Discharge if ps ||- (pi,o) */
Bool defaulted = FALSE;
#ifdef DEBUG_DEFAULTS
- printf("Attempt to resolve variables ");
+ Printf("Attempt to resolve variables ");
printExp(stdout,vs);
- printf(" with context ");
+ Printf(" with context ");
printContext(stdout,copyPreds(preds));
- printf("\n");
+ Printf("\n");
#endif
resetGenerics(); /* find type variables in ps */
Int vn = intOf(hd(pvs));
#ifdef DEBUG_DEFAULTS
- printf("is var %d included in ",vn);
+ Printf("is var %d included in ",vn);
printExp(stdout,vs);
- printf("?\n");
+ Printf("?\n");
#endif
if (!intIsMember(vn,vs))
defaulted |= resolveVar(vn);
#ifdef DEBUG_DEFAULTS
else
- printf("Yes, so no ambiguity!\n");
+ Printf("Yes, so no ambiguity!\n");
#endif
}
*/
#ifdef DEBUG_DEFAULTS
- printf("Trying to default variable %d\n",vn);
+ Printf("Trying to default variable %d\n",vn);
#endif
for (; nonNull(ps); ps=tl(ps)) {
else if (c!=classEq && c!=classOrd && c!=classShow &&
c!=classRead && c!=classIx && c!=classEnum &&
#if EVAL_INSTANCES
- c!=classEval &&
+ c!=classEval &&
#endif
c!=classBounded)
return FALSE;
if (aNumClass) {
List ds = defaultDefns; /* N.B. guaranteed to be monotypes */
#ifdef DEBUG_DEFAULTS
- printf("Default conditions met, looking for type\n");
+ Printf("Default conditions met, looking for type\n");
#endif
for (; nonNull(ds); ds=tl(ds)) {
List cs1 = cs;
- while (nonNull(cs1) && nonNull(entail(NIL,ap(hd(cs1),hd(ds)),0)))
+ while (nonNull(cs1) && nonNull(entail(NIL,ap(hd(cs1),hd(ds)),0,0)))
cs1 = tl(cs1);
if (isNull(cs1)) {
bindTv(vn,hd(ds),0);
#ifdef DEBUG_DEFAULTS
- printf("Default type for variable %d is ",vn);
+ Printf("Default type for variable %d is ",vn);
printType(stdout,hd(ds));
- printf("\n");
+ Printf("\n");
#endif
return TRUE;
}
}
#ifdef DEBUG_DEFAULTS
- printf("No default permitted/found\n");
+ Printf("No default permitted/found\n");
#endif
return FALSE;
}
-/* -*- mode: hugs-c; -*- */
+
/* --------------------------------------------------------------------------
* Basic data type definitions, prototypes and standard macros including
* machine dependent variations...
* Hugs version 1.4, December 1997
*
* $RCSfile: prelude.h,v $
- * $Revision: 1.2 $
- * $Date: 1998/12/02 13:22:33 $
+ * $Revision: 1.3 $
+ * $Date: 1999/02/03 17:08:36 $
* ------------------------------------------------------------------------*/
#include "config.h"
typedef unsigned Bool;
#define TRUE 1
#define FALSE 0
-typedef char *String;
-typedef int Int;
-typedef long Long;
-typedef int Char;
-typedef unsigned int Word; /* at least 32 bits */
-typedef void* Ptr;
-typedef void* Addr;
-typedef Word* HpPtr;
+
+typedef char *String;
+typedef int Int;
+typedef long Long;
+typedef int Char;
+typedef unsigned int Unsigned; /* at least 32 bits */
+typedef void* Ptr;
+typedef void* Addr;
+typedef void* HpPtr;
+
+#define FloatImpType double
+#define FloatPro double
+#define FloatFMT "%.9g"
+
/* ToDo: this should probably go in dynamic.h - but then
* storage.h has to include dynamic.h!
-/* -*- mode: hugs-c; -*- */
+
/* --------------------------------------------------------------------------
* Strongly connected components algorithm for static.c.
*
- * 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
+ * Hugs 98 is Copyright (c) Mark P Jones, Alastair Reid and the Yale
+ * Haskell Group 1994-99, and is distributed as Open Source software
+ * under the Artistic License; see the file "Artistic" that is included
+ * in the distribution for details.
*
* $RCSfile: scc.c,v $
- * $Revision: 1.2 $
- * $Date: 1998/12/02 13:22:34 $
+ * $Revision: 1.3 $
+ * $Date: 1999/02/03 17:08:36 $
* ------------------------------------------------------------------------*/
#ifndef SCC_C
#define SCC_C
-#define visited(d) (isInt(DEPENDS(d))) /* binding already visited ? */
+#define visited(d) (isInt(DEPENDS(d))) /* binding already visited?*/
static Cell daSccs = NIL;
static Int daCount;
static Int local sccMin Args((Int,Int));
-static Int local sccMin(x,y) /* calculate minimum of x,y (unless */
-Int x,y; { /* y is zero) */
+static Int local sccMin(x,y) /* calculate minimum of x,y */
+Int x, y; { /* (unless y is zero) */
return (x<=y || y==0) ? x : y;
}
#endif
-/* -*- mode: hugs-c; -*- */
+
/* --------------------------------------------------------------------------
* Static Analysis for Hugs
*
- * 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
+ * Hugs 98 is Copyright (c) Mark P Jones, Alastair Reid and the Yale
+ * Haskell Group 1994-99, and is distributed as Open Source software
+ * under the Artistic License; see the file "Artistic" that is included
+ * in the distribution for details.
*
* $RCSfile: static.c,v $
- * $Revision: 1.2 $
- * $Date: 1998/12/02 13:22:35 $
+ * $Revision: 1.3 $
+ * $Date: 1999/02/03 17:08:37 $
* ------------------------------------------------------------------------*/
#include "prelude.h"
#include "storage.h"
+#include "backend.h"
#include "connect.h"
-#include "input.h"
-#include "type.h"
-#include "static.h"
-#include "translate.h"
-#include "hugs.h" /* for target */
#include "errors.h"
#include "subst.h"
-#include "link.h"
-#include "modules.h"
-#include "derive.h"
/* --------------------------------------------------------------------------
* local function prototypes:
* ------------------------------------------------------------------------*/
-static Module thisModule = 0; /* module currently being processed*/
-
-static Void local kindError Args((Int,Constr,Constr,String,Kind,Int));
+static Void local kindError Args((Int,Constr,Constr,String,Kind,Int));
+#if !IGNORE_MODULES
+static Void local checkQualImport Args((Pair));
+static Void local checkUnqualImport Args((Triple));
+
+static Name local lookupName Args((Text,List));
+static List local checkSubentities Args((List,List,List,String,Text));
+static List local checkExportTycon Args((List,Text,Cell,Tycon));
+static List local checkExportClass Args((List,Text,Cell,Class));
+static List local checkExport Args((List,Text,Cell));
+static List local checkImportEntity Args((List,Module,Cell));
+static List local resolveImportList Args((Module,Cell));
+static Void local checkImportList Args((Pair));
+
+static Void local importEntity Args((Module,Cell));
+static Void local importName Args((Module,Name));
+static Void local importTycon Args((Module,Tycon));
+static Void local importClass Args((Module,Class));
+static List local checkExports Args((List));
+#endif
-static Void local checkTyconDefn Args((Tycon));
-static Void local depConstrs Args((Tycon,List,Cell));
-static List local addSels Args((Int,Name,List,List));
-static List local selectCtxt Args((List,List));
-static Void local checkSynonyms Args((List));
-static List local visitSyn Args((List,Tycon,List));
+static Void local checkTyconDefn Args((Tycon));
+static Void local depConstrs Args((Tycon,List,Cell));
+static List local addSels Args((Int,Name,List,List));
+static List local selectCtxt Args((List,List));
+static Void local checkSynonyms Args((List));
+static List local visitSyn Args((List,Tycon,List));
#if EVAL_INSTANCES
-static Void local deriveEval Args((List));
-static List local calcEvalContexts Args((Tycon,List,List));
+static Void local deriveEval Args((List));
+static List local calcEvalContexts Args((Tycon,List,List));
+static Void local checkBanged Args((Name,Kinds,List,Type));
#endif
-static Void local checkBanged Args((Name,Kinds,List,Type));
-static Type local instantiateSyn Args((Type,Type));
-
-static Void local checkClassDefn Args((Class));
-static Void local depPredExp Args((Int,List,Cell));
-static Void local checkMems Args((Class,List,Cell));
-static Void local addMembers Args((Class));
-static Name local newMember Args((Int,Int,Cell,Type));
-static Name local newDSel Args((Class,Int));
-static Name local newDBuild Args((Class));
-static Text local generateText Args((String, Class));
-static Int local visitClass Args((Class));
-
-static List local classBindings Args((String,Class,List));
-static Name local memberName Args((Class,Text));
-static List local numInsert Args((Int,Cell,List));
-
-static List local typeVarsIn Args((Cell,List,List));
-static List local maybeAppendVar Args((Cell,List));
-
-static Type local checkSigType Args((Int,String,Cell,Type));
-static Type local depTopType Args((Int,List,Type));
-static Type local depCompType Args((Int,List,Type));
-static Type local depTypeExp Args((Int,List,Type));
-static Type local depTypeVar Args((Int,List,Text));
-static Void local kindConstr Args((Int,Int,Int,Constr));
-static Kind local kindAtom Args((Int,Constr));
-static Void local kindPred Args((Int,Int,Int,Cell));
-static Void local kindType Args((Int,String,Type));
-static Void local fixKinds Args((Void));
-
-static Void local kindTCGroup Args((List));
-static Void local initTCKind Args((Cell));
-static Void local kindTC Args((Cell));
-static Void local genTC Args((Cell));
-
-static Void local checkInstDefn Args((Inst));
-static Void local insertInst Args((Inst));
-static Bool local instCompare Args((Inst,Inst));
-static Name local newInstImp Args((Inst));
-static Void local kindInst Args((Inst,Int));
-static Void local checkDerive Args((Tycon,List,List,Cell));
-static Void local addDerInst Args((Int,Class,List,List,Type,Int));
-
-static Void local deriveContexts Args((List));
-static Void local initDerInst Args((Inst));
-static Void local calcInstPreds Args((Inst));
-static Void local maybeAddPred Args((Cell,Int,Int,List));
-static Cell local copyAdj Args((Cell,Int,Int));
-static Void local tidyDerInst Args((Inst));
-
-static Void local addDerivImp Args((Inst));
-
-static Void local checkDefaultDefns Args((Void));
-
-static Void local checkForeignImport Args((Name));
-static Void local checkForeignExport Args((Name));
-
-static Cell local checkPat Args((Int,Cell));
-static Cell local checkMaybeCnkPat Args((Int,Cell));
-static Cell local checkApPat Args((Int,Int,Cell));
-static Void local addPatVar Args((Int,Cell));
-static Name local conDefined Args((Int,Cell));
-static Void local checkIsCfun Args((Int,Name));
-static Void local checkCfunArgs Args((Int,Cell,Int));
-static Cell local applyBtyvs Args((Cell));
-static Cell local bindPat Args((Int,Cell));
-static Void local bindPats Args((Int,List));
-
-static List local extractSigdecls Args((List));
-static List local extractBindings Args((List));
-static List local eqnsToBindings Args((List));
-static Void local notDefined Args((Int,List,Cell));
-static Cell local findBinding Args((Text,List));
-static Void local addSigDecl Args((List,Cell));
-static Void local setType Args((Int,Cell,Cell,List));
-
-static List local dependencyAnal Args((List));
-static List local topDependAnal Args((List));
-static Void local addDepField Args((Cell));
-static Void local remDepField Args((List));
-static Void local remDepField1 Args((Cell));
-static Void local clearScope Args((Void));
-static Void local withinScope Args((List));
-static Void local leaveScope Args((Void));
-
-static Void local depBinding Args((Cell));
-static Void local depDefaults Args((Class));
-static Void local depInsts Args((Inst));
-static Void local depClassBindings Args((List));
-static Void local depAlt Args((Cell));
-static Void local depRhs Args((Cell));
-static Void local depGuard Args((Cell));
-static Cell local depExpr Args((Int,Cell));
-static Void local depPair Args((Int,Cell));
-static Void local depTriple Args((Int,Cell));
-static Void local depComp Args((Int,Cell,List));
-static Void local depCaseAlt Args((Int,Cell));
-static Cell local depVar Args((Int,Cell));
-static Cell local depQVar Args((Int,Cell));
-static Void local depConFlds Args((Int,Cell,Bool));
-static Void local depUpdFlds Args((Int,Cell));
-static List local depFields Args((Int,Cell,List,Bool));
+static Type local instantiateSyn Args((Type,Type));
+
+static Void local checkClassDefn Args((Class));
+static Void local depPredExp Args((Int,List,Cell));
+static Void local checkMems Args((Class,List,Cell));
+static Void local addMembers Args((Class));
+static Name local newMember Args((Int,Int,Cell,Type,Class));
+static Name local newDSel Args((Class,Int));
+static Name local newDBuild Args((Class));
+static Text local generateText Args((String,Class));
+static Int local visitClass Args((Class));
+
+static List local classBindings Args((String,Class,List));
+static Name local memberName Args((Class,Text));
+static List local numInsert Args((Int,Cell,List));
+
+static List local typeVarsIn Args((Cell,List,List));
+static List local maybeAppendVar Args((Cell,List));
+
+static Type local checkSigType Args((Int,String,Cell,Type));
+static Type local depTopType Args((Int,List,Type));
+static Type local depCompType Args((Int,List,Type));
+static Type local depTypeExp Args((Int,List,Type));
+static Type local depTypeVar Args((Int,List,Text));
+static List local checkQuantVars Args((Int,List,List,Cell));
+static List local offsetTyvarsIn Args((Type,List));
+static Void local kindConstr Args((Int,Int,Int,Constr));
+static Kind local kindAtom Args((Int,Constr));
+static Void local kindPred Args((Int,Int,Int,Cell));
+static Void local kindType Args((Int,String,Type));
+static Void local fixKinds Args((Void));
+
+static Void local kindTCGroup Args((List));
+static Void local initTCKind Args((Cell));
+static Void local kindTC Args((Cell));
+static Void local genTC Args((Cell));
+
+static Void local checkInstDefn Args((Inst));
+static Void local insertInst Args((Inst));
+static Bool local instCompare Args((Inst,Inst));
+static Name local newInstImp Args((Inst));
+static Void local kindInst Args((Inst,Int));
+static Void local checkDerive Args((Tycon,List,List,Cell));
+static Void local addDerInst Args((Int,Class,List,List,Type,Int));
+static Void local deriveContexts Args((List));
+static Void local initDerInst Args((Inst));
+static Void local calcInstPreds Args((Inst));
+static Void local maybeAddPred Args((Cell,Int,Int,List));
+static Cell local copyAdj Args((Cell,Int,Int));
+static Void local tidyDerInst Args((Inst));
+
+static Void local addDerivImp Args((Inst));
+static List local getDiVars Args((Int));
+static Cell local mkBind Args((String,List));
+static Cell local mkVarAlts Args((Int,Cell));
+
+static List local makeDPats2 Args((Cell,Int));
+
+static Bool local isEnumType Args((Tycon));
+
+static Void local checkDefaultDefns Args((Void));
+
+static Void local checkForeignImport Args((Name));
+static Void local checkForeignExport Args((Name));
+
+static Name local addNewPrim Args((Int,Text,String,Cell));
+
+static Cell local tidyInfix Args((Int,Cell));
+static Pair local attachFixity Args((Int,Cell));
+static Syntax local lookupSyntax Args((Text));
+
+static Cell local checkPat Args((Int,Cell));
+static Cell local checkMaybeCnkPat Args((Int,Cell));
+static Cell local checkApPat Args((Int,Int,Cell));
+static Void local addToPatVars Args((Int,Cell));
+static Name local conDefined Args((Int,Cell));
+static Void local checkIsCfun Args((Int,Name));
+static Void local checkCfunArgs Args((Int,Cell,Int));
+static Cell local checkPatType Args((Int,String,Cell,Type));
+static Cell local applyBtyvs Args((Cell));
+static Cell local bindPat Args((Int,Cell));
+static Void local bindPats Args((Int,List));
+
+static List local extractSigdecls Args((List));
+static List local extractFixdecls Args((List));
+static List local extractBindings Args((List));
+static List local getPatVars Args((Int,Cell,List));
+static List local addPatVar Args((Int,Cell,List));
+static List local eqnsToBindings Args((List,List,List,List));
+static Void local notDefined Args((Int,List,Cell));
+static Cell local findBinding Args((Text,List));
+static Cell local getAttr Args((List,Cell));
+static Void local addSigdecl Args((List,Cell));
+static Void local addFixdecl Args((List,List,List,List,Triple));
+static Void local dupFixity Args((Int,Text));
+static Void local missFixity Args((Int,Text));
+
+static List local dependencyAnal Args((List));
+static List local topDependAnal Args((List));
+static Void local addDepField Args((Cell));
+static Void local remDepField Args((List));
+static Void local remDepField1 Args((Cell));
+static Void local clearScope Args((Void));
+static Void local withinScope Args((List));
+static Void local leaveScope Args((Void));
+static Void local saveSyntax Args((Cell,Cell));
+
+static Void local depBinding Args((Cell));
+static Void local depDefaults Args((Class));
+static Void local depInsts Args((Inst));
+static Void local depClassBindings Args((List));
+static Void local depAlt Args((Cell));
+static Void local depRhs Args((Cell));
+static Void local depGuard Args((Cell));
+static Cell local depExpr Args((Int,Cell));
+static Void local depPair Args((Int,Cell));
+static Void local depTriple Args((Int,Cell));
+static Void local depComp Args((Int,Cell,List));
+static Void local depCaseAlt Args((Int,Cell));
+static Cell local depVar Args((Int,Cell));
+static Cell local depQVar Args((Int,Cell));
+static Void local depConFlds Args((Int,Cell,Bool));
+static Void local depUpdFlds Args((Int,Cell));
+static List local depFields Args((Int,Cell,List,Bool));
#if TREX
-static Cell local depRecord Args((Int,Cell));
+static Cell local depRecord Args((Int,Cell));
#endif
-static List local tcscc Args((List,List));
-static List local bscc Args((List));
+static List local tcscc Args((List,List));
+static List local bscc Args((List));
-static Void local addRSsigdecls Args((Pair));
-static Void local opDefined Args((List,Cell));
-static Void local allNoPrevDef Args((Cell));
-static Void local noPrevDef Args((Int,Cell));
-static Void local duplicateError Args((Int,Module,Text,String));
-static Void local checkTypeIn Args((Pair));
+static Void local addRSsigdecls Args((Pair));
+static Void local allNoPrevDef Args((Cell));
+static Void local noPrevDef Args((Int,Cell));
+#if IGNORE_MODULES
+static Void local duplicateErrorAux Args((Int,Text,String));
+#define duplicateError(l,m,t,k) duplicateErrorAux(l,t,k)
+#else
+static Void local duplicateErrorAux Args((Int,Module,Text,String));
+#define duplicateError(l,m,t,k) duplicateErrorAux(l,m,t,k)
+#endif
+static Void local checkTypeIn Args((Pair));
/* --------------------------------------------------------------------------
* The code in this file is arranged in roughly the following order:
* - Kind inference preliminaries
+ * - Module declarations
* - Type declarations (data, type, newtype, type in)
* - Class declarations
* - Type signatures
* - Instance declarations
* - Default declarations
+ * - Primitive definitions
* - Patterns
+ * - Infix expressions
* - Value definitions
* - Top-level static analysis and control
+ * - Haskell 98 compatibility tests
* ------------------------------------------------------------------------*/
/* --------------------------------------------------------------------------
#endif
/* --------------------------------------------------------------------------
+ * Static analysis of modules:
+ * ------------------------------------------------------------------------*/
+
+#if HSCRIPT
+String reloadModule;
+#endif
+
+#if !IGNORE_MODULES
+Void startModule(nm) /* switch to a new module */
+Cell nm; {
+ Module m;
+ if (!isCon(nm)) internal("startModule");
+ if (isNull(m = findModule(textOf(nm))))
+ m = newModule(textOf(nm));
+ else if (!isPreludeScript()) {
+ /* You're allowed to break the rules in the Prelude! */
+#if HSCRIPT
+ reloadModule = textToStr(textOf(nm));
+#endif
+ ERRMSG(0) "Module \"%s\" already loaded", textToStr(textOf(nm))
+ EEND;
+ }
+ setCurrModule(m);
+}
+
+Void setExportList(exps) /* Add export list to current module */
+List exps; {
+ module(currentModule).exports = exps;
+}
+
+Void addQualImport(orig,new) /* Add to qualified import list */
+Cell orig; /* Original name of module */
+Cell new; { /* Name module is called within this module (or NIL) */
+ module(currentModule).qualImports =
+ cons(pair(isNull(new)?orig:new,orig),module(currentModule).qualImports);
+}
+
+Void addUnqualImport(mod,entities) /* Add to unqualified import list */
+Cell mod; /* Name of module */
+List entities; { /* List of entity names */
+ unqualImports = cons(pair(mod,entities),unqualImports);
+}
+
+static Void local checkQualImport(i) /* Process qualified import */
+Pair i; {
+ Module m = findModid(snd(i));
+ if (isNull(m)) {
+ ERRMSG(0) "Module \"%s\" not previously loaded",
+ textToStr(textOf(snd(i)))
+ EEND;
+ }
+ snd(i)=m;
+}
+
+static Void local checkUnqualImport(i) /* Process unqualified import */
+Pair i; {
+ Module m = findModid(fst(i));
+ if (isNull(m)) {
+ ERRMSG(0) "Module \"%s\" not previously loaded",
+ textToStr(textOf(fst(i)))
+ EEND;
+ }
+ fst(i)=m;
+}
+
+static Name local lookupName(t,nms) /* find text t in list of Names */
+Text t;
+List nms; { /* :: [Name] */
+ for(; nonNull(nms); nms=tl(nms)) {
+ if (t == name(hd(nms)).text)
+ return hd(nms);
+ }
+ return NIL;
+}
+
+static List local checkSubentities(imports,named,wanted,description,textParent)
+List imports;
+List named; /* :: [ Q?(Var|Con)(Id|Op) ] */
+List wanted; /* :: [Name] */
+String description; /* "<constructor>|<member> of <type>|<class>" */
+Text textParent; {
+ for(; nonNull(named); named=tl(named)) {
+ Pair x = hd(named);
+ /* ToDo: ignores qualifier; doesn't check that entity is in scope */
+ Text t = isPair(snd(x)) ? qtextOf(x) : textOf(x);
+ Name n = lookupName(t,wanted);
+ if (isNull(n)) {
+ ERRMSG(0) "Entity \"%s\" is not a %s \"%s\"",
+ textToStr(t),
+ description,
+ textToStr(textParent)
+ EEND;
+ }
+ imports = cons(n,imports);
+ }
+ return imports;
+}
+
+static List local checkImportEntity(imports,exporter,entity)
+List imports; /* Accumulated list of things to import */
+Module exporter;
+Cell entity; { /* Entry from import list */
+ List oldImports = imports;
+ Text t = isIdent(entity) ? textOf(entity) : textOf(fst(entity));
+ List es = module(exporter).exports;
+ for(; nonNull(es); es=tl(es)) {
+ Cell e = hd(es); /* :: Entity | (Entity, NIL|DOTDOT) */
+ if (isPair(e)) {
+ Cell f = fst(e);
+ if (isTycon(f)) {
+ if (tycon(f).text == t) {
+ imports = cons(f,imports);
+ if (!isIdent(entity)) {
+ switch (tycon(f).what) {
+ case NEWTYPE:
+ case DATATYPE:
+ if (DOTDOT == snd(entity)) {
+ imports=dupOnto(tycon(f).defn,imports);
+ } else {
+ imports=checkSubentities(imports,snd(entity),tycon(f).defn,"constructor of type",t);
+ }
+ break;
+ default:;
+ /* deliberate fall thru */
+ }
+ }
+ }
+ } else if (isClass(f)) {
+ if (cclass(f).text == t) {
+ imports = cons(f,imports);
+ if (!isIdent(entity)) {
+ if (DOTDOT == snd(entity)) {
+ return dupOnto(cclass(f).members,imports);
+ } else {
+ return checkSubentities(imports,snd(entity),cclass(f).members,"member of class",t);
+ }
+ }
+ }
+ } else {
+ internal("checkImportEntity2");
+ }
+ } else if (isName(e)) {
+ if (isIdent(entity) && name(e).text == t) {
+ imports = cons(e,imports);
+ }
+ } else {
+ internal("checkImportEntity3");
+ }
+ }
+ if (imports == oldImports) {
+ ERRMSG(0) "Unknown entity \"%s\" imported from module \"%s\"",
+ textToStr(t),
+ textToStr(module(exporter ).text)
+ EEND;
+ }
+ return imports;
+}
+
+static List local resolveImportList(m,impList)
+Module m; /* exporting module */
+Cell impList; {
+ List imports = NIL;
+ if (DOTDOT == impList) {
+ List es = module(m).exports;
+ for(; nonNull(es); es=tl(es)) {
+ Cell e = hd(es);
+ if (isName(e))
+ imports = cons(e,imports);
+ else {
+ Cell c = fst(e);
+ List subentities = NIL;
+ imports = cons(c,imports);
+ if (isTycon(c)
+ && (tycon(c).what == DATATYPE
+ || tycon(c).what == NEWTYPE))
+ subentities = tycon(c).defn;
+ else if (isClass(c))
+ subentities = cclass(c).members;
+ if (DOTDOT == snd(e)) {
+ imports = dupOnto(subentities,imports);
+ }
+ }
+ }
+ } else {
+ map1Accum(checkImportEntity,imports,m,impList);
+ }
+ return imports;
+}
+
+static Void local checkImportList(importSpec) /*Import a module unqualified*/
+Pair importSpec; {
+ Module m = fst(importSpec);
+ Cell impList = snd(importSpec);
+
+ List imports = NIL; /* entities we want to import */
+ List hidden = NIL; /* entities we want to hide */
+
+ if (moduleThisScript(m)) {
+ ERRMSG(0) "Module \"%s\" recursively imports itself",
+ textToStr(module(m).text)
+ EEND;
+ }
+ if (isPair(impList) && HIDDEN == fst(impList)) {
+ /* Somewhat inefficient - but obviously correct:
+ * imports = importsOf("module Foo") `setDifference` hidden;
+ */
+ hidden = resolveImportList(m, snd(impList));
+ imports = resolveImportList(m, DOTDOT);
+ } else {
+ imports = resolveImportList(m, impList);
+ }
+ for(; nonNull(imports); imports=tl(imports)) {
+ Cell e = hd(imports);
+ if (!cellIsMember(e,hidden))
+ importEntity(m,e);
+ }
+ /* ToDo: hang onto the imports list for processing export list entries
+ * of the form "module Foo"
+ */
+}
+
+static Void local importEntity(source,e)
+Module source;
+Cell e; {
+ switch (whatIs(e)) {
+ case NAME : importName(source,e);
+ break;
+ case TYCON : importTycon(source,e);
+ break;
+ case CLASS : importClass(source,e);
+ break;
+ default: internal("importEntity");
+ }
+}
+
+static Void local importName(source,n)
+Module source;
+Name n; {
+ Name clash = addName(n);
+ if (nonNull(clash) && clash!=n) {
+ ERRMSG(0) "Entity \"%s\" imported from module \"%s\" already defined in module \"%s\"",
+ textToStr(name(n).text),
+ textToStr(module(source).text),
+ textToStr(module(name(clash).mod).text)
+ EEND;
+ }
+}
+
+static Void local importTycon(source,tc)
+Module source;
+Tycon tc; {
+ Tycon clash=addTycon(tc);
+ if (nonNull(clash) && clash!=tc) {
+ ERRMSG(0) "Tycon \"%s\" imported from \"%s\" already defined in module \"%s\"",
+ textToStr(tycon(tc).text),
+ textToStr(module(source).text),
+ textToStr(module(tycon(clash).mod).text)
+ EEND;
+ }
+ if (nonNull(findClass(tycon(tc).text))) {
+ ERRMSG(0) "Import of type constructor \"%s\" clashes with class in module \"%s\"",
+ textToStr(tycon(tc).text),
+ textToStr(module(tycon(tc).mod).text)
+ EEND;
+ }
+}
+
+static Void local importClass(source,c)
+Module source;
+Class c; {
+ Class clash=addClass(c);
+ if (nonNull(clash) && clash!=c) {
+ ERRMSG(0) "Class \"%s\" imported from \"%s\" already defined in module \"%s\"",
+ textToStr(cclass(c).text),
+ textToStr(module(source).text),
+ textToStr(module(cclass(clash).mod).text)
+ EEND;
+ }
+ if (nonNull(findTycon(cclass(c).text))) {
+ ERRMSG(0) "Import of class \"%s\" clashes with type constructor in module \"%s\"",
+ textToStr(cclass(c).text),
+ textToStr(module(source).text)
+ EEND;
+ }
+}
+
+static List local checkExportTycon(exports,mt,spec,tc)
+List exports;
+Text mt;
+Cell spec;
+Tycon tc; {
+ if (DOTDOT == spec || SYNONYM == tycon(tc).what) {
+ return cons(pair(tc,DOTDOT), exports);
+ } else {
+ return cons(pair(tc,NIL), exports);
+ }
+}
+
+static List local checkExportClass(exports,mt,spec,cl)
+List exports;
+Text mt;
+Class cl;
+Cell spec; {
+ if (DOTDOT == spec) {
+ return cons(pair(cl,DOTDOT), exports);
+ } else {
+ return cons(pair(cl,NIL), exports);
+ }
+}
+
+static List local checkExport(exports,mt,e) /* Process entry in export list*/
+List exports;
+Text mt;
+Cell e; {
+ if (isIdent(e)) {
+ Cell export = NIL;
+ List origExports = exports;
+ if (nonNull(export=findQualName(e))) {
+ exports=cons(export,exports);
+ }
+ if (isQCon(e) && nonNull(export=findQualTycon(e))) {
+ exports = checkExportTycon(exports,mt,NIL,export);
+ }
+ if (isQCon(e) && nonNull(export=findQualClass(e))) {
+ /* opaque class export */
+ exports = checkExportClass(exports,mt,NIL,export);
+ }
+ if (exports == origExports) {
+ ERRMSG(0) "Unknown entity \"%s\" exported from module \"%s\"",
+ identToStr(e),
+ textToStr(mt)
+ EEND;
+ }
+ return exports;
+ } else if (MODULEENT == fst(e)) {
+ Module m = findModid(snd(e));
+ /* ToDo: shouldn't allow export of module we didn't import */
+ if (isNull(m)) {
+ ERRMSG(0) "Unknown module \"%s\" exported from module \"%s\"",
+ textToStr(textOf(snd(e))),
+ textToStr(mt)
+ EEND;
+ }
+ if (m == currentModule) {
+ /* Exporting the current module exports local definitions */
+ List xs;
+ for(xs=module(m).classes; nonNull(xs); xs=tl(xs)) {
+ if (cclass(hd(xs)).mod==m)
+ exports = checkExportClass(exports,mt,DOTDOT,hd(xs));
+ }
+ for(xs=module(m).tycons; nonNull(xs); xs=tl(xs)) {
+ if (tycon(hd(xs)).mod==m)
+ exports = checkExportTycon(exports,mt,DOTDOT,hd(xs));
+ }
+ for(xs=module(m).names; nonNull(xs); xs=tl(xs)) {
+ if (name(hd(xs)).mod==m)
+ exports = cons(hd(xs),exports);
+ }
+ } else {
+ /* Exporting other modules imports all things imported
+ * unqualified from it.
+ * ToDo: we reexport everything exported by a module -
+ * whether we imported it or not. This gives the wrong
+ * result for "module M(module N) where import N(x)"
+ */
+ exports = dupOnto(module(m).exports,exports);
+ }
+ return exports;
+ } else {
+ Cell ident = fst(e); /* class name or type name */
+ Cell parts = snd(e); /* members or constructors */
+ Cell nm;
+ if (isQCon(ident) && nonNull(nm=findQualTycon(ident))) {
+ switch (tycon(nm).what) {
+ case SYNONYM:
+ if (DOTDOT!=parts) {
+ ERRMSG(0) "Explicit constructor list given for type synonym \"%s\" in export list of module \"%s\"",
+ identToStr(ident),
+ textToStr(mt)
+ EEND;
+ }
+ return cons(pair(nm,DOTDOT),exports);
+ case RESTRICTSYN:
+ ERRMSG(0) "Transparent export of restricted type synonym \"%s\" in export list of module \"%s\"",
+ identToStr(ident),
+ textToStr(mt)
+ EEND;
+ return exports; /* Not reached */
+ case NEWTYPE:
+ case DATATYPE:
+ if (DOTDOT==parts) {
+ return cons(pair(nm,DOTDOT),exports);
+ } else {
+ exports = checkSubentities(exports,parts,tycon(nm).defn,
+ "constructor of type",
+ tycon(nm).text);
+ return cons(pair(nm,DOTDOT), exports);
+ }
+ default:
+ internal("checkExport1");
+ }
+ } else if (isQCon(ident) && nonNull(nm=findQualClass(ident))) {
+ if (DOTDOT == parts) {
+ return cons(pair(nm,DOTDOT),exports);
+ } else {
+ exports = checkSubentities(exports,parts,cclass(nm).members,
+ "member of class",cclass(nm).text);
+ return cons(pair(nm,DOTDOT), exports);
+ }
+ } else {
+ ERRMSG(0) "Explicit export list given for non-class/datatype \"%s\" in export list of module \"%s\"",
+ identToStr(ident),
+ textToStr(mt)
+ EEND;
+ }
+ }
+ assert(0); return 0; /* NOTREACHED */
+}
+
+static List local checkExports(exports)
+List exports; {
+ Module m = lastModule();
+ Text mt = module(m).text;
+ List es = NIL;
+
+ map1Accum(checkExport,es,mt,exports);
+
+#if DEBUG_MODULES
+ for(xs=es; nonNull(xs); xs=tl(xs)) {
+ Printf(" %s", textToStr(textOfEntity(hd(xs))));
+ }
+#endif
+ return es;
+}
+#endif
+
+/* --------------------------------------------------------------------------
* Static analysis of type declarations:
*
* Type declarations come in two forms:
tycon(nw).arity = argCount;
tycon(nw).what = what;
if (what==RESTRICTSYN) {
+ h98DoesntSupport(line,"restricted type synonyms");
typeInDefns = cons(pair(nw,snd(rhs)),typeInDefns);
rhs = fst(rhs);
}
List derivs = snd(cd);
List compTypes = NIL;
List sels = NIL;
- Int ntvs = length(tyvars);
Int i;
for (i=0; i<tycon(t).arity; ++i) /* build representation for tycon */
ctxt = fst(snd(cs));
cs = snd(snd(cs));
map2Proc(depPredExp,line,tyvars,ctxt);
+ h98CheckCtxt(line,"context",TRUE,ctxt,NIL);
}
if (nonNull(cs) && isNull(tl(cs))) /* Single constructor datatype? */
for (; nonNull(cs); cs=tl(cs)) { /* For each constructor function: */
Cell con = hd(cs);
- List sig = typeVarsIn(con,NIL,dupList(tyvars));
- Int etvs = length(sig);
+ List sig = dupList(tyvars);
+ List evs = NIL; /* locally quantified vars */
+ List lps = NIL; /* locally bound predicates */
List ctxt1 = ctxt; /* constructor function context */
List scs = NIL; /* strict components */
List fs = NONE; /* selector names */
Int nr2 = 0; /* Number of rank 2 args */
Name n; /* name for constructor function */
+ if (whatIs(con)==POLYTYPE) { /* Locally quantified vars */
+ evs = fst(snd(con));
+ con = snd(snd(con));
+ sig = checkQuantVars(line,evs,sig,con);
+ }
+
+ if (whatIs(con)==QUAL) { /* Local predicates */
+ List us;
+ lps = fst(snd(con));
+ for (us = typeVarsIn(lps,NIL,NIL); nonNull(us); us=tl(us))
+ if (!varIsMember(textOf(hd(us)),evs)) {
+ ERRMSG(line)
+ "Variable \"%s\" in constraint is not locally bound",
+ textToStr(textOf(hd(us)))
+ EEND;
+ }
+ map2Proc(depPredExp,line,sig,lps);
+ con = snd(snd(con));
+ arity = length(lps);
+ }
+
if (whatIs(con)==LABC) { /* Skeletize constr components */
Cell fls = snd(snd(con)); /* get field specifications */
con = fst(snd(con));
ctxt1 = selectCtxt(ctxt1,offsetTyvarsIn(con,NIL));
for (i=arity; isAp(con); i--) { /* Calculate type of constructor */
- Type t = fun(con);
+ Type ty = fun(con);
Type cmp = arg(con);
fun(con) = typeArrow;
if (isPolyType(cmp)) {
if (nonNull(derivs)) /* and build list of components */
compTypes = cons(cmp,compTypes);
type = ap(con,type);
- con = t;
+ con = ty;
}
if (nr2>0) /* Add rank 2 annotation */
type = ap(RANK2,pair(mkInt(nr2),type));
- if (etvs>ntvs) { /* Add existential annotation */
+ if (nonNull(evs)) { /* Add existential annotation */
if (nonNull(derivs)) {
ERRMSG(line) "Cannot derive instances for types" ETHEN
ERRTEXT " with existentially typed components"
"Cannot use selectors with existentially typed components"
EEND;
}
- type = ap(EXIST,pair(mkInt(etvs-ntvs),type));
+ type = ap(EXIST,pair(mkInt(length(evs)),type));
}
+
+ if (nonNull(lps)) { /* Add local preds part to type */
+ type = ap(CDICTS,pair(lps,type));
+ }
+
if (nonNull(ctxt1)) { /* Add context part to type */
type = ap(QUAL,pair(ctxt1,type));
}
+
if (nonNull(sig)) { /* Add quantifiers to type */
List ts1 = sig;
for (; nonNull(ts1); ts1=tl(ts1)) {
n = findName(textOf(con)); /* Allocate constructor fun name */
if (isNull(n)) {
- n = newName(textOf(con));
+ n = newName(textOf(con),NIL);
} else if (name(n).defn!=PREDEFINED) {
duplicateError(line,name(n).mod,name(n).text,
"constructor function");
}
name(n).arity = arity; /* Save constructor fun details */
name(n).line = line;
+ name(n).parent = t;
name(n).number = cfunNo(conNo++);
name(n).type = type;
if (tycon(t).what==NEWTYPE) {
+ if (nonNull(lps)) {
+ ERRMSG(line)
+ "A newtype constructor cannot have class constraints"
+ EEND;
+ }
+ if (arity!=1) {
+ ERRMSG(line)
+ "A newtype constructor must have exactly one argument"
+ EEND;
+ }
+ if (nonNull(scs)) {
+ ERRMSG(line)
+ "Illegal strictess annotation for newtype constructor"
+ EEND;
+ }
name(n).defn = nameId;
} else {
implementCfun(n,scs);
}
+
hd(cs) = n;
if (fs!=NONE) {
sels = addSels(line,n,fs,sels);
}
}
+Int userArity(c) /* Find arity for cfun, ignoring */
+Name c; { /* CDICTS parameters */
+ Int a = name(c).arity;
+ Type t = name(c).type;
+ Int w;
+ if (isPolyType(t)) {
+ t = monotypeOf(t);
+ }
+ if ((w=whatIs(t))==QUAL) {
+ w = whatIs(t=snd(snd(t)));
+ }
+ if (w==CDICTS) {
+ a -= length(fst(snd(t)));
+ }
+ return a;
+}
+
+static List cfunSfuns; /* List of (Cfun,[SelectorVar]) */
+ /* - used for deriving Show */
+
static List local addSels(line,c,fs,ss) /* Add fields to selector list */
Int line; /* line number of constructor */
Name c; /* corresponding constr function */
List fs; /* list of fields (varids) */
List ss; { /* list of existing selectors */
Int sn = 1;
-#if DERIVE_SHOW | DERIVE_READ
cfunSfuns = cons(pair(c,fs),cfunSfuns);
-#endif
for (; nonNull(fs); fs=tl(fs), ++sn) {
List ns = ss;
Text t = textOf(hd(fs));
while (nonNull(ns) && t!=name(hd(ns)).text) {
ns = tl(ns);
}
+
if (nonNull(ns)) {
name(hd(ns)).defn = cons(pair(c,mkInt(sn)),name(hd(ns)).defn);
} else {
textToStr(t)
EEND;
}
- n = newName(t);
+ n = newName(t,c);
name(n).line = line;
name(n).number = SELNAME;
name(n).defn = singleton(pair(c,mkInt(sn)));
List path1 = NIL;
for (; nonNull(ds); ds=tl(ds)) {
if (cellIsMember(hd(ds),syns)) {
- if (isNull(path1))
+ if (isNull(path1)) {
path1 = cons(t,path);
+ }
syns = visitSyn(path1,hd(ds),syns);
}
}
return removeCell(t,syns);
}
+#if EVAL_INSTANCES
/* --------------------------------------------------------------------------
* The following code is used in calculating contexts for the automatically
* derived Eval instances for newtype and restricted type synonyms. This is
* future.
* ------------------------------------------------------------------------*/
-#if EVAL_INSTANCES
static Void local deriveEval(tcs) /* Derive instances of Eval */
List tcs; {
List ts1 = tcs;
for (; nonNull(scs); scs=tl(scs)) {
Int i = intOf(hd(scs));
for (; n<i; n++) {
- t = arg(t);
+ t = arg(t);
}
checkBanged(c,ks,ctxt,arg(fun(t)));
}
ctxt = singleton(ap(classEval,copyType(t,o)));
break;
} else if (isTuple(h) /* Check for tuples ... */
- || h==tc /* ... direct recursion */
- || cellIsMember(h,ps) /* ... mutual recursion */
- || tycon(h).what==DATATYPE) { /* ... or datatype. */
+ || h==tc /* ... direct recursion */
+ || cellIsMember(h,ps) /* ... mutual recursion */
+ || tycon(h).what==DATATYPE) {/* ... or datatype. */
break; /* => empty context */
} else {
Cell pi = ap(classEval,t);
if (cellIsMember(h,ts)) { /* Not yet visited? */
ts = calcEvalContexts(h,removeCell(h,ts),cons(h,ts));
}
+<<<<<<<<<<<<<< variant A
+>>>>>>>>>>>>>> variant B
+
+======= end of combination
if (nonNull(in=findInstFor(pi,o))) {/* Look for Eval instance */
List qs = inst(in).specifics;
Int o1 = typeOff;
}
static Void local checkBanged(c,ks,ps,ty)
-Name c; /* Check that banged component of c*/
-Kinds ks; /* with type ty is an instance of */
-List ps; /* Eval under the predicates in ps.*/
-Type ty; { /* (All types using ks) */
+Name c; /* Check that banged component of c */
+Kinds ks; /* with type ty is an instance of */
+List ps; /* Eval under the predicates in ps. */
+Type ty; { /* (All types using ks) */
Cell pi = ap(classEval,ty);
if (isNull(provePred(ks,ps,pi))) {
ERRMSG(name(c).line) "Illegal datatype strictness annotation:" ETHEN
* stages of static analysis.
* ------------------------------------------------------------------------*/
-Void classDefn(line,head,ms) /* process new class definition */
-Int line; /* definition line number */
-Cell head; /* class header :: ([Supers],Class)*/
-List ms; { /* class definition body */
- Text ct = textOf(getHead(snd(head)));
- Int arity = argCount;
+Void classDefn(line,head,ms) /* process new class definition */
+Int line; /* definition line number */
+Cell head; /* class header :: ([Supers],Class) */
+List ms; { /* class definition body */
+ Text ct = textOf(getHead(snd(head)));
+ Int arity = argCount;
if (nonNull(findClass(ct))) {
ERRMSG(line) "Repeated definition of class \"%s\"",
cclass(nw).members = ms;
cclass(nw).level = 0;
classDefns = cons(nw,classDefns);
+ if (arity!=1)
+ h98DoesntSupport(line,"multiple parameter classes");
}
}
* class definition:
* - check that variables in header are distinct
* - replace head by skeleton
- * - check superclass declarations, replace by skeltons
+ * - check superclass declarations, replace by skeletons
* - split body of class into members and declarations
* - make new name entry for each member function
* - record member function number (eventually an offset into dictionary!)
* - check that extended class hierarchy does not contain any cycles
* ------------------------------------------------------------------------*/
-static Void local checkClassDefn(c) /* validate class definition */
+static Void local checkClassDefn(c) /* validate class definition */
Class c; {
List tyvars = NIL;
Int args = cclass(c).arity - 1;
Cell temp = cclass(c).head;
+ List fs = NIL;
+ List ss = NIL;
for (; isAp(temp); temp=fun(temp)) {
if (!isVar(arg(temp))) {
tcDeps = NIL; /* find dependents */
map2Proc(depPredExp,cclass(c).line,tyvars,cclass(c).supers);
+ h98CheckCtxt(cclass(c).line,"class definition",FALSE,cclass(c).supers,NIL);
cclass(c).numSupers = length(cclass(c).supers);
cclass(c).defaults = extractBindings(cclass(c).members); /* defaults*/
- cclass(c).members = extractSigdecls(cclass(c).members);
- map2Proc(checkMems,c,tyvars,cclass(c).members);
+ ss = extractSigdecls(cclass(c).members);
+ fs = extractFixdecls(cclass(c).members);
+ cclass(c).members = pair(ss,fs);
+ map2Proc(checkMems,c,tyvars,ss);
+
cclass(c).kinds = tcDeps;
tcDeps = NIL;
}
h = fun(pred);
}
arg(pred) = depTypeExp(line,tyvars,arg(pred));
+ if (args!=1)
+ h98DoesntSupport(line,"multiple parameter classes");
if (isQCon(h)) { /* standard class constraint */
Class c = findQualClass(h);
textToStr(cclass(c).text)
EEND;
}
- if (cellIsMember(c,classDefns) && !cellIsMember(c,tcDeps))
+ if (cellIsMember(c,classDefns) && !cellIsMember(c,tcDeps)) {
tcDeps = cons(c,tcDeps);
+ }
}
#if TREX
else if (isExt(h)) { /* Lacks predicate */
fst(snd(t)) = cons(cclass(c).head,fst(snd(t)));/* Add main predicate */
snd(snd(t)) = depTopType(line,tyvars,snd(snd(t)));
- for (tvs=tyvars; nonNull(tvs); tvs=tl(tvs)) { /* Quantify */
+ for (tvs=tyvars; nonNull(tvs); tvs=tl(tvs)){/* Quantify */
sig = ap(NIL,sig);
}
t = mkPolyType(sig,t);
if (isAmbiguous(t)) {
ambigError(line,"class declaration",hd(vs),t);
}
+ h98CheckType(line,"member type",hd(vs),t);
}
static Void local addMembers(c) /* Add definitions of member funs */
Class c; { /* and other parts of class struct.*/
- List ms = cclass(c).members;
+ List ms = fst(cclass(c).members);
+ List fs = snd(cclass(c).members);
List ns = NIL; /* List of names */
Int mno; /* Member function number */
List vs = rev(snd3(hd(ms)));
Type t = thd3(hd(ms));
for (; nonNull(vs); vs=tl(vs)) {
- ns = cons(newMember(line,mno++,hd(vs),t),ns);
+ ns = cons(newMember(line,mno++,hd(vs),t,c),ns);
}
}
cclass(c).members = rev(ns); /* Save list of members */
cclass(c).numMembers = length(cclass(c).members);
+ for (; nonNull(fs); fs=tl(fs)) { /* fixity declarations */
+ Int line = intOf(fst3(hd(fs)));
+ List ops = snd3(hd(fs));
+ Syntax s = intOf(thd3(hd(fs)));
+ for (; nonNull(ops); ops=tl(ops)) {
+ Name n = nameIsMember(textOf(hd(ops)),cclass(c).members);
+ if (isNull(n)) {
+ missFixity(line,textOf(hd(ops)));
+ } else if (name(n).syntax!=NO_SYNTAX) {
+ dupFixity(line,textOf(hd(ops)));
+ }
+ name(n).syntax = s;
+ }
+ }
+
/* Not actually needed just yet; for the time being, dictionary code will
not be passed through the type checker.
*/
mno = cclass(c).numSupers + cclass(c).numMembers;
- cclass(c).dcon = addPrimCfun(generateText("Make.%s",c),mno,0,0);
- implementCfun(cclass(c).dcon,NIL); /* ADR addition */
-#if USE_NEWTYPE_FOR_DICTS
+ cclass(c).dcon = addPrimCfun(generateText("Make.%s",c),mno,0,NIL);
if (mno==1) { /* Single entry dicts use newtype */
name(cclass(c).dcon).defn = nameId;
name(hd(cclass(c).members)).number = mfunNo(0);
}
-#endif
cclass(c).dbuild = newDBuild(c);
cclass(c).defaults = classBindings("class",c,cclass(c).defaults);
}
-static Name local newMember(l,no,v,t) /* Make definition for member fn */
-Int l;
-Int no;
-Cell v;
-Type t; {
+static Name local newMember(l,no,v,t,parent)
+Int l; /* Make definition for member fn */
+Int no;
+Cell v;
+Type t;
+Class parent; {
Name m = findName(textOf(v));
if (isNull(m)) {
- m = newName(textOf(v));
+ m = newName(textOf(v),parent);
} else if (name(m).defn!=PREDEFINED) {
ERRMSG(l) "Repeated definition for member function \"%s\"",
textToStr(name(m).text)
char buf[16];
sprintf(buf,"sc%d.%s",no,"%s");
- s = newName(generateText(buf,c));
+ s = newName(generateText(buf,c),c);
name(s).line = cclass(c).line;
name(s).arity = 1;
name(s).number = DFUNNAME;
static Name local newDBuild(c) /* Make definition for builder */
Class c; {
- Name b = newName(generateText("class.%s",c));
+ Name b = newName(generateText("class.%s",c),c);
name(b).line = cclass(c).line;
name(b).arity = cclass(c).numSupers+1;
return b;
ERRMSG(cclass(c).line) "Class hierarchy for \"%s\" is not acyclic",
textToStr(cclass(c).text)
EEND;
- } else if (cclass(c).level == 0) { /* visiting class for first time */
+ } else if (cclass(c).level == 0) { /* visiting class for first time */
List scs = cclass(c).supers;
Int lev = 0;
cclass(c).level = (-1);
* ------------------------------------------------------------------------*/
static List local classBindings(where,c,bs)
-String where; /*check validity of bindings bs for*/
-Class c; /* class c (or an instance of c) */
+String where; /* Check validity of bindings bs */
+Class c; /* for class c (or an inst of c) */
List bs; { /* sort into approp. member order */
List nbs = NIL;
for (; nonNull(bs); bs=tl(bs)) {
- Cell b = hd(bs);
+ Cell b = hd(bs);
+ Cell body = snd(snd(b));
Name mnm;
- if (!isVar(fst(b))) { /* only allows function bindings */
- ERRMSG(rhsLine(snd(snd(snd(b)))))
- "Pattern binding illegal in %s declaration", where
+ if (!isVar(fst(b))) { /* Only allow function bindings */
+ ERRMSG(rhsLine(snd(body)))
+ "Pattern binding illegal in %s declaration", where
EEND;
}
if (isNull(mnm=memberName(c,textOf(fst(b))))) {
- ERRMSG(rhsLine(snd(hd(snd(snd(b))))))
+ ERRMSG(rhsLine(snd(hd(body))))
"No member \"%s\" in class \"%s\"",
textToStr(textOf(fst(b))), textToStr(cclass(c).text)
EEND;
}
-
- snd(b) = snd(snd(b));
- nbs = numInsert(mfunOf(mnm)-1,b,nbs);
+ snd(b) = body;
+ nbs = numInsert(mfunOf(mnm)-1,b,nbs);
}
return nbs;
}
return NIL;
}
-static List local numInsert(n,x,xs) /* insert x at nth position in xs, */
-Int n; /* filling gaps with NIL */
+static List local numInsert(n,x,xs) /* insert x at nth position in xs, */
+Int n; /* filling gaps with NIL */
Cell x;
List xs; {
List start = isNull(xs) ? cons(NIL,NIL) : xs;
case VAROPCELL : if (nonNull(findBtyvs(textOf(ty)))
|| varIsMember(textOf(ty),us)) {
return vs;
- } else {
+ } else {
return maybeAppendVar(ty,vs);
- }
+ }
+
case POLYTYPE : return typeVarsIn(monotypeOf(ty),polySigOf(ty),vs);
case QUAL : { List qs = fst(snd(ty));
return vs;
}
-static List local maybeAppendVar(v,vs) /* append variable to list if not */
-Cell v; /* already included */
+static List local maybeAppendVar(v,vs) /* append variable to list if not */
+Cell v; /* already included */
List vs; {
Text t = textOf(v);
List p = NIL;
} else {
vs = cons(v,NIL);
}
+
return vs;
}
} else {
type = depTopType(line,tvs,type);
}
+
if (n>0) {
if (n>=NUM_OFFSETS) {
ERRMSG(line) "Too many type variables in %s\n", where
kindType(line,"type expression",type);
fixKinds();
unkindTypes = sunk;
+
+ h98CheckType(line,where,e,type);
return type;
}
Type t1 = t;
Int nr2 = 0;
Int i = 1;
- for (; getHead(t1)==typeArrow; ++i) {
+ for (; getHead(t1)==typeArrow && argCount==2; ++i) {
arg(fun(t1)) = depCompType(l,tvs,arg(fun(t1)));
if (isPolyType(arg(fun(t1)))) {
nr2 = i;
List nfr = NIL;
if (isPolyType(t)) {
List vs = fst(snd(t));
- List bvs = typeVarsIn(monotypeOf(t),NIL,NIL);
- List us = vs;
- for (; nonNull(us); us=tl(us)) {
- Text u = textOf(hd(us));
- if (varIsMember(u,tl(us))) {
- ERRMSG(l) "Duplicated quantified variable %s",
- textToStr(u)
- EEND;
- }
- if (varIsMember(u,tvs)) {
- ERRMSG(l) "Local quantifier for %s hides an outer use",
- textToStr(u)
- EEND;
- }
- if (!varIsMember(u,bvs)) {
- ERRMSG(l) "Locally quantified variable %s is not used",
- textToStr(u)
- EEND;
- }
- }
- nfr = replicate(length(vs),NIL);
- tvs = appendOnto(tvs,vs);
- t = monotypeOf(t);
+ t = monotypeOf(t);
+ tvs = checkQuantVars(l,vs,tvs,t);
+ nfr = replicate(length(vs),NIL);
}
if (whatIs(t)==QUAL) {
map2Proc(depPredExp,l,tvs,fst(snd(t)));
snd(snd(t)) = depTypeExp(l,tvs,snd(snd(t)));
- if (isAmbiguous(t))
+ if (isAmbiguous(t)) {
ambigError(l,"type component",NIL,t);
+ }
} else {
t = depTypeExp(l,tvs,t);
}
}
#if TREX
- case EXT :
+ case EXT : h98DoesntSupport(line,"extensible records");
#endif
case TYCON :
case TUPLE : break;
return mkOffset(offset);
}
+static List local checkQuantVars(line,vs,tvs,body)
+Int line;
+List vs; /* variables to quantify over */
+List tvs; /* variables already in scope */
+Cell body; { /* type/constr for scope of vars */
+ if (nonNull(vs)) {
+ List bvs = typeVarsIn(body,NIL,NIL);
+ List us = vs;
+ for (; nonNull(us); us=tl(us)) {
+ Text u = textOf(hd(us));
+ if (varIsMember(u,tl(us))) {
+ ERRMSG(line) "Duplicated quantified variable %s",
+ textToStr(u)
+ EEND;
+ }
+ if (varIsMember(u,tvs)) {
+ ERRMSG(line) "Local quantifier for %s hides an outer use",
+ textToStr(u)
+ EEND;
+ }
+ if (!varIsMember(u,bvs)) {
+ ERRMSG(line) "Locally quantified variable %s is not used",
+ textToStr(u)
+ EEND;
+ }
+ }
+ tvs = appendOnto(tvs,vs);
+ }
+ return tvs;
+}
+
/* --------------------------------------------------------------------------
* Check for ambiguous types:
* A type Preds => type is ambiguous if not (TV(P) `subset` TV(type))
* ------------------------------------------------------------------------*/
+static List local offsetTyvarsIn(t,vs) /* add list of offset tyvars in t */
+Type t; /* to list vs */
+List vs; {
+ switch (whatIs(t)) {
+ case AP : return offsetTyvarsIn(fun(t),
+ offsetTyvarsIn(arg(t),vs));
+
+ case OFFSET : if (cellIsMember(t,vs))
+ return vs;
+ else
+ return cons(t,vs);
+
+ case QUAL : return offsetTyvarsIn(snd(t),vs);
+
+ case POLYTYPE : return offsetTyvarsIn(monotypeOf(t),vs);
+ /* slightly inaccurate, but won't matter here */
+
+ case EXIST :
+ case RANK2 : return offsetTyvarsIn(snd(snd(t)),vs);
+
+ default : return vs;
+ }
+}
+
Bool isAmbiguous(type) /* Determine whether type is */
Type type; { /* ambiguous */
if (isPolyType(type)) {
Int n = argCount;
#ifdef DEBUG_KINDS
- printf("kindConstr: alpha=%d, m=%d, c=",alpha,m);
+ Printf("kindConstr: alpha=%d, m=%d, c=",alpha,m);
printType(stdout,c);
- printf("\n");
+ Printf("\n");
#endif
switch (whatIs(h)) {
Kinds ks = polySigOf(t);
Int m1 = 0;
Int beta;
- for (; isAp(ks); ks=tl(ks))
+ for (; isAp(ks); ks=tl(ks)) {
m1++;
+ }
beta = newKindvars(m1);
unkindTypes = cons(pair(mkInt(beta),t),unkindTypes);
checkKind(line,beta,m1,monotypeOf(t),NIL,pt,STAR,0);
}
return;
+ case CDICTS :
case QUAL : if (n!=0) {
internal("kindConstr2");
}
if (n==0) { /* trivial case, no arguments */
typeIs = kindAtom(alpha,c);
- } else { /* non-trivial application */
+ } else { /* non-trivial application */
static String app = "constructor application";
Cell a = c;
Int i;
#endif
}
#if DEBUG_KINDS
- printf("kindAtom(%d,whatIs(%d)) on ",alpha,whatIs(c));
+ Printf("kindAtom(%d,whatIs(%d)) on ",alpha,whatIs(c));
printType(stdout,c);
- printf("\n");
+ Printf("\n");
#endif
internal("kindAtom");
return STAR;/* not reached */
}
}
#ifdef DEBUG_KINDS
- printf("Type expression: ");
+ Printf("Type expression: ");
printType(stdout,snd(pr));
- printf(" :: ");
+ Printf(" :: ");
printKind(stdout,polySigOf(snd(pr)));
- printf("\n");
+ Printf("\n");
#endif
}
}
}
}
else { /* scan type exprs in class defn to*/
- List ms = cclass(c).members; /* determine the class signature */
- Int m = cclass(c).arity;
+ List ms = fst(cclass(c).members);
+ Int m = cclass(c).arity; /* determine the class signature */
Int beta = newKindvars(m);
kindPred(cclass(c).line,beta,m,cclass(c).head);
map3Proc(kindPred,cclass(c).line,beta,m,cclass(c).supers);
if (isTycon(c)) {
tycon(c).kind = copyKindvar(intOf(tycon(c).kind));
#ifdef DEBUG_KINDS
- printf("%s :: ",textToStr(tycon(c).text));
+ Printf("%s :: ",textToStr(tycon(c).text));
printKind(stdout,tycon(c).kind);
- putchar('\n');
+ Putchar('\n');
#endif
} else {
Kinds ks = cclass(c).kinds;
hd(ks) = copyKindvar(intOf(hd(ks)));
}
#ifdef DEBUG_KINDS
- printf("%s :: ",textToStr(cclass(c).text));
+ Printf("%s :: ",textToStr(cclass(c).text));
printKinds(stdout,cclass(c).kinds);
- putchar('\n');
+ Putchar('\n');
#endif
}
}
* stages of static analysis.
* ------------------------------------------------------------------------*/
-Void instDefn(line,head,ms) /* process new instance definition */
-Int line; /* definition line number */
-Cell head; /* inst header :: (context,Class) */
-List ms; { /* instance members */
+Void instDefn(line,head,ms) /* process new instance definition */
+Int line; /* definition line number */
+Cell head; /* inst header :: (context,Class) */
+List ms; { /* instance members */
Inst nw = newInst();
inst(nw).line = line;
inst(nw).specifics = fst(head);
* ------------------------------------------------------------------------*/
Bool allowOverlap = FALSE; /* TRUE => allow overlapping insts */
+Name nameListMonad = NIL; /* builder function for List Monad */
static Void local checkInstDefn(in) /* Validate instance declaration */
Inst in; {
Int line = inst(in).line;
List tyvars = typeVarsIn(inst(in).head,NIL,NIL);
+ if (haskell98) { /* Check for `simple' type */
+ List tvs = NIL;
+ Cell t = arg(inst(in).head);
+ for (; isAp(t); t=fun(t)) {
+ if (!isVar(arg(t))) {
+ ERRMSG(line)
+ "syntax error in instance head (variable expected)"
+ EEND;
+ }
+ if (varIsMember(textOf(arg(t)),tvs)) {
+ ERRMSG(line) "repeated type variable \"%s\" in instance head",
+ textToStr(textOf(arg(t)))
+ EEND;
+ }
+ tvs = cons(arg(t),tvs);
+ }
+ if (isVar(t)) {
+ ERRMSG(line)
+ "syntax error in instance head (constructor expected)"
+ EEND;
+ }
+ }
+
depPredExp(line,tyvars,inst(in).head);
+
+ if (haskell98) {
+ Type h = getHead(arg(inst(in).head));
+ if (isSynonym(h)) {
+ ERRMSG(line) "Cannot use type synonym in instance head"
+ EEND;
+ }
+ }
+
map2Proc(depPredExp,line,tyvars,inst(in).specifics);
+ h98CheckCtxt(line,"instance definition",FALSE,inst(in).specifics,NIL);
inst(in).numSpecifics = length(inst(in).specifics);
inst(in).c = getHead(inst(in).head);
if (!isClass(inst(in).c)) {
insertInst(in);
if (nonNull(extractSigdecls(inst(in).implements))) {
- ERRMSG(line) "Type signature decls not permitted in instance decl"
+ ERRMSG(line)
+ "Type signature declarations not permitted in instance declaration"
+ EEND;
+ }
+ if (nonNull(extractFixdecls(inst(in).implements))) {
+ ERRMSG(line)
+ "Fixity declarations not permitted in instance declaration"
EEND;
}
inst(in).implements = classBindings("instance",
inst(in).c,
extractBindings(inst(in).implements));
inst(in).builder = newInstImp(in);
+ /*ToDo*/
+fprintf(stderr, "\npreludeLoaded query\n" );
+ if (/*!preludeLoaded &&*/ isNull(nameListMonad) && isAp(inst(in).head)
+ && fun(inst(in).head)==classMonad && arg(inst(in).head)==typeList) {
+ nameListMonad = inst(in).builder;
+ }
}
static Void local insertInst(in) /* Insert instance into class */
Int beta = newKindedVars(inst(hd(ins)).kinds);
if (unifyPred(inst(in).head,alpha,inst(hd(ins)).head,beta)) {
Cell pi = copyPred(inst(in).head,alpha);
- if (allowOverlap) { /* So long as one is more specific */
+ if (allowOverlap && !haskell98) {
Bool bef = instCompare(in,hd(ins));
Bool aft = instCompare(hd(ins),in);
if (bef && !aft) { /* in comes strictly before hd(ins)*/
static Name local newInstImp(in) /* Make definition for inst builder*/
Inst in; {
- Name b = newName(inventText());
+ Name b = newName(inventText(),in);
name(b).line = inst(in).line;
name(b).arity = inst(in).numSpecifics;
name(b).number = DFUNNAME;
inst(in).kinds = cons(copyKindvar(beta+freedom),inst(in).kinds);
}
#ifdef DEBUG_KINDS
- printf("instance ");
+ Printf("instance ");
printPred(stdout,inst(in).head);
- printf(" :: ");
+ Printf(" :: ");
printKinds(stdout,inst(in).kinds);
- putchar('\n');
+ Putchar('\n');
#endif
emptySubstitution();
}
}
#if EVAL_INSTANCES
-/* ADR addition */
-static List evalInsts = NIL;
-
Void addEvalInst(line,t,arity,ctxt) /* Add dummy instance for Eval */
Int line;
Cell t;
kindInst(in,arity);
cclass(classEval).instances
= appendOnto(cclass(classEval).instances,singleton(in));
- /* ADR addition */
- evalInsts = cons(in,evalInsts);
}
#endif
Ext e; {
Inst in = newInst();
inst(in).c = c;
- inst(in).head = ap(c,ap2(e,mkOffset(0),mkOffset(1)));
+ inst(in).head = ap(c,ap2(e,aVar,bVar));
inst(in).kinds = extKind;
- inst(in).specifics = cons(ap(classShow,mkOffset(0)),
- cons(ap(e,mkOffset(1)),
- cons(ap(c,mkOffset(1)),NIL)));
+ inst(in).specifics = cons(ap(classShow,aVar),
+ cons(ap(e,bVar),
+ cons(ap(c,bVar),NIL)));
inst(in).numSpecifics = 3;
- inst(in).builder = implementRecShw(extText(e));
+ inst(in).builder = implementRecShw(extText(e),in);
cclass(c).instances = appendOnto(cclass(c).instances,singleton(in));
return in;
}
Ext e; {
Inst in = newInst();
inst(in).c = c;
- inst(in).head = ap(c,ap2(e,mkOffset(0),mkOffset(1)));
+ inst(in).head = ap(c,ap2(e,aVar,bVar));
inst(in).kinds = extKind;
- inst(in).specifics = cons(ap(classEq,mkOffset(0)),
- cons(ap(e,mkOffset(1)),
- cons(ap(c,mkOffset(1)),NIL)));
+ inst(in).specifics = cons(ap(classEq,aVar),
+ cons(ap(e,bVar),
+ cons(ap(c,bVar),NIL)));
inst(in).numSpecifics = 3;
- inst(in).builder = implementRecEq(extText(e));
+ inst(in).builder = implementRecEq(extText(e),in);
cclass(c).instances = appendOnto(cclass(c).instances,singleton(in));
return in;
}
} while (instsChanged);
mapProc(tidyDerInst,is); /* Tidy up results */
-#if DERIVE_SHOW | DERIVE_READ
- cfunSfuns = NIL; /* Only needed to derive Read/Show */
-#endif
}
static Void local initDerInst(in) /* Prepare instance for calculation*/
inst(in).numSpecifics = beta;
#ifdef DEBUG_DERIVING
- printf("initDerInst: ");
+ Printf("initDerInst: ");
printPred(stdout,inst(in).head);
- printf("\n");
+ Printf("\n");
printContext(stdout,snd(snd(inst(in).specifics)));
- printf("\n");
+ Printf("\n");
#endif
}
Int beta = inst(in).numSpecifics;
#ifdef DEBUG_DERIVING
- printf("calcInstPreds: ");
+ Printf("calcInstPreds: ");
printPred(stdout,inst(in).head);
- printf("\n");
+ Printf("\n");
#endif
while (nonNull(ps)) {
List qs = inst(in1).specifics;
Int off = mkInt(typeOff);
if (whatIs(qs)==DERIVE) { /* Still being derived */
- for (qs=fst(snd(qs)); nonNull(hd(qs)); qs=tl(qs))
+ for (qs=fst(snd(qs)); nonNull(hd(qs)); qs=tl(qs)) {
ps = cons(pair(hd(qs),off),ps);
+ }
retain = cons(pair(off,qs),retain);
} else { /* Previously def'd inst */
for (; nonNull(qs); qs=tl(qs)) {
clearMarks();
copyPred(inst(in).head,o);
inst(in).specifics = simpleContext(ps,o);
+ h98CheckCtxt(inst(in).line,"derived instance",FALSE,inst(in).specifics,in);
inst(in).numSpecifics = length(inst(in).specifics);
#ifdef DEBUG_DERIVING
- printf("Derived instance: ");
+ Printf("Derived instance: ");
printContext(stdout,inst(in).specifics);
- printf(" ||- ");
+ Printf(" ||- ");
printPred(stdout,inst(in).head);
- printf("\n");
+ Printf("\n");
#endif
}
List imp = NIL;
Type t = getHead(arg(inst(in).head));
Class c = inst(in).c;
-#if DERIVE_EQ
- if (c==classEq)
+ if (c==classEq) {
imp = deriveEq(t);
- else
-#endif
-#if DERIVE_ORD
- if (c==classOrd)
+ } else if (c==classOrd) {
imp = deriveOrd(t);
- else
-#endif
-#if DERIVE_ENUM
- if (c==classEnum)
+ } else if (c==classEnum) {
imp = deriveEnum(t);
- else
-#endif
-#if DERIVE_IX
- if (c==classIx)
+ } else if (c==classIx) {
imp = deriveIx(t);
- else
-#endif
-#if DERIVE_SHOW
- if (c==classShow)
+ } else if (c==classShow) {
imp = deriveShow(t);
- else
-#endif
-#if DERIVE_READ
- if (c==classRead)
+ } else if (c==classRead) {
imp = deriveRead(t);
- else
-#endif
-#if DERIVE_BOUNDED
- if (c==classBounded)
+ } else if (c==classBounded) {
imp = deriveBounded(t);
- else
-#endif
- {
+ } else {
ERRMSG(inst(in).line) "Cannot derive instances of class \"%s\"",
textToStr(cclass(inst(in).c).text)
EEND;
imp);
}
+
/* --------------------------------------------------------------------------
* Default definitions; only one default definition is permitted in a
* given script file. If no default is supplied, then a standard system
} else {
defaultDefns = stdDefaults;
}
+
+ if (isNull(classNum)) {
+ classNum = findClass(findText("Num"));
+ }
+
for (ds=defaultDefns; nonNull(ds); ds=tl(ds)) {
if (isNull(provePred(NIL,NIL,ap(classNum,hd(ds))))) {
ERRMSG(defaultLine)
}
}
+
+/*-- from STG --*/
/* --------------------------------------------------------------------------
* Foreign import declarations are Hugs' equivalent of GHC's ccall mechanism.
* They are used to "import" C functions into a module.
Int l = intOf(line);
if (isNull(n)) {
- n = newName(t);
+ n = newName(t,NIL);
} else if (name(n).defn!=PREDEFINED) {
ERRMSG(l) "Redeclaration of foreign \"%s\"", textToStr(t)
EEND;
Int l = intOf(line);
if (isNull(n)) {
- n = newName(t);
+ n = newName(t,NIL);
} else if (name(n).defn!=PREDEFINED) {
ERRMSG(l) "Redeclaration of foreign \"%s\"", textToStr(t)
EEND;
implementForeignExport(p);
}
+
+
+
+#if 0
+/*-- from 98 --*/
+/* --------------------------------------------------------------------------
+ * Primitive definitions are usually only included in the first script
+ * file read - the prelude. A primitive definition associates a variable
+ * name with a string (which identifies a built-in primitive) and a type.
+ * ------------------------------------------------------------------------*/
+
+Void primDefn(line,prims,type) /* Handle primitive definitions */
+Cell line;
+List prims;
+Cell type; {
+ primDefns = cons(triple(line,prims,type),primDefns);
+}
+
+static List local checkPrimDefn(pd) /* Check primitive definition */
+Triple pd; {
+ Int line = intOf(fst3(pd));
+ List prims = snd3(pd);
+ Type type = thd3(pd);
+ emptySubstitution();
+ type = checkSigType(line,"primitive definition",fst(hd(prims)),type);
+ for (; nonNull(prims); prims=tl(prims)) {
+ Cell p = hd(prims);
+ Bool same = isVar(p);
+ Text pt = textOf(same ? p : fst(p));
+ String pr = textToStr(textOf(same ? p : snd(p)));
+ hd(prims) = addNewPrim(line,pt,pr,type);
+ }
+ return snd3(pd);
+}
+
+static Name local addNewPrim(l,vn,s,t) /* make binding of variable vn to */
+Int l; /* primitive function referred */
+Text vn; /* to by s, with given type t */
+String s;
+Cell t;{
+ Name n = findName(vn);
+
+ if (isNull(n)) {
+ n = newName(vn,NIL);
+ } else if (name(n).defn!=PREDEFINED) {
+ duplicateError(l,name(n).mod,vn,"primitive");
+ }
+
+ addPrim(l,n,s,t);
+ return n;
+}
+#endif
+
+
+
+
+
/* --------------------------------------------------------------------------
* Static analysis of patterns:
*
* complete pattern list (as is required on the lhs of a function defn).
* ------------------------------------------------------------------------*/
-static List patVars; /* List of vars bound in pattern */
+static List patVars; /* List of vars bound in pattern */
-static Cell local checkPat(line,p) /* Check valid pattern syntax */
+static Cell local checkPat(line,p) /* Check valid pattern syntax */
Int line;
Cell p; {
switch (whatIs(p)) {
case VARIDCELL :
- case VAROPCELL : addPatVar(line,p);
+ case VAROPCELL : addToPatVars(line,p);
break;
+ case INFIX : return checkPat(line,tidyInfix(line,snd(p)));
+
case AP : return checkMaybeCnkPat(line,p);
case NAME :
case QUALIDENT :
- case CONIDCELL :
+ case CONIDCELL :
case CONOPCELL : return checkApPat(line,0,p);
+#if BIGNUMS
+ case ZERONUM :
+ case POSNUM :
+ case NEGNUM :
+#endif
case WILDCARD :
case STRCELL :
case CHARCELL :
- case INTCELL :
- case BIGCELL :
case FLOATCELL : break;
+ case INTCELL : break;
- case ASPAT : addPatVar(line,fst(snd(p)));
+ case ASPAT : addToPatVars(line,fst(snd(p)));
snd(snd(p)) = checkPat(line,snd(snd(p)));
break;
case CONFLDS : depConFlds(line,p,TRUE);
break;
- case ESIGN : { Type t = snd(snd(p));
- List tvs = typeVarsIn(t,NIL,NIL);
- for (; nonNull(tvs); tvs=tl(tvs)) {
- Int beta = newKindvars(1);
- hd(btyvars) = cons(pair(hd(tvs),mkInt(beta)),
- hd(btyvars));
- }
- t = checkSigType(line,
- "pattern type",
- fst(snd(p)),
- t);
- if (isPolyType(t)
- || whatIs(t)==QUAL
- || whatIs(t)==RANK2) {
- ERRMSG(line)
- "Illegal type in pattern annotation"
- EEND;
- }
- snd(snd(p)) = t;
- fst(snd(p)) = checkPat(line,fst(snd(p)));
- }
+ case ESIGN : snd(snd(p)) = checkPatType(line,
+ "pattern",
+ fst(snd(p)),
+ snd(snd(p)));
+ fst(snd(p)) = checkPat(line,fst(snd(p)));
break;
default : ERRMSG(line) "Illegal pattern syntax"
return p;
}
-static Cell local checkMaybeCnkPat(l,p) /* Check applicative pattern with */
-Int l; /* the possibility of n+k pattern */
+static Cell local checkMaybeCnkPat(l,p)/* Check applicative pattern with */
+Int l; /* the possibility of n+k pattern */
Cell p; {
#if NPLUSK
Cell h = getHead(p);
if (argCount==2 && isVar(h) && textOf(h)==textPlus) { /* n+k */
Cell v = arg(fun(p));
- if (!isInt(arg(p)) && !isBignum(arg(p))) {
- ERRMSG(l) "Second argument in (n+k) pattern must be an integer"
- EEND;
+ if (!isInt(arg(p))) {
+ ERRMSG(l) "Second argument in (n+k) pattern must be an integer"
+ EEND;
}
-#if 0 /* can't call intOf - it might be a bignum */
if (intOf(arg(p))<=0) {
- ERRMSG(l) "Integer k in (n+k) pattern must be > 0"
- EEND;
+ ERRMSG(l) "Integer k in (n+k) pattern must be > 0"
+ EEND;
}
-#endif
- overwrite2(fun(p),ADDPAT,arg(p));
+ fst(fun(p)) = ADDPAT;
+ intValOf(fun(p)) = intOf(arg(p));
arg(p) = checkPat(l,v);
return p;
}
}
static Cell local checkApPat(line,args,p)
-Int line; /* check validity of application */
-Int args; /* of constructor to arguments */
+Int line; /* check validity of application */
+Int args; /* of constructor to arguments */
Cell p; {
switch (whatIs(p)) {
case AP : fun(p) = checkApPat(line,args+1,fun(p));
break;
#if TREX
- case EXT : if (args!=2) {
+ case EXT : h98DoesntSupport(line,"extensible records");
+ if (args!=2) {
ERRMSG(line) "Illegal record pattern"
EEND;
}
break;
#endif
- case QUALIDENT :
- if (!isQCon(p)) {
- ERRMSG(line) "Illegal use of qualified variable in pattern"
- EEND;
- }
- /* deliberate fall through */
+ case QUALIDENT : if (!isQCon(p)) {
+ ERRMSG(line)
+ "Illegal use of qualified variable in pattern"
+ EEND;
+ }
+ /* deliberate fall through */
case CONIDCELL :
case CONOPCELL : p = conDefined(line,p);
checkCfunArgs(line,p,args);
return p;
}
-static Void local addPatVar(line,v) /* add variable v to list of vars */
-Int line; /* in current pattern, checking for*/
-Cell v; { /* repeated variables. */
- Text t = textOf(v);
- List p = NIL;
- List n = patVars;
-
- for (; nonNull(n); p=n, n=tl(n)) {
- if (textOf(hd(n))==t) {
- ERRMSG(line) "Repeated variable \"%s\" in pattern",
- textToStr(t)
- EEND;
- }
- }
- if (isNull(p)) {
+static Void local addToPatVars(line,v) /* Add variable v to list of vars */
+Int line; /* in current pattern, checking */
+Cell v; { /* for repeated variables. */
+ Text t = textOf(v);
+ List p = NIL;
+ List n = patVars;
+
+ for (; nonNull(n); p=n, n=tl(n)) {
+ if (textOf(hd(n))==t) {
+ ERRMSG(line) "Repeated variable \"%s\" in pattern",
+ textToStr(t)
+ EEND;
+ }
+ }
+
+ if (isNull(p)) {
patVars = cons(v,NIL);
- } else {
+ } else {
tl(p) = cons(v,NIL);
- }
+ }
}
-static Name local conDefined(line,nm) /* check that nm is the name of a */
-Int line; /* previously defined constructor */
-Cell nm; { /* function. */
- Cell c=findQualName(line,nm);
- if (isNull(c)) {
+static Name local conDefined(line,nm) /* check that nm is the name of a */
+Int line; /* previously defined constructor */
+Cell nm; { /* function. */
+ Name n = findQualName(nm);
+ if (isNull(n)) {
ERRMSG(line) "Undefined constructor function \"%s\"", identToStr(nm)
EEND;
}
- checkIsCfun(line,c);
- return c;
+ checkIsCfun(line,n);
+ return n;
}
-static Void local checkIsCfun(line,c) /* Check that c is a constructor fn*/
+static Void local checkIsCfun(line,c) /* Check that c is a constructor fn */
Int line;
Name c; {
if (!isCfun(c)) {
}
static Void local checkCfunArgs(line,c,args)
-Int line; /* Check constructor applied with */
-Cell c; /* correct number of arguments */
+Int line; /* Check constructor applied with */
+Cell c; /* correct number of arguments */
Int args; {
- if (name(c).arity!=args) {
- ERRMSG(line) "Constructor function \"%s\" needs %d args in pattern",
- textToStr(name(c).text), name(c).arity
+ Int a = userArity(c);
+ if (a!=args) {
+ ERRMSG(line)
+ "Constructor \"%s\" must have exactly %d argument%s in pattern",
+ textToStr(name(c).text), a, ((a==1)?"":"s")
+ EEND;
+ }
+}
+
+static Cell local checkPatType(l,wh,e,t)/* Check type appearing in pattern */
+Int l;
+String wh;
+Cell e;
+Type t; {
+ List tvs = typeVarsIn(t,NIL,NIL);
+ h98DoesntSupport(l,"pattern type annotations");
+ for (; nonNull(tvs); tvs=tl(tvs)) {
+ Int beta = newKindvars(1);
+ hd(btyvars) = cons(pair(hd(tvs),mkInt(beta)), hd(btyvars));
+ }
+ t = checkSigType(l,"pattern type",e,t);
+ if (isPolyType(t) || whatIs(t)==QUAL || whatIs(t)==RANK2) {
+ ERRMSG(l) "Illegal syntax in %s type annotation", wh
EEND;
}
+ return t;
}
static Cell local applyBtyvs(pat) /* Record bound type vars in pat */
Cell pat; {
List bts = hd(btyvars);
- btyvars = tl(btyvars);
+ leaveBtyvs();
if (nonNull(bts)) {
pat = ap(BIGLAM,pair(bts,pat));
for (; nonNull(bts); bts=tl(bts)) {
* dependency and scope analysis.
* ------------------------------------------------------------------------*/
-static List bounds; /* list of lists of bound vars */
-static List bindings; /* list of lists of binds in scope */
-static List depends; /* list of lists of dependents */
+static List bounds; /* list of lists of bound vars */
+static List bindings; /* list of lists of binds in scope */
+static List depends; /* list of lists of dependents */
+
+/* bounds :: [[Var]] -- var equality used on Vars */
+/* bindings :: [[([Var],?)]] -- var equality used on Vars */
+/* depends :: [[Var]] -- pointer equality used on Vars */
-#define saveBvars() hd(bounds) /* list of bvars in current scope */
-#define restoreBvars(bs) hd(bounds)=bs /* restore list of bound variables */
+#define saveBvars() hd(bounds) /* list of bvars in current scope */
+#define restoreBvars(bs) hd(bounds)=bs /* restore list of bound variables */
-static Cell local bindPat(line,p) /* add new bound vars for pattern */
+static Cell local bindPat(line,p) /* add new bound vars for pattern */
Int line;
Cell p; {
patVars = NIL;
return p;
}
-static Void local bindPats(line,ps) /* add new bound vars for patterns */
+static Void local bindPats(line,ps) /* add new bound vars for patterns */
Int line;
List ps; {
patVars = NIL;
* known.
*
* The result of parsing a list of value declarations is a list of Eqns:
- * Eqn ::= (SIGDECL,(Line,[Var],type)) | (Expr,Rhs)
+ * Eqn ::= (SIGDECL,(Line,[Var],type))
+ * | (FIXDECL,(Line,[Op],SyntaxInt))
+ * | (Expr,Rhs)
* The ordering of the equations in this list is the reverse of the original
* ordering in the script parsed. This is a consequence of the structure of
* the parser ... but also turns out to be most convenient for the static
* - Every variable named in a type signature declaration is defined by
* one or more equations elsewhere in the script.
* - No variable has more than one type declaration.
+ * - Similar properties for fixity declarations.
*
* ------------------------------------------------------------------------*/
-#define bindingType(b) fst(snd(b)) /* type (or types) for binding */
-#define fbindAlts(b) snd(snd(b)) /*alternatives for function binding*/
+#define bindingAttr(b) fst(snd(b)) /* type(s)/fixity(ies) for binding */
+#define fbindAlts(b) snd(snd(b)) /* alternatives for function binding*/
-static List local extractSigdecls(es) /* extract the SIGDECLS from list */
-List es; { /* of equations */
- List sigDecls = NIL; /* :: [(Line,[Var],Type)] */
+static List local extractSigdecls(es) /* Extract the SIGDECLS from list */
+List es; { /* of equations */
+ List sigdecls = NIL; /* :: [(Line,[Var],Type)] */
for(; nonNull(es); es=tl(es)) {
if (fst(hd(es))==SIGDECL) { /* type-declaration? */
EEND;
}
}
- sigDecls = cons(sig,sigDecls); /* discard SIGDECL tag */
+ sigdecls = cons(sig,sigdecls); /* discard SIGDECL tag*/
}
}
- return sigDecls;
+ return sigdecls;
}
-static List local extractBindings(es) /* extract untyped bindings from */
-List es; { /* given list of equations */
+static List local extractFixdecls(es) /* Extract the FIXDECLS from list */
+List es; { /* of equations */
+ List fixdecls = NIL; /* :: [(Line,SyntaxInt,[Op])] */
+
+ for(; nonNull(es); es=tl(es)) {
+ if (fst(hd(es))==FIXDECL) { /* fixity declaration?*/
+ fixdecls = cons(snd(hd(es)),fixdecls); /* discard FIXDECL tag*/
+ }
+ }
+ return fixdecls;
+}
+
+static List local extractBindings(ds) /* extract untyped bindings from */
+List ds; { /* given list of equations */
Cell lastVar = NIL; /* = var def'd in last eqn (if any)*/
Int lastArity = 0; /* = number of args in last defn */
List bs = NIL; /* :: [Binding] */
- for(; nonNull(es); es=tl(es)) {
- Cell e = hd(es);
-
- if (fst(e)!=SIGDECL) {
- Int line = rhsLine(snd(e));
- Cell lhsHead = getHead(fst(e));
-
- switch (whatIs(lhsHead)) {
- case VARIDCELL :
- case VAROPCELL : { /* function-binding? */
- Cell newAlt = pair(getArgs(fst(e)), snd(e));
- if (nonNull(lastVar) && textOf(lhsHead)==textOf(lastVar)) {
- if (argCount!=lastArity) {
- ERRMSG(line)
- "Equations give different arities for \"%s\"",
- textToStr(textOf(lhsHead))
- EEND;
- }
- fbindAlts(hd(bs)) = cons(newAlt,fbindAlts(hd(bs)));
- }
- else {
- lastVar = lhsHead;
- lastArity = argCount;
- notDefined(line,bs,lhsHead);
- bs = cons(pair(lhsHead,
- pair(NIL,
- singleton(newAlt))),
- bs);
- }
+ for(; nonNull(ds); ds=tl(ds)) {
+ Cell d = hd(ds);
+ if (fst(d)==FUNBIND) { /* Function bindings */
+ Cell rhs = snd(snd(d));
+ Int line = rhsLine(rhs);
+ Cell lhs = fst(snd(d));
+ Cell v = getHead(lhs);
+ Cell newAlt = pair(getArgs(lhs),rhs);
+ if (!isVar(v)) {
+ internal("FUNBIND");
+ }
+ if (nonNull(lastVar) && textOf(v)==textOf(lastVar)) {
+ if (argCount!=lastArity) {
+ ERRMSG(line) "Equations give different arities for \"%s\"",
+ textToStr(textOf(v))
+ EEND;
}
- break;
+ fbindAlts(hd(bs)) = cons(newAlt,fbindAlts(hd(bs)));
+ }
+ else {
+ lastVar = v;
+ lastArity = argCount;
+ notDefined(line,bs,v);
+ bs = cons(pair(v,pair(NIL,singleton(newAlt))),bs);
+ }
- case QUALIDENT: if (isQVar(lhsHead)) {
- ERRMSG(line) "Binding for qualified variable \"%s\" not allowed",
- identToStr(lhsHead)
- EEND;
- }
- break;
- /* deliberate fall through */
-#if TREX
- case EXT :
-#endif
- case CONFLDS :
- case CONOPCELL :
- case CONIDCELL :
- case FINLIST :
- case TUPLE :
- case NAME :
- case LAZYPAT :
- case ASPAT : lastVar = NIL; /* pattern-binding? */
- patVars = NIL;
- enterBtyvs();
- fst(e) = checkPat(line,fst(e));
- if (isNull(patVars)) {
- ERRMSG(line)
- "No variables defined in lhs pattern"
- EEND;
- }
- map2Proc(notDefined,line,bs,patVars);
- bs = cons(pair(patVars,pair(NIL,e)),bs);
- if (nonNull(hd(btyvars))) {
- ERRMSG(line)
- "Sorry, no type variables are allowed in pattern binding type annotations"
- EEND;
- }
- leaveBtyvs();
- break;
-
- default : ERRMSG(line) "Improper left hand side"
- EEND;
+ } else if (fst(d)==PATBIND) { /* Pattern bindings */
+ Cell rhs = snd(snd(d));
+ Int line = rhsLine(rhs);
+ Cell pat = fst(snd(d));
+ while (whatIs(pat)==ESIGN) {/* Move type annotations to rhs */
+ Cell p = fst(snd(pat));
+ fst(snd(pat)) = rhs;
+ snd(snd(d)) = rhs = pat;
+ fst(snd(d)) = pat = p;
+ fst(rhs) = RSIGN;
}
+ if (isVar(pat)) { /* Convert simple pattern bind to */
+ notDefined(line,bs,pat);/* a function binding */
+ bs = cons(pair(pat,pair(NIL,singleton(pair(NIL,rhs)))),bs);
+ } else {
+ List vs = getPatVars(line,pat,NIL);
+ if (isNull(vs)) {
+ ERRMSG(line) "No variables defined in lhs pattern"
+ EEND;
+ }
+ map2Proc(notDefined,line,bs,vs);
+ bs = cons(pair(vs,pair(NIL,snd(d))),bs);
+ }
+ lastVar = NIL;
}
}
return bs;
}
-static List local eqnsToBindings(es) /*Convert list of equations to list*/
-List es; { /*of typed bindings */
+static List local getPatVars(line,p,vs) /* Find list of variables bound in */
+Int line; /* pattern p */
+Cell p;
+List vs; {
+ switch (whatIs(p)) {
+ case AP : do {
+ vs = getPatVars(line,arg(p),vs);
+ p = fun(p);
+ } while (isAp(p));
+ return vs; /* Ignore head of application */
+
+ case CONFLDS : { List pfs = snd(snd(p));
+ for (; nonNull(pfs); pfs=tl(pfs)) {
+ if (isVar(hd(pfs))) {
+ vs = addPatVar(line,hd(pfs),vs);
+ } else {
+ vs = getPatVars(line,snd(hd(pfs)),vs);
+ }
+ }
+ }
+ return vs;
+
+ case FINLIST : { List ps = snd(p);
+ for (; nonNull(ps); ps=tl(ps)) {
+ vs = getPatVars(line,hd(ps),vs);
+ }
+ }
+ return vs;
+
+ case ESIGN : return getPatVars(line,fst(snd(p)),vs);
+
+ case LAZYPAT :
+ case NEG :
+ case ONLY :
+ case INFIX : return getPatVars(line,snd(p),vs);
+
+ case ASPAT : return addPatVar(line,fst(snd(p)),
+ getPatVars(line,snd(snd(p)),vs));
+
+ case VARIDCELL :
+ case VAROPCELL : return addPatVar(line,p,vs);
+
+ case CONIDCELL :
+ case CONOPCELL :
+ case QUALIDENT :
+ case INTCELL :
+ case FLOATCELL :
+ case CHARCELL :
+ case STRCELL :
+ case NAME :
+ case WILDCARD : return vs;
+
+ default : internal("getPatVars");
+ }
+ return vs;
+}
+
+static List local addPatVar(line,v,vs) /* Add var to list of previously */
+Int line; /* encountered variables */
+Cell v;
+List vs; {
+ if (varIsMember(textOf(v),vs)) {
+ ERRMSG(line) "Repeated use of variable \"%s\" in pattern binding",
+ textToStr(textOf(v))
+ EEND;
+ }
+ return cons(v,vs);
+}
+
+static List local eqnsToBindings(es,ts,cs,ps)
+List es; /* Convert list of equations to */
+List ts; /* list of typed bindings */
+List cs;
+List ps; {
List bs = extractBindings(es);
- map1Proc(addSigDecl,bs,extractSigdecls(es));
+ map1Proc(addSigdecl,bs,extractSigdecls(es));
+ map4Proc(addFixdecl,bs,ts,cs,ps,extractFixdecls(es));
return bs;
}
-static Void local notDefined(line,bs,v) /* check if name already defined in*/
-Int line; /* list of bindings */
+static Void local notDefined(line,bs,v)/* check if name already defined in */
+Int line; /* list of bindings */
List bs;
Cell v; {
if (nonNull(findBinding(textOf(v),bs))) {
}
}
-static Cell local findBinding(t,bs) /* look for binding for variable t */
-Text t; /* in list of bindings bs */
+static Cell local findBinding(t,bs) /* look for binding for variable t */
+Text t; /* in list of bindings bs */
List bs; {
for (; nonNull(bs); bs=tl(bs)) {
if (isVar(fst(hd(bs)))) { /* function-binding? */
if (textOf(fst(hd(bs)))==t) {
return hd(bs);
}
- } else if (nonNull(varIsMember(t,fst(hd(bs))))) { /* pattern-binding? */
+ } else if (nonNull(varIsMember(t,fst(hd(bs))))){/* pattern-binding?*/
return hd(bs);
}
}
return NIL;
}
-static Void local addSigDecl(bs,sigDecl)/* add type information to bindings*/
-List bs; /* :: [Binding] */
-Cell sigDecl; { /* :: (Line,[Var],Type) */
- Int line = intOf(fst3(sigDecl));
- Cell vs = snd3(sigDecl);
- Cell type = checkSigType(line,"type declaration",hd(vs),thd3(sigDecl));
-
- map3Proc(setType,line,type,bs,vs);
-}
-
-static Void local setType(line,type,bs,v)
-Int line; /* Set type of variable */
-Cell type;
-Cell v;
-List bs; {
+static Cell local getAttr(bs,v) /* Locate type/fixity attribute */
+List bs; /* for variable v in bindings bs */
+Cell v; {
Text t = textOf(v);
Cell b = findBinding(t,bs);
- if (isNull(b)) {
- ERRMSG(line) "Type declaration for variable \"%s\" with no body",
- textToStr(t)
- EEND;
- }
-
- if (isVar(fst(b))) { /* function-binding? */
- if (isNull(bindingType(b))) {
- bindingType(b) = type;
- return;
+ if (isNull(b)) { /* No binding */
+ return NIL;
+ } else if (isVar(fst(b))) { /* func binding? */
+ if (isNull(bindingAttr(b))) {
+ bindingAttr(b) = pair(NIL,NIL);
}
- } else { /* pattern-binding? */
+ return bindingAttr(b);
+ } else { /* pat binding? */
List vs = fst(b);
- List ts = bindingType(b);
+ List as = bindingAttr(b);
- if (isNull(ts)) {
- bindingType(b) = ts = replicate(length(vs),NIL);
+ if (isNull(as)) {
+ bindingAttr(b) = as = replicate(length(vs),NIL);
}
+
while (nonNull(vs) && t!=textOf(hd(vs))) {
vs = tl(vs);
- ts = tl(ts);
+ as = tl(as);
}
- if (nonNull(vs) && isNull(hd(ts))) {
- hd(ts) = type;
- return;
+ if (isNull(vs)) {
+ internal("getAttr");
+ } else if (isNull(hd(as))) {
+ hd(as) = pair(NIL,NIL);
}
+ return hd(as);
}
+}
- ERRMSG(line) "Repeated type declaration for \"%s\"", textToStr(t)
+static Void local addSigdecl(bs,sigdecl)/* add type information to bindings*/
+List bs; /* :: [Binding] */
+Cell sigdecl; { /* :: (Line,[Var],Type) */
+ Int l = intOf(fst3(sigdecl));
+ List vs = snd3(sigdecl);
+ Type type = checkSigType(l,"type declaration",hd(vs),thd3(sigdecl));
+
+ for (; nonNull(vs); vs=tl(vs)) {
+ Cell v = hd(vs);
+ Pair attr = getAttr(bs,v);
+ if (isNull(attr)) {
+ ERRMSG(l) "Missing binding for variable \"%s\" in type signature",
+ textToStr(textOf(v))
+ EEND;
+ } else if (nonNull(fst(attr))) {
+ ERRMSG(l) "Repeated type signature for \"%s\"",
+ textToStr(textOf(v))
+ EEND;
+ }
+ fst(attr) = type;
+ }
+}
+
+static Void local addFixdecl(bs,ts,cs,ps,fixdecl)
+List bs;
+List ts;
+List cs;
+List ps;
+Triple fixdecl; {
+ Int line = intOf(fst3(fixdecl));
+ List ops = snd3(fixdecl);
+ Cell sy = thd3(fixdecl);
+
+ for (; nonNull(ops); ops=tl(ops)) {
+ Cell op = hd(ops);
+ Text t = textOf(op);
+ Cell attr = getAttr(bs,op);
+ if (nonNull(attr)) { /* Found name in binding? */
+ if (nonNull(snd(attr))) {
+ dupFixity(line,t);
+ }
+ snd(attr) = sy;
+ } else { /* Look in tycons, classes, prims */
+ Name n = NIL;
+ List ts1 = ts;
+ List cs1 = cs;
+ List ps1 = ps;
+ for (; isNull(n) && nonNull(ts1); ts1=tl(ts1)) { /* tycons */
+ Tycon tc = hd(ts1);
+ if (tycon(tc).what==DATATYPE || tycon(tc).what==NEWTYPE) {
+ n = nameIsMember(t,tycon(tc).defn);
+ }
+ }
+ for (; isNull(n) && nonNull(cs1); cs1=tl(cs1)) { /* classes */
+ n = nameIsMember(t,cclass(hd(cs1)).members);
+ }
+ for (; isNull(n) && nonNull(ps1); ps1=tl(ps1)) { /* prims */
+ n = nameIsMember(t,hd(ps1));
+ }
+
+ if (isNull(n)) {
+ missFixity(line,t);
+ } else if (name(n).syntax!=NO_SYNTAX) {
+ dupFixity(line,t);
+ }
+ name(n).syntax = intOf(sy);
+ }
+ }
+}
+
+static Void local dupFixity(line,t) /* Report repeated fixity decl */
+Int line;
+Text t; {
+ ERRMSG(line)
+ "Repeated fixity declaration for operator \"%s\"", textToStr(t)
+ EEND;
+}
+
+static Void local missFixity(line,t) /* Report missing op for fixity */
+Int line;
+Text t; {
+ ERRMSG(line)
+ "Cannot find binding for operator \"%s\" in fixity declaration",
+ textToStr(t)
EEND;
}
/* --------------------------------------------------------------------------
+ * Dealing with infix operators:
+ *
+ * Expressions involving infix operators or unary minus are parsed as
+ * elements of the following type:
+ *
+ * data InfixExp = Only Exp | Neg InfixExp | Infix InfixExp Op Exp
+ *
+ * (The algorithms here do not assume that negation can be applied only once,
+ * i.e., that - - x is a syntax error, as required by the Haskell report.
+ * Instead, that restriction is captured by the grammar itself, given above.)
+ *
+ * There are rules of precedence and grouping, expressed by two functions:
+ *
+ * prec :: Op -> Int; assoc :: Op -> Assoc (Assoc = {L, N, R})
+ *
+ * InfixExp values are rearranged accordingly when a complete expression
+ * has been read using a simple shift-reduce parser whose result may be taken
+ * to be a value of the following type:
+ *
+ * data Exp = Atom Int | Negate Exp | Apply Op Exp Exp | Error String
+ *
+ * The machine on which this parser is based can be defined as follows:
+ *
+ * tidy :: InfixExp -> [(Op,Exp)] -> Exp
+ * tidy (Only a) [] = a
+ * tidy (Only a) ((o,b):ss) = tidy (Only (Apply o a b)) ss
+ * tidy (Infix a o b) [] = tidy a [(o,b)]
+ * tidy (Infix a o b) ((p,c):ss)
+ * | shift o p = tidy a ((o,b):(p,c):ss)
+ * | red o p = tidy (Infix a o (Apply p b c)) ss
+ * | ambig o p = Error "ambiguous use of operators"
+ * tidy (Neg e) [] = tidy (tidyNeg e) []
+ * tidy (Neg e) ((o,b):ss)
+ * | nshift o = tidy (Neg (underNeg o b e)) ss
+ * | nred o = tidy (tidyNeg e) ((o,b):ss)
+ * | nambig o = Error "illegal use of negation"
+ *
+ * At each stage, the parser can either shift, reduce, accept, or error.
+ * The transitions when dealing with juxtaposed operators o and p are
+ * determined by the following rules:
+ *
+ * shift o p = (prec o > prec p)
+ * || (prec o == prec p && assoc o == L && assoc p == L)
+ *
+ * red o p = (prec o < prec p)
+ * || (prec o == prec p && assoc o == R && assoc p == R)
+ *
+ * ambig o p = (prec o == prec p)
+ * && (assoc o == N || assoc p == N || assoc o /= assoc p)
+ *
+ * The transitions when dealing with juxtaposed unary minus and infix
+ * operators are as follows. The precedence of unary minus (infixl 6) is
+ * hardwired in to these definitions, as it is to the definitions of the
+ * Haskell grammar in the official report.
+ *
+ * nshift o = (prec o > 6)
+ * nred o = (prec o < 6) || (prec o == 6 && assoc o == L)
+ * nambig o = prec o == 6 && (assoc o == R || assoc o == N)
+ *
+ * An InfixExp of the form (Neg e) means negate the last thing in
+ * the InfixExp e; we can force this negation using:
+ *
+ * tidyNeg :: OpExp -> OpExp
+ * tidyNeg (Only e) = Only (Negate e)
+ * tidyNeg (Infix a o b) = Infix a o (Negate b)
+ * tidyNeg (Neg e) = tidyNeg (tidyNeg e)
+ *
+ * On the other hand, if we want to sneak application of an infix operator
+ * under a negation, then we use:
+ *
+ * underNeg :: Op -> Exp -> OpExp -> OpExp
+ * underNeg o b (Only e) = Only (Apply o e b)
+ * underNeg o b (Neg e) = Neg (underNeg o b e)
+ * underNeg o b (Infix e p f) = Infix e p (Apply o f b)
+ *
+ * As a concession to efficiency, we lower the number of calls to syntaxOf
+ * by keeping track of the values of sye, sys throughout the process. The
+ * value APPLIC is used to indicate that the syntax value is unknown.
+ * ------------------------------------------------------------------------*/
+
+static Cell local tidyInfix(line,e) /* Convert infixExp to Exp */
+Int line;
+Cell e; { /* :: OpExp */
+ Cell s = NIL; /* :: [(Op,Exp)] */
+ Syntax sye = APPLIC; /* Syntax of op in e (init unknown)*/
+ Syntax sys = APPLIC; /* Syntax of op in s (init unknown)*/
+ Cell d = e;
+
+ while (fst(d)!=ONLY) { /* Attach fixities to operators */
+ if (fst(d)==NEG) {
+ d = snd(d);
+ } else {
+ fun(fun(d)) = attachFixity(line,fun(fun(d)));
+ d = arg(fun(d));
+ }
+ }
+
+ for (;;)
+ switch (whatIs(e)) {
+ case ONLY : e = snd(e);
+ while (nonNull(s)) {
+ Cell next = arg(fun(s));
+ arg(fun(s)) = e;
+ fun(fun(s)) = snd(fun(fun(s)));
+ e = s;
+ s = next;
+ }
+ return e;
+
+ case NEG : if (nonNull(s)) {
+ if (sys==APPLIC) { /* calculate sys */
+ sys = intOf(fst(fun(fun(s))));
+ }
+
+ if (precOf(sys)==UMINUS_PREC && /* nambig */
+ assocOf(sys)!=UMINUS_ASSOC) {
+ ERRMSG(line)
+ "Ambiguous use of unary minus with \""
+ ETHEN ERREXPR(snd(fun(fun(s))));
+ ERRTEXT "\""
+ EEND;
+ }
+
+ if (precOf(sys)>UMINUS_PREC) { /* nshift */
+ Cell e1 = snd(e);
+ Cell t = s;
+ s = arg(fun(s));
+ while (whatIs(e1)==NEG)
+ e1 = snd(e1);
+ arg(fun(t)) = arg(e1);
+ fun(fun(t)) = snd(fun(fun(t)));
+ arg(e1) = t;
+ sys = APPLIC;
+ continue;
+ }
+ }
+
+ /* Intentional fall-thru for nreduce and isNull(s) */
+
+ { Cell prev = e; /* e := tidyNeg e */
+ Cell temp = arg(prev);
+ Int nneg = 1;
+ for (; whatIs(temp)==NEG; nneg++) {
+ fun(prev) = nameNegate;
+ prev = temp;
+ temp = arg(prev);
+ }
+ if (isInt(arg(temp))) { /* special cases */
+ if (nneg&1) /* for literals */
+ arg(temp) = mkInt(-intOf(arg(temp)));
+ }
+#if BIGNUMS
+ else if (isBignum(arg(temp))) {
+ if (nneg&1)
+ arg(temp) = bigNeg(arg(temp));
+ }
+#endif
+ else if (isFloat(arg(temp))) {
+ if (nneg&1)
+ arg(temp) = mkFloat(-floatOf(arg(temp)));
+ }
+ else {
+ fun(prev) = nameNegate;
+ arg(prev) = arg(temp);
+ arg(temp) = e;
+ }
+ e = temp;
+ }
+ continue;
+
+ default : if (isNull(s)) {/* Move operation onto empty stack */
+ Cell next = arg(fun(e));
+ s = e;
+ arg(fun(s)) = NIL;
+ e = next;
+ sys = sye;
+ sye = APPLIC;
+ }
+ else { /* deal with pair of operators */
+
+ if (sye==APPLIC) { /* calculate sys and sye */
+ sye = intOf(fst(fun(fun(e))));
+ }
+ if (sys==APPLIC) {
+ sys = intOf(fst(fun(fun(s))));
+ }
+
+ if (precOf(sye)==precOf(sys) && /* ambig */
+ (assocOf(sye)!=assocOf(sys) ||
+ assocOf(sye)==NON_ASS)) {
+ ERRMSG(line) "Ambiguous use of operator \""
+ ETHEN ERREXPR(snd(fun(fun(e))));
+ ERRTEXT "\" with \""
+ ETHEN ERREXPR(snd(fun(fun(s))));
+ ERRTEXT "\""
+ EEND;
+ }
+
+ if (precOf(sye)>precOf(sys) || /* shift */
+ (precOf(sye)==precOf(sys) &&
+ assocOf(sye)==LEFT_ASS &&
+ assocOf(sys)==LEFT_ASS)) {
+ Cell next = arg(fun(e));
+ arg(fun(e)) = s;
+ s = e;
+ e = next;
+ sys = sye;
+ sye = APPLIC;
+ }
+ else { /* reduce */
+ Cell next = arg(fun(s));
+ arg(fun(s)) = arg(e);
+ fun(fun(s)) = snd(fun(fun(s)));
+ arg(e) = s;
+ s = next;
+ sys = APPLIC;
+ /* sye unchanged */
+ }
+ }
+ continue;
+ }
+}
+
+static Pair local attachFixity(line,op) /* Attach fixity to operator in an */
+Int line; /* infix expression */
+Cell op; {
+ Syntax sy = DEF_OPSYNTAX;
+
+ switch (whatIs(op)) {
+ case VAROPCELL :
+ case VARIDCELL : if ((sy=lookupSyntax(textOf(op)))==NO_SYNTAX) {
+ Name n = findName(textOf(op));
+ if (isNull(n)) {
+ ERRMSG(line) "Undefined variable \"%s\"",
+ textToStr(textOf(op))
+ EEND;
+ }
+ sy = syntaxOf(n);
+ op = n;
+ }
+ break;
+
+ case CONOPCELL :
+ case CONIDCELL : sy = syntaxOf(op = conDefined(line,op));
+ break;
+
+ case QUALIDENT : { Name n = findQualName(op);
+ if (nonNull(n)) {
+ op = n;
+ sy = syntaxOf(n);
+ } else {
+ ERRMSG(line)
+ "Undefined qualified variable \"%s\"",
+ identToStr(op)
+ EEND;
+ }
+ }
+ break;
+ }
+ if (sy==APPLIC) {
+ sy = DEF_OPSYNTAX;
+ }
+ return pair(mkInt(sy),op); /* Pair fixity with (possibly) */
+ /* translated operator */
+}
+
+static Syntax local lookupSyntax(t) /* Try to find fixity for var in */
+Text t; { /* enclosing bindings */
+ List bounds1 = bounds;
+ List bindings1 = bindings;
+
+ while (nonNull(bindings1)) {
+ if (nonNull(varIsMember(t,hd(bounds1)))) {
+ return DEF_OPSYNTAX;
+ } else {
+ Cell b = findBinding(t,hd(bindings1));
+ if (nonNull(b)) {
+ Cell a = fst(snd(b));
+ if (isVar(fst(b))) { /* Function binding */
+ if (nonNull(a) && nonNull(snd(a))) {
+ return intOf(snd(a));
+ }
+ } else { /* Pattern binding */
+ List vs = fst(b);
+ while (nonNull(vs) && nonNull(a)) {
+ if (t==textOf(hd(vs))) {
+ if (nonNull(hd(a)) && isInt(snd(hd(a)))) {
+ return intOf(snd(hd(a)));
+ }
+ break;
+ }
+ vs = tl(vs);
+ a = tl(a);
+ }
+ }
+ return DEF_OPSYNTAX;
+ }
+ }
+ bounds1 = tl(bounds1);
+ bindings1 = tl(bindings1);
+ }
+ return NO_SYNTAX;
+}
+
+/* --------------------------------------------------------------------------
* To facilitate dependency analysis, lists of bindings are temporarily
* augmented with an additional field, which is used in two ways:
* - to build the `adjacency lists' for the dependency graph. Represented by
* Using this extra field, the type of each list of declarations during
* dependency analysis is [Binding'] where:
*
- * Binding' ::= (Var, (Dep, (Type, [Alt]))) -- function binding
- * | ([Var], (Dep, ([Type], (Pat,Rhs)))) -- pattern binding
+ * Binding' ::= (Var, (Attr, (Dep, [Alt]))) -- function binding
+ * | ([Var], ([Attr], (Dep, (Pat,Rhs)))) -- pattern binding
*
* ------------------------------------------------------------------------*/
-#define depVal(d) (fst(snd(d))) /* Access to dependency information*/
-
+#define depVal(d) (fst(snd(snd(d)))) /* Access to dependency information*/
+
static List local dependencyAnal(bs) /* Separate lists of bindings into */
List bs; { /* mutually recursive groups in */
- /* order of dependency */
-
mapProc(addDepField,bs); /* add extra field for dependents */
mapProc(depBinding,bs); /* find dependents of each binding */
bs = bscc(bs); /* sort to strongly connected comps*/
mapProc(remDepField,bs); /* remove dependency info field */
- return bs;
-}
-
+ return bs;
+}
+
static List local topDependAnal(bs) /* Like dependencyAnal(), but at */
List bs; { /* top level, reporting on progress*/
- List xs;
- Int i = 0;
-
- setGoal("Dependency analysis",(Target)(length(bs)));
- mapProc(addDepField,bs); /* add extra field for dependents */
- for (xs=bs; nonNull(xs); xs=tl(xs)) {
- emptySubstitution();
- depBinding(hd(xs));
- soFar((Target)(i++));
- }
- bs = bscc(bs); /* sort to strongly connected comps*/
- mapProc(remDepField,bs); /* remove dependency info field */
- done();
- return bs;
-}
-
-static Void local addDepField(b) /* add extra field to binding to */
-Cell b; { /* hold list of dependents */
- snd(b) = pair(NIL,snd(b));
-}
-
-static Void local remDepField(bs) /* remove dependency field from */
-List bs; { /* list of bindings */
- mapProc(remDepField1,bs);
-}
-
-static Void local remDepField1(b) /* remove dependency field from */
-Cell b; { /* single binding */
- snd(b) = snd(snd(b));
-}
-
-static Void local clearScope() { /* initialise dependency scoping */
- bounds = NIL;
- bindings = NIL;
- depends = NIL;
-}
-
-static Void local withinScope(bs) /* enter scope of bindings bs */
-List bs; {
- bounds = cons(NIL,bounds);
- bindings = cons(bs,bindings);
- depends = cons(NIL,depends);
-}
-
-static Void local leaveScope() { /* leave scope of last withinScope */
+ List xs;
+ Int i = 0;
+
+ setGoal("Dependency analysis",(Target)(length(bs)));
+ mapProc(addDepField,bs); /* add extra field for dependents */
+ for (xs=bs; nonNull(xs); xs=tl(xs)) {
+ emptySubstitution();
+ depBinding(hd(xs));
+ soFar((Target)(i++));
+ }
+ bs = bscc(bs); /* sort to strongly connected comps */
+ mapProc(remDepField,bs); /* remove dependency info field */
+ done();
+ return bs;
+}
+
+static Void local addDepField(b) /* add extra field to binding to */
+Cell b; { /* hold list of dependents */
+ snd(snd(b)) = pair(NIL,snd(snd(b)));
+}
+
+static Void local remDepField(bs) /* remove dependency field from */
+List bs; { /* list of bindings */
+ mapProc(remDepField1,bs);
+}
+
+static Void local remDepField1(b) /* remove dependency field from */
+Cell b; { /* single binding */
+ snd(snd(b)) = snd(snd(snd(b)));
+}
+
+static Void local clearScope() { /* initialise dependency scoping */
+ bounds = NIL;
+ bindings = NIL;
+ depends = NIL;
+}
+
+static Void local withinScope(bs) /* Enter scope of bindings bs */
+List bs; {
+ bounds = cons(NIL,bounds);
+ bindings = cons(bs,bindings);
+ depends = cons(NIL,depends);
+}
+
+static Void local leaveScope() { /* Leave scope of last withinScope */
+ List bs = hd(bindings); /* Remove fixity info from binds */
+ Bool toplevel = isNull(tl(bindings));
+ for (; nonNull(bs); bs=tl(bs)) {
+ Cell b = hd(bs);
+ if (isVar(fst(b))) { /* Variable binding */
+ Cell a = fst(snd(b));
+ if (isPair(a)) {
+ if (toplevel) {
+ saveSyntax(fst(b),snd(a));
+ }
+ fst(snd(b)) = fst(a);
+ }
+ } else { /* Pattern binding */
+ List vs = fst(b);
+ List as = fst(snd(b));
+ while (nonNull(vs) && nonNull(as)) {
+ if (isPair(hd(as))) {
+ if (toplevel) {
+ saveSyntax(hd(vs),snd(hd(as)));
+ }
+ hd(as) = fst(hd(as));
+ }
+ vs = tl(vs);
+ as = tl(as);
+ }
+ }
+ }
bounds = tl(bounds);
bindings = tl(bindings);
depends = tl(depends);
}
+static Void local saveSyntax(v,sy) /* Save syntax of top-level var */
+Cell v; /* in corresponding Name */
+Cell sy; {
+ Name n = findName(textOf(v));
+ if (isNull(n) || name(n).syntax!=NO_SYNTAX) {
+ internal("saveSyntax");
+ }
+ if (nonNull(sy)) {
+ name(n).syntax = intOf(sy);
+ }
+}
+
/* --------------------------------------------------------------------------
* As a side effect of the dependency analysis we also make the following
* checks:
* - No free (i.e. unbound) variables are used in the declaration list.
* ------------------------------------------------------------------------*/
-static Void local depBinding(b) /* find dependents of binding */
+static Void local depBinding(b) /* find dependents of binding */
Cell b; {
- Cell defpart = snd(snd(snd(b))); /* definition part of binding */
+ Cell defpart = snd(snd(snd(b))); /* definition part of binding */
hd(depends) = NIL;
- if (isVar(fst(b))) { /* function-binding? */
+ if (isVar(fst(b))) { /* function-binding? */
mapProc(depAlt,defpart);
- if (isNull(fst(snd(snd(b))))) { /* Save dep info for implicitly */
- fst(snd(snd(b))) = ap(IMPDEPS,hd(depends)); /* typed var binds */
+ if (isNull(fst(snd(b)))) { /* Save dep info if no type sig */
+ fst(snd(b)) = pair(ap(IMPDEPS,hd(depends)),NIL);
+ } else if (isNull(fst(fst(snd(b))))) {
+ fst(fst(snd(b))) = ap(IMPDEPS,hd(depends));
}
- } else { /* pattern-binding? */
+ } else { /* pattern-binding? */
+ Int line = rhsLine(snd(defpart));
+ enterBtyvs();
+ patVars = NIL;
+ fst(defpart) = checkPat(line,fst(defpart));
depRhs(snd(defpart));
+#if 0
+ if (nonNull(hd(btyvars))) {
+ ERRMSG(line)
+ "Sorry, no type variables are allowed in pattern binding type annotations"
+ EEND;
+ }
+#endif
+ fst(defpart) = applyBtyvs(fst(defpart));
}
depVal(b) = hd(depends);
}
-static Void local depDefaults(c) /* dependency analysis on defaults */
-Class c; { /* from class definition */
+static Void local depDefaults(c) /* dependency analysis on defaults */
+Class c; { /* from class definition */
depClassBindings(cclass(c).defaults);
}
-static Void local depInsts(in) /* dependency analysis on instance */
-Inst in; { /* bindings */
+static Void local depInsts(in) /* dependency analysis on instance */
+Inst in; { /* bindings */
depClassBindings(inst(in).implements);
}
-static Void local depClassBindings(bs) /* dependency analysis on list of */
-List bs; { /* bindings, possibly containing */
- for (; nonNull(bs); bs=tl(bs)) { /* NIL bindings ... */
- if (nonNull(hd(bs))) { /* No need to add extra field for */
- mapProc(depAlt,snd(hd(bs))); /* dependency information ... */
+static Void local depClassBindings(bs) /* dependency analysis on list of */
+List bs; { /* bindings, possibly containing */
+ for (; nonNull(bs); bs=tl(bs)) { /* NIL bindings ... */
+ if (nonNull(hd(bs))) { /* No need to add extra field for */
+ mapProc(depAlt,snd(hd(bs)));/* dependency information... */
}
}
}
case GUARDED : mapProc(depGuard,snd(r));
break;
- case LETREC : fst(snd(r)) = eqnsToBindings(fst(snd(r)));
+ case LETREC : fst(snd(r)) = eqnsToBindings(fst(snd(r)),NIL,NIL,NIL);
withinScope(fst(snd(r)));
fst(snd(r)) = dependencyAnal(fst(snd(r)));
hd(depends) = fst(snd(r));
leaveScope();
break;
+ case RSIGN : snd(snd(r)) = checkPatType(rhsLine(fst(snd(r))),
+ "result",
+ rhsExpr(fst(snd(r))),
+ snd(snd(r)));
+ depRhs(fst(snd(r)));
+ break;
+
default : snd(r) = depExpr(intOf(fst(r)),snd(r));
break;
}
}
-static Void local depGuard(g) /*find dependents of single guarded*/
-Cell g; { /* expression */
+static Void local depGuard(g) /* find dependents of single guarded*/
+Cell g; { /* expression */
depPair(intOf(fst(g)),snd(g));
}
-static Cell local depExpr(line,e) /* find dependents of expression */
+static Cell local depExpr(line,e) /* find dependents of expression */
Int line;
Cell e; {
switch (whatIs(e)) {
return conDefined(line,e);
}
+ case INFIX : return depExpr(line,tidyInfix(line,snd(e)));
+
#if TREX
case RECSEL : break;
break;
#endif
+#if BIGNUMS
+ case ZERONUM :
+ case POSNUM :
+ case NEGNUM :
+#endif
case NAME :
case TUPLE :
case STRCELL :
case CHARCELL :
- case INTCELL :
- case BIGCELL :
- case FLOATCELL : break;
+ case FLOATCELL :
+ case INTCELL : break;
case COND : depTriple(line,snd(e));
break;
case FINLIST : map1Over(depExpr,line,snd(e));
break;
- case LETREC : fst(snd(e)) = eqnsToBindings(fst(snd(e)));
+ case LETREC : fst(snd(e)) = eqnsToBindings(fst(snd(e)),NIL,NIL,NIL);
withinScope(fst(snd(e)));
fst(snd(e)) = dependencyAnal(fst(snd(e)));
hd(depends) = fst(snd(e));
EEND;
#endif
- default : internal("in depExpr");
+ default : internal("depExpr");
}
return e;
}
Int l;
Cell e;
List qs; {
- if (isNull(qs))
+ if (isNull(qs)) {
fst(e) = depExpr(l,fst(e));
- else {
+ } else {
Cell q = hd(qs);
List qs1 = tl(qs);
switch (whatIs(q)) {
}
break;
- case QWHERE : snd(q) = eqnsToBindings(snd(q));
+ case QWHERE : snd(q) = eqnsToBindings(snd(q),NIL,NIL,NIL);
withinScope(snd(q));
snd(q) = dependencyAnal(snd(q));
hd(depends) = snd(q);
}
n = findBinding(t,hd(bindings1)); /* look for t in var bindings */
if (nonNull(n)) {
- if (!cellIsMember(n,hd(depends1)))
- hd(depends1) = cons(n,hd(depends1));
+ if (!cellIsMember(n,hd(depends1))) {
+ hd(depends1) = cons(n,hd(depends1));
+ }
return (isVar(fst(n)) ? fst(n) : e);
}
EEND;
}
- if (name(n).mod != thisModule) {
+#if !IGNORE_MODULES
+ if (!moduleThisScript(name(n).mod)) {
return n;
}
+#endif
/* Later phases of the system cannot cope if we resolve references
* to unprocessed objects too early. This is the main reason that
* we cannot cope with recursive modules at the moment.
*/
- return n;
+ return e;
}
static Cell local depQVar(line,e)/* register occurrence of qualified variable */
Int line;
Cell e; {
- Cell n = findQualName(line,e);
+ Name n = findQualName(e);
if (isNull(n)) { /* check global definitions */
ERRMSG(line) "Undefined qualified variable \"%s\"", identToStr(e)
EEND;
}
+#if !IGNORE_MODULES
if (name(n).mod != currentModule) {
return n;
}
+#endif
if (fst(e) == VARIDCELL) {
e = mkVar(qtextOf(e));
} else {
if (!isP && isPair(name(c).defn)) { /* Check that banged fields defined*/
List scs = fst(name(c).defn); /* List of strict components */
Type t = name(c).type;
- Int a = name(c).arity;
+ Int a = userArity(c);
List fs = snd(snd(e));
List ss;
if (isPolyType(t)) { /* Find tycon that c belongs to */
if (whatIs(t)==QUAL) {
t = snd(snd(t));
}
+ if (whatIs(t)==CDICTS) {
+ t = snd(snd(t));
+ }
while (0<a--) {
t = arg(t);
}
Name s;
if (isVar(fb)) { /* expand var to var = var */
+ h98DoesntSupport(l,"missing field bindings");
fb = hd(fs) = pair(fb,fb);
}
- s = findQualName(l,fst(fb)); /* check for selector */
+
+ s = findQualName(fst(fb)); /* check for selector */
if (nonNull(s) && isSfun(s)) {
fst(fb) = s;
} else {
if (isNull(ss)) { /* for first named selector */
List scs = name(s).defn; /* calculate list of constructors */
- for (; nonNull(scs); scs=tl(scs))
+ for (; nonNull(scs); scs=tl(scs)) {
cs = cons(fst(hd(scs)),cs);
+ }
ss = singleton(s); /* initialize selector list */
} else { /* for subsequent selectors */
List ds = cs; /* intersect constructor lists */
List exts = NIL; /* more efficient. */
Cell r = e;
+ h98DoesntSupport(line,"extensible records");
do { /* build up list of extensions */
Text t = extText(fun(fun(r)));
String s = textToStr(t);
}
#endif
+
/* --------------------------------------------------------------------------
* Several parts of this program require an algorithm for sorting a list
* of values (with some added dependency information) into a list of strongly
#define SCC2 tcscc /* make scc algorithm for Tycons */
#define LOWLINK tclowlink
#define DEPENDS(c) (isTycon(c) ? tycon(c).kind : cclass(c).kinds)
-#define SETDEPENDS(c,v) if(isTycon(c))tycon(c).kind=v;else cclass(c).kinds=v
+#define SETDEPENDS(c,v) if(isTycon(c)) tycon(c).kind=v; else cclass(c).kinds=v
#include "scc.c"
#undef SETDEPENDS
#undef DEPENDS
}
Void checkDefns() { /* Top level static analysis */
+#if !IGNORE_MODULES
+ Module thisModule = lastModule();
+#endif
staticAnalysis(RESET);
- thisModule = lastModule();
+
+#if !IGNORE_MODULES
setCurrModule(thisModule);
/* Resolve module references */
mapProc(checkQualImport, module(thisModule).qualImports);
mapProc(checkUnqualImport,unqualImports);
-
- /* Add implicit import declarations - if Prelude has been loaded */
- {
- Module modulePrelude = findModule(findText("Prelude"));
- if (nonNull(modulePrelude)) {
- /* Add "import Prelude" if there`s no explicit import */
- if (thisModule != modulePrelude
- && isNull(cellAssoc(modulePrelude,unqualImports))
- && isNull(cellRevAssoc(modulePrelude,module(thisModule).qualImports))) {
- unqualImports = cons(pair(modulePrelude,DOTDOT),unqualImports);
- }
- /* Add "import qualified Prelude" */
- module(thisModule).qualImports=cons(pair(conPrelude,modulePrelude),
- module(thisModule).qualImports);
- }
+ /* Add "import Prelude" if there`s no explicit import */
+ if (thisModule!=modulePrelude
+ && isNull(cellAssoc(modulePrelude,unqualImports))
+ && isNull(cellRevAssoc(modulePrelude,module(thisModule).qualImports))) {
+ unqualImports = cons(pair(modulePrelude,DOTDOT),unqualImports);
+ } else {
+ /* Every module (including the Prelude) implicitly contains
+ * "import qualified Prelude"
+ */
+ module(thisModule).qualImports=cons(pair(mkCon(textPrelude),modulePrelude),
+ module(thisModule).qualImports);
}
- map1Proc(checkImportList, thisModule, unqualImports);
+ mapProc(checkImportList, unqualImports);
+#endif
linkPreludeTC(); /* Get prelude tycons and classes */
- setCurrModule(thisModule);
-
mapProc(checkTyconDefn,tyconDefns); /* validate tycon definitions */
checkSynonyms(tyconDefns); /* check synonym definitions */
mapProc(checkClassDefn,classDefns); /* process class definitions */
mapProc(kindTCGroup,tcscc(tyconDefns,classDefns)); /* attach kinds */
mapProc(addMembers,classDefns); /* add definitions for member funs */
mapProc(visitClass,classDefns); /* check class hierarchy */
+ linkPreludeCM(); /* Get prelude cfuns and mfuns */
+ /* ToDo: reinstate?
+ mapOver(checkPrimDefn,primDefns); */ /* check primitive declarations */
+
instDefns = rev(instDefns); /* process instance definitions */
mapProc(checkInstDefn,instDefns);
- linkPreludeCM(); /* Get prelude cfuns and mfuns */
setCurrModule(thisModule);
-
mapProc(addDerivImp,derivedInsts); /* Add impls for derived instances */
deriveContexts(derivedInsts); /* Calculate derived inst contexts */
#if EVAL_INSTANCES
deriveEval(tyconDefns); /* Derive instances of Eval */
#endif
- tyconDefns = NIL;
instDefns = appendOnto(instDefns,derivedInsts);
-#if EVAL_INSTANCES
- instDefns = appendOnto(evalInsts,instDefns); /* ADR addition */
-#endif
checkDefaultDefns(); /* validate default definitions */
mapProc(addRSsigdecls,typeInDefns); /* add sigdecls for RESTRICTSYN */
+#if 0 /* from STG */
valDefns = eqnsToBindings(valDefns);/* translate value equations */
map1Proc(opDefined,valDefns,opDefns);/*check all declared ops bound */
+#else /* from 98 */
+ valDefns = eqnsToBindings(valDefns,tyconDefns,classDefns, NIL/*primDefns*/ );
+ tyconDefns = NIL;
+ /* primDefns = NIL; */
+#endif
mapProc(allNoPrevDef,valDefns); /* check against previous defns */
- linkPreludeNames(); /* Get prelude names */
- setCurrModule(thisModule);
-
- mapProc(checkForeignImport,foreignImports); /* check foreign imports */
- mapProc(checkForeignExport,foreignExports); /* check foreign exports */
+ mapProc(checkForeignImport,foreignImports); /* check foreign imports */
+ mapProc(checkForeignExport,foreignExports); /* check foreign exports */
foreignImports = NIL;
foreignExports = NIL;
+#if !IGNORE_MODULES
/* Every top-level name has now been created - so we can build the */
/* export list. Note that this has to happen before dependency */
/* analysis so that references to Prelude.foo will be resolved */
/* when compiling the prelude. */
- /* Note too that this is just a little too late to catch the use of */
- /* qualified tycons (for the current module) in data declarations */
- module(thisModule).exports = checkExports(thisModule,module(thisModule).exports);
+ module(thisModule).exports = checkExports(module(thisModule).exports);
+#endif
mapProc(checkTypeIn,typeInDefns); /* check restricted synonym defns */
}
}
-static Void local opDefined(bs,op) /* check that op bound in bs */
-List bs; /* (or in current module for */
-Cell op; { /* constructor functions etc...) */
- Name n;
-
- if (isNull(findBinding(textOf(op),bs))
- && (isNull(n=findName(textOf(op))) || name(n).mod != thisModule)) {
- ERRMSG(0) "No top level definition for operator symbol \"%s\"",
- textToStr(textOf(op))
- EEND;
- }
-}
-
-static Void local allNoPrevDef(b) /* ensure no previous bindings for */
-Cell b; { /* variables in new binding */
+static Void local allNoPrevDef(b) /* ensure no previous bindings for*/
+Cell b; { /* variables in new binding */
if (isVar(fst(b))) {
noPrevDef(rhsLine(snd(hd(snd(snd(b))))),fst(b));
} else {
}
}
-static Void local noPrevDef(line,v) /* ensure no previous binding for */
-Int line; /* new variable */
+static Void local noPrevDef(line,v) /* ensure no previous binding for */
+Int line; /* new variable */
Cell v; {
Name n = findName(textOf(v));
if (isNull(n)) {
- n = newName(textOf(v));
+ n = newName(textOf(v),NIL);
name(n).defn = PREDEFINED;
} else if (name(n).defn!=PREDEFINED) {
- ERRMSG(line) "Attempt to redefine variable \"%s\"",
- textToStr(name(n).text)
- EEND;
+ duplicateError(line,name(n).mod,name(n).text,"variable");
}
name(n).line = line;
}
-static Void local duplicateError(line,mod,t,kind)/* report duplicate defn */
+#if IGNORE_MODULES
+static Void local duplicateErrorAux(line,t,kind) /* report duplicate defn */
+Int line;
+Text t;
+String kind; {
+ ERRMSG(line) "Definition of %s \"%s\" clashes with import", kind,
+ textToStr(t)
+ EEND;
+}
+#else /* !IGNORE_MODULES */
+static Void local duplicateErrorAux(line,mod,t,kind)/* report duplicate defn */
Int line;
Module mod;
Text t;
String kind; {
if (mod == currentModule) {
ERRMSG(line) "Repeated definition for %s \"%s\"", kind,
- textToStr(t)
+ textToStr(t)
EEND;
} else {
ERRMSG(line) "Definition of %s \"%s\" clashes with import", kind,
- textToStr(t)
+ textToStr(t)
EEND;
}
}
+#endif /* !IGNORE_MODULES */
static Void local checkTypeIn(cvs) /* Check that vars in restricted */
Pair cvs; { /* synonym are defined */
}
/* --------------------------------------------------------------------------
+ * Haskell 98 compatibility tests:
+ * ------------------------------------------------------------------------*/
+
+Bool h98Pred(allowArgs,pi) /* Check syntax of Hask98 predicate*/
+Bool allowArgs;
+Cell pi; {
+ return isClass(getHead(pi)) && argCount==1 &&
+ isOffset(getHead(arg(pi))) && (argCount==0 || allowArgs);
+}
+
+Cell h98Context(allowArgs,ps) /* Check syntax of Hask98 context */
+Bool allowArgs;
+List ps; {
+ for (; nonNull(ps); ps=tl(ps)) {
+ if (!h98Pred(allowArgs,hd(ps))) {
+ return hd(ps);
+ }
+ }
+ return NIL;
+}
+
+Void h98CheckCtxt(line,wh,allowArgs,ps,in)
+Int line; /* Report illegal context/predicate*/
+String wh;
+Bool allowArgs;
+List ps;
+Inst in; {
+ if (haskell98) {
+ Cell pi = h98Context(allowArgs,ps);
+ if (nonNull(pi)) {
+ ERRMSG(line) "Illegal Haskell 98 class constraint in %s",wh ETHEN
+ if (nonNull(in)) {
+ ERRTEXT "\n*** Instance : " ETHEN ERRPRED(inst(in).head);
+ }
+ ERRTEXT "\n*** Constraint : " ETHEN ERRPRED(pi);
+ if (nonNull(ps) && nonNull(tl(ps))) {
+ ERRTEXT "\n*** Context : " ETHEN ERRCONTEXT(ps);
+ }
+ ERRTEXT "\n"
+ EEND;
+ }
+ }
+}
+
+Void h98CheckType(line,wh,e,t) /* Check for Haskell 98 type */
+Int line;
+String wh;
+Cell e;
+Type t; {
+ if (haskell98) {
+ Type ty = t;
+ if (isPolyType(t))
+ t = monotypeOf(t);
+ if (whatIs(t)==QUAL) {
+ Cell pi = h98Context(TRUE,fst(snd(t)));
+ if (nonNull(pi)) {
+ ERRMSG(line) "Illegal Haskell 98 class constraint in %s",wh
+ ETHEN
+ ERRTEXT "\n*** Expression : " ETHEN ERREXPR(e);
+ ERRTEXT "\n*** Type : " ETHEN ERRTYPE(ty);
+ ERRTEXT "\n"
+ EEND;
+ }
+ }
+ }
+}
+
+Void h98DoesntSupport(line,wh) /* Report feature missing in H98 */
+Int line;
+String wh; {
+ if (haskell98) {
+ ERRMSG(line) "Haskell 98 does not support %s", wh
+ EEND;
+ }
+}
+
+/* --------------------------------------------------------------------------
* Static Analysis control:
* ------------------------------------------------------------------------*/
Void staticAnalysis(what)
Int what; {
switch (what) {
- case RESET : daSccs = NIL;
+ case RESET : cfunSfuns = NIL;
+ daSccs = NIL;
patVars = NIL;
bounds = NIL;
bindings = NIL;
depends = NIL;
tcDeps = NIL;
derivedInsts = NIL;
-#if EVAL_INSTANCES
- evalInsts = NIL;
-#endif
+ diVars = NIL;
+ diNum = 0;
unkindTypes = NIL;
- thisModule = 0;
break;
case MARK : mark(daSccs);
mark(depends);
mark(tcDeps);
mark(derivedInsts);
-#if EVAL_INSTANCES
- mark(evalInsts);
-#endif
+ mark(diVars);
+ mark(cfunSfuns);
mark(unkindTypes);
#if TREX
mark(extKind);
-/* -*- mode: hugs-c; -*- */
+
/* --------------------------------------------------------------------------
* STG syntax
*
* Hugs version 1.4, December 1997
*
* $RCSfile: stg.c,v $
- * $Revision: 1.2 $
- * $Date: 1998/12/02 13:22:38 $
+ * $Revision: 1.3 $
+ * $Date: 1999/02/03 17:08:39 $
* ------------------------------------------------------------------------*/
#include "prelude.h"
#include "storage.h"
+#include "backend.h"
#include "connect.h"
#include "errors.h"
-#include "stg.h"
#include "link.h" /* for nameTrue/False */
#include "Assembler.h" /* for AsmRep and primops */
return body;
} else {
if (whatIs(body) == LAMBDA) {
- return mkStgLambda(dupListOnto(args,stgLambdaArgs(body)),
+ return mkStgLambda(dupOnto(args,stgLambdaArgs(body)),
stgLambdaBody(body));
} else {
return mkStgLambda(args,body);
}
/*-------------------------------------------------------------------------*/
+
+/* --------------------------------------------------------------------------
+ * STG pretty printer
+ *
+ * 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
+ *
+ * $RCSfile: stg.c,v $
+ * $Revision: 1.3 $
+ * $Date: 1999/02/03 17:08:39 $
+ * ------------------------------------------------------------------------*/
+
+/* --------------------------------------------------------------------------
+ * Local functions
+ * ------------------------------------------------------------------------*/
+
+static Void local pIndent Args((Int));
+static Void local unlexVar Args((Text));
+static Void local unlexCharConst Args((Cell));
+static Void local unlexStrConst Args((Text));
+
+static Void local putStgVar Args((StgVar));
+static Void local putStgVars Args((List));
+static Void local putStgAtom Args((StgAtom a));
+static Void local putStgAtoms Args((List as));
+static Void local putStgBinds Args((List));
+static Void local putStgExpr Args((StgExpr));
+static Void local putStgRhs Args((StgRhs));
+static Void local putStgPat Args((StgPat));
+static Void local putStgPrimPat Args((StgPrimPat));
+
+/* --------------------------------------------------------------------------
+ * Basic output routines:
+ * ------------------------------------------------------------------------*/
+
+static FILE *outputStream; /* current output stream */
+static Int outColumn = 0; /* current output column number */
+
+static Void local putChr( Int c );
+static Void local putStr( String s );
+static Void local putInt( Int n );
+static Void local putPtr( Ptr p );
+
+static Void local putChr(c) /* print single character */
+Int c; {
+ Putc(c,outputStream);
+ outColumn++;
+}
+
+static Void local putStr(s) /* print string */
+String s; {
+ for (; *s; s++) {
+ Putc(*s,outputStream);
+ outColumn++;
+ }
+}
+
+static Void local putInt(n) /* print integer */
+Int n; {
+ static char intBuf[16];
+ sprintf(intBuf,"%d",n);
+ putStr(intBuf);
+}
+
+static Void local putPtr(p) /* print pointer */
+Ptr p; {
+ static char intBuf[16];
+ sprintf(intBuf,"%p",p);
+ putStr(intBuf);
+}
+
+/* --------------------------------------------------------------------------
+ * Indentation and showing names/constants
+ * ------------------------------------------------------------------------*/
+
+static Void local pIndent(n) /* indent to particular position */
+Int n; {
+ outColumn = n;
+ while (0<n--) {
+ Putc(' ',outputStream);
+ }
+}
+
+static Void local unlexVar(t) /* print text as a variable name */
+Text t; { /* operator symbols must be enclosed*/
+ String s = textToStr(t); /* in parentheses... except [] ... */
+
+ if ((isascii(s[0]) && isalpha(s[0])) || s[0]=='_' || s[0]=='[' || s[0]=='(')
+ putStr(s);
+ else {
+ putChr('(');
+ putStr(s);
+ putChr(')');
+ }
+}
+
+static Void local unlexCharConst(c)
+Cell c; {
+ putChr('\'');
+ putStr(unlexChar(c,'\''));
+ putChr('\'');
+}
+
+static Void local unlexStrConst(t)
+Text t; {
+ String s = textToStr(t);
+ static Char SO = 14; /* ASCII code for '\SO' */
+ Bool lastWasSO = FALSE;
+ Bool lastWasDigit = FALSE;
+ Bool lastWasEsc = FALSE;
+
+ putChr('\"');
+ for (; *s; s++) {
+ String ch = unlexChar(*s,'\"');
+ Char c = ' ';
+
+ if ((lastWasSO && *ch=='H') ||
+ (lastWasEsc && lastWasDigit && isascii(*ch) && isdigit(*ch)))
+ putStr("\\&");
+
+ lastWasEsc = (*ch=='\\');
+ lastWasSO = (*s==SO);
+ for (; *ch; c = *ch++)
+ putChr(*ch);
+ lastWasDigit = (isascii(c) && isdigit(c));
+ }
+ putChr('\"');
+}
+
+/* --------------------------------------------------------------------------
+ * Pretty printer for stg code:
+ * ------------------------------------------------------------------------*/
+
+static Void putStgAlts ( Int left, List alts );
+static Void putStgPrimAlt ( Int left, List vs, StgExpr body );
+
+static Void local putStgVar(StgVar v)
+{
+ if (isName(v)) {
+ unlexVar(name(v).text);
+ } else {
+ putStr("id");
+ putInt(-v);
+ }
+}
+
+static Void local putStgVars( List vs )
+{
+ for(; nonNull(vs); vs=tl(vs)) {
+ putStgVar(hd(vs));
+ putChr(' ');
+ }
+}
+
+static Void local putStgAtom( StgAtom a )
+{
+ switch (whatIs(a)) {
+ case STGVAR:
+ case NAME:
+ putStgVar(a);
+ break;
+ case CHARCELL:
+ unlexCharConst(charOf(a));
+ putChr('#');
+ break;
+ case INTCELL:
+ putInt(intOf(a));
+ putChr('#');
+ break;
+ case BIGCELL:
+ putStr(bignumToString(a));
+ putChr('#');
+ break;
+ case FLOATCELL:
+ putStr(floatToString(a));
+ putChr('#');
+ break;
+ case STRCELL:
+ unlexStrConst(textOf(a));
+ break;
+ case PTRCELL:
+ putPtr(ptrOf(a));
+ putChr('#');
+ break;
+ default:
+ fprintf(stderr,"\nYoiks: "); printExp(stderr,a);
+ internal("putStgAtom");
+ }
+}
+
+Void putStgAtoms( List as )
+{
+ putChr('{');
+ while (nonNull(as)) {
+ putStgAtom(hd(as));
+ as=tl(as);
+ if (nonNull(as)) {
+ putChr(',');
+ }
+ }
+ putChr('}');
+}
+
+Void putStgPat( StgPat pat )
+{
+ putStgVar(pat);
+ if (nonNull(stgVarBody(pat))) {
+ StgDiscr d = stgConCon(stgVarBody(pat));
+ List vs = stgConArgs(stgVarBody(pat));
+ putChr('@');
+ switch (whatIs(d)) {
+ case NAME:
+ {
+ unlexVar(name(d).text);
+ for (; nonNull(vs); vs=tl(vs)) {
+ putChr(' ');
+ putStgVar(hd(vs));
+ }
+ break;
+ }
+ case TUPLE:
+ {
+ putChr('(');
+ putStgVar(hd(vs));
+ vs=tl(vs);
+ while (nonNull(vs)) {
+ putChr(',');
+ putStgVar(hd(vs));
+ vs=tl(vs);
+ }
+ putChr(')');
+ break;
+ }
+ default:
+ fprintf(stderr,"\nYoiks: "); printExp(stderr,d);
+ internal("putStgPat");
+ }
+ }
+}
+
+Void putStgPrimPat( StgPrimPat pat )
+{
+ putStgVar(pat);
+ if (nonNull(stgVarBody(pat))) {
+ StgExpr d = stgVarBody(pat);
+ putChr('@');
+ switch (whatIs(d)) {
+ case INTCELL:
+ {
+ putInt(intOf(d));
+ putChr('#');
+ break;
+ }
+ default:
+ fprintf(stderr,"\nYoiks: "); printExp(stderr,d);
+ internal("putStgPrimPat");
+ }
+ }
+ putChr(' ');
+}
+
+Void putStgBinds(binds) /* pretty print locals */
+List binds; {
+ Int left = outColumn;
+
+ putStr("let { ");
+ while (nonNull(binds)) {
+ Cell bind = hd(binds);
+ putStgVar(bind);
+ putStr(" = ");
+ putStgRhs(stgVarBody(bind));
+ putStr("\n");
+ binds = tl(binds);
+ if (nonNull(binds))
+ pIndent(left+6);
+ }
+ pIndent(left);
+ putStr("} in ");
+}
+
+static Void putStgAlts( Int left, List alts )
+{
+ if (length(alts) == 1) {
+ StgCaseAlt alt = hd(alts);
+ putStr("{ ");
+ putStgPat(stgCaseAltPat(alt));
+ putStr(" ->\n");
+ pIndent(left);
+ putStgExpr(stgCaseAltBody(alt));
+ putStr("}");
+ } else {
+ putStr("{\n");
+ for (; nonNull(alts); alts=tl(alts)) {
+ StgCaseAlt alt = hd(alts);
+ pIndent(left+2);
+ putStgPat(stgCaseAltPat(alt));
+ putStr(" -> ");
+ putStgExpr(stgCaseAltBody(alt));
+ putStr("\n");
+ }
+ pIndent(left);
+ putStr("}\n");
+ }
+}
+
+static Void putStgPrimAlts( Int left, List alts )
+{
+ if (length(alts) == 1) {
+ StgPrimAlt alt = hd(alts);
+ putStr("{ ");
+ mapProc(putStgPrimPat,stgPrimAltPats(alt));
+ putStr(" ->\n");
+ pIndent(left);
+ putStgExpr(stgPrimAltBody(alt));
+ putStr("}");
+ } else {
+ putStr("{\n");
+ for (; nonNull(alts); alts=tl(alts)) {
+ StgPrimAlt alt = hd(alts);
+ pIndent(left+2);
+ mapProc(putStgPrimPat,stgPrimAltPats(alt));
+ putStr(" -> ");
+ putStgExpr(stgPrimAltBody(alt));
+ putStr("\n");
+ }
+ pIndent(left);
+ putStr("}\n");
+ }
+}
+
+Void putStgExpr( StgExpr e ) /* pretty print expr */
+{
+ switch (whatIs(e)) {
+ case LETREC:
+ putStgBinds(stgLetBinds(e));
+ putStgExpr(stgLetBody(e));
+ break;
+ case LAMBDA:
+ {
+ Int left = outColumn;
+ putStr("\\ ");
+ putStgVars(stgLambdaArgs(e));
+ putStr("->\n");
+ pIndent(left+2);
+ putStgExpr(stgLambdaBody(e));
+ break;
+ }
+ case CASE:
+ {
+ Int left = outColumn;
+ putStr("case ");
+ putStgExpr(stgCaseScrut(e));
+ putStr(" of ");
+ putStgAlts(left,stgCaseAlts(e));
+ break;
+ }
+ case PRIMCASE:
+ {
+ Int left = outColumn;
+ putStr("case# ");
+ putStgExpr(stgPrimCaseScrut(e));
+ putStr(" of ");
+ putStgPrimAlts(left,stgPrimCaseAlts(e));
+ break;
+ }
+ case STGPRIM:
+ {
+ Cell op = stgPrimOp(e);
+ unlexVar(name(op).text);
+ putStgAtoms(stgPrimArgs(e));
+ break;
+ }
+ case STGAPP:
+ putStgVar(stgAppFun(e));
+ putStgAtoms(stgAppArgs(e));
+ break;
+ case STGVAR:
+ case NAME:
+ putStgVar(e);
+ break;
+ default:
+ fprintf(stderr,"\nYoiks: "); printExp(stderr,e);
+ internal("putStgExpr");
+ }
+}
+
+Void putStgRhs( StgRhs e ) /* print lifted definition */
+{
+ switch (whatIs(e)) {
+ case STGCON:
+ {
+ Name con = stgConCon(e);
+ if (isTuple(con)) {
+ putStr("Tuple");
+ putInt(tupleOf(con));
+ } else {
+ unlexVar(name(con).text);
+ }
+ putStgAtoms(stgConArgs(e));
+ break;
+ }
+ default:
+ putStgExpr(e);
+ break;
+ }
+}
+
+static void beginStgPP( FILE* fp );
+static void endStgPP( FILE* fp );
+
+static void beginStgPP( FILE* fp )
+{
+ outputStream = fp;
+ putChr('\n');
+ outColumn = 0;
+}
+
+static void endStgPP( FILE* fp )
+{
+ fflush(fp);
+}
+
+Void printStg(fp,b) /* Pretty print sc defn on fp */
+FILE *fp;
+StgVar b;
+{
+ beginStgPP(fp);
+ putStgVar(b);
+ putStr(" = ");
+ putStgRhs(stgVarBody(b));
+ putStr("\n");
+ endStgPP(fp);
+}
+
+#if DEBUG_PRINTER
+Void ppStg( StgVar v )
+{
+ if (debugCode) {
+ printStg(stdout,v);
+ }
+}
+
+Void ppStgExpr( StgExpr e )
+{
+ if (debugCode) {
+ beginStgPP(stdout);
+ putStgExpr(e);
+ endStgPP(stdout);
+ }
+}
+
+Void ppStgRhs( StgRhs rhs )
+{
+ if (debugCode) {
+ beginStgPP(stdout);
+ putStgRhs(rhs);
+ endStgPP(stdout);
+ }
+}
+
+Void ppStgAlts( List alts )
+{
+ if (debugCode) {
+ beginStgPP(stdout);
+ putStgAlts(0,alts);
+ endStgPP(stdout);
+ }
+}
+
+extern Void ppStgPrimAlts( List alts )
+{
+ if (debugCode) {
+ beginStgPP(stdout);
+ putStgPrimAlts(0,alts);
+ endStgPP(stdout);
+ }
+}
+
+extern Void ppStgVars( List vs )
+{
+ if (debugCode) {
+ beginStgPP(stdout);
+ printf("Vars: ");
+ putStgVars(vs);
+ printf("\n");
+ endStgPP(stdout);
+ }
+}
+#endif
+
+/*-------------------------------------------------------------------------*/
-/* -*- mode: hugs-c; -*- */
+
/* --------------------------------------------------------------------------
* Substitute variables in an expression
*
* Hugs version 1.4, December 1997
*
* $RCSfile: stgSubst.c,v $
- * $Revision: 1.2 $
- * $Date: 1998/12/02 13:22:40 $
+ * $Revision: 1.3 $
+ * $Date: 1999/02/03 17:08:40 $
* ------------------------------------------------------------------------*/
#include "prelude.h"
#include "storage.h"
+#include "backend.h"
#include "connect.h"
#include "errors.h"
-#include "stg.h"
-
-#include "stgSubst.h"
/* --------------------------------------------------------------------------
* Local function prototypes:
-/* -*- mode: hugs-c; -*- */
+
/* --------------------------------------------------------------------------
* Primitives for manipulating global data structures
*
- * 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
+ * Hugs 98 is Copyright (c) Mark P Jones, Alastair Reid and the Yale
+ * Haskell Group 1994-99, and is distributed as Open Source software
+ * under the Artistic License; see the file "Artistic" that is included
+ * in the distribution for details.
*
* $RCSfile: storage.c,v $
- * $Revision: 1.2 $
- * $Date: 1998/12/02 13:22:41 $
+ * $Revision: 1.3 $
+ * $Date: 1999/02/03 17:08:40 $
* ------------------------------------------------------------------------*/
#include "prelude.h"
#include "storage.h"
+#include "backend.h"
#include "connect.h"
-#include "charset.h"
#include "errors.h"
-#include "link.h" /* for nameCons */
#include <setjmp.h>
-#include "machdep.h" /* gc-related functions */
-
/*#define DEBUG_SHOWUSE*/
/* --------------------------------------------------------------------------
static Int local hash Args((String));
static Int local saveText Args((Text));
+#if !IGNORE_MODULES
static Module local findQualifier Args((Text));
+#endif
static Void local hashTycon Args((Tycon));
static List local insertTycon Args((Tycon,List));
static Void local hashName Args((Name));
static Bool local typeInvolves Args((Type,Type));
static Cell local markCell Args((Cell));
static Void local markSnd Args((Cell));
+static Cell local indirectChain Args((Cell));
+static Bool local isMarked Args((Cell));
static Cell local lowLevelLastIn Args((Cell));
static Cell local lowLevelLastOut Args((Cell));
-static Module local moduleOfScript Args((Script));
-static Script local scriptThisFile Args((Text));
-
+/* from STG */
+ Module local moduleOfScript Args((Script));
+ Script local scriptThisFile Args((Text));
+/* from 98 */
+#if IO_HANDLES
+static Void local freeHandle Args((Int));
+#endif
+#if GC_STABLEPTRS
+static Void local resetStablePtrs Args((Void));
+#endif
+/* end */
/* --------------------------------------------------------------------------
* Text storage:
String identToStr(v) /*find string corresp to given ident or qualified name*/
Cell v; {
- static char newVar[33];
-
- assert(isPair(v));
- switch (fst(v)) {
- case VARIDCELL :
- case VAROPCELL :
- case CONIDCELL :
- case CONOPCELL : return text+textOf(v);
-
- case QUALIDENT : sprintf(newVar,"%s.%s",
- text+qmodOf(v),text+qtextOf(v));
- return newVar;
+ if (!isPair(v)) {
+ internal("identToStr");
}
- internal("identToStr 2");
-}
-
-Syntax identSyntax(v) /* find syntax of ident or qualified ident */
-Cell v; {
- assert(isPair(v));
switch (fst(v)) {
case VARIDCELL :
case VAROPCELL :
case CONIDCELL :
- case CONOPCELL : return syntaxOf(textOf(v));
+ case CONOPCELL : return text+textOf(v);
- case QUALIDENT : return syntaxOf(qtextOf(v));
- }
- internal("identSyntax 2");
+ case QUALIDENT : { Text pos = textHw;
+ Text t = qmodOf(v);
+ while (pos+1 < savedText && text[t]!=0) {
+ text[pos++] = text[t++];
+ }
+ if (pos+1 < savedText) {
+ text[pos++] = '.';
+ }
+ t = qtextOf(v);
+ while (pos+1 < savedText && text[t]!=0) {
+ text[pos++] = text[t++];
+ }
+ text[pos] = '\0';
+ return text+textHw;
+ }
+ }
+ internal("identToStr2");
+ assert(0); return 0; /* NOTREACHED */
}
Text inventText() { /* return new unused variable name */
return savedText;
}
-/* --------------------------------------------------------------------------
- * Syntax storage:
- *
- * Operator declarations are stored in a table which associates Text values
- * with Syntax values.
- * ------------------------------------------------------------------------*/
-
-static Int syntaxHw; /* next unused syntax table entry */
-static struct strSyntax { /* table of Text <-> Syntax values */
- Text text;
- Syntax syntax;
-} DEFTABLE(tabSyntax,NUM_SYNTAX);
-
-Syntax defaultSyntax(t) /* Find default syntax of var named */
-Text t; { /* by t ... */
- String s = textToStr(t);
- return isIn(s[0],SYMBOL) ? DEF_OPSYNTAX : APPLIC;
-}
-
-Syntax syntaxOf(t) /* look up syntax of operator symbol*/
-Text t; {
- int i;
-
- for (i=0; i<syntaxHw; ++i)
- if (tabSyntax[i].text==t)
- return tabSyntax[i].syntax;
- return defaultSyntax(t);
-}
-
-Void addSyntax(line,t,sy) /* add (t,sy) to syntax table */
-Int line;
-Text t;
-Syntax sy; {
- int i;
-
- for (i=0; i<syntaxHw; ++i)
- if (tabSyntax[i].text==t) {
- /* There's no problem with multiple identical fixity declarations.
- * - but note that it's not allowed by the Haskell report. ADR
- */
- if (tabSyntax[i].syntax == sy) return;
- ERRMSG(line) "Attempt to redefine syntax of operator \"%s\"",
- textToStr(t)
- EEND;
- }
-
- if (syntaxHw>=NUM_SYNTAX) {
- ERRMSG(line) "Too many fixity declarations"
- EEND;
- }
-
- tabSyntax[syntaxHw].text = t;
- tabSyntax[syntaxHw].syntax = sy;
- syntaxHw++;
-}
/* --------------------------------------------------------------------------
* Ext storage:
tycon(tyconHw).kind = NIL;
tycon(tyconHw).defn = NIL;
tycon(tyconHw).what = NIL;
- tycon(tyconHw).conToTag = NIL;
- tycon(tyconHw).tagToCon = NIL;
+#if !IGNORE_MODULES
tycon(tyconHw).mod = currentModule;
module(currentModule).tycons = cons(tyconHw,module(currentModule).tycons);
+#endif
tycon(tyconHw).nextTyconHash = tyconHash[h];
tyconHash[h] = tyconHw;
Tycon oldtc = findTycon(tycon(tc).text);
if (isNull(oldtc)) {
hashTycon(tc);
+#if !IGNORE_MODULES
module(currentModule).tycons=cons(tc,module(currentModule).tycons);
+#endif
return tc;
} else
return oldtc;
Tycon findQualTycon(id) /*locate (possibly qualified) Tycon in tycon table */
Cell id; {
- assert(isPair(id));
+ if (!isPair(id)) internal("findQualTycon");
switch (fst(id)) {
case CONIDCELL :
case CONOPCELL :
return findTycon(textOf(id));
case QUALIDENT : {
+#if IGNORE_MODULES
+ return findTycon(qtextOf(id));
+#else /* !IGNORE_MODULES */
Text t = qtextOf(id);
Module m = findQualifier(qmodOf(id));
List es = NIL;
- if (isNull(m))
- return NIL;
- if (m==currentModule) {
- /* The Haskell report (rightly) forbids this.
- * We added it to let the Prelude refer to itself
- * without having to import itself.
- */
- return findTycon(t);
- }
+ if (isNull(m)) return NIL;
for(es=module(m).exports; nonNull(es); es=tl(es)) {
Cell e = hd(es);
if (isPair(e) && isTycon(fst(e)) && tycon(fst(e)).text==t)
return fst(e);
}
return NIL;
+#endif /* !IGNORE_MODULES */
}
default : internal("findQualTycon2");
}
+ assert(0); return 0; /* NOTREACHED */
}
Tycon addPrimTycon(t,kind,ar,what,defn) /* add new primitive type constr */
-Text t;
-Kind kind;
-Int ar;
-Cell what;
-Cell defn; {
+Text t;
+Kind kind;
+Int ar;
+Cell what;
+Cell defn; {
Tycon tc = newTycon(t);
tycon(tc).line = 0;
tycon(tc).kind = kind;
#define NAMEHSZ 256 /* Size of Name hash table */
#define nHash(x) ((x)%NAMEHSZ) /* hash fn :: Text->Int */
-/*static*/Name nameHw; /* next unused name */
+static Name nameHw; /* next unused name */
static Name DEFTABLE(nameHash,NAMEHSZ); /* Hash table storage */
struct strName DEFTABLE(tabName,NUM_NAME); /* Name table storage */
-Name newName(t) /* add new name to name table */
-Text t; {
+Name newName(t,parent) /* Add new name to name table */
+Text t;
+Cell parent; {
+ Int h = nHash(t);
+
if (nameHw-NAMEMIN >= NUM_NAME) {
ERRMSG(0) "Name storage space exhausted"
EEND;
}
name(nameHw).text = t; /* clear new name record */
name(nameHw).line = 0;
+ name(nameHw).syntax = NO_SYNTAX;
+ name(nameHw).parent = parent;
name(nameHw).arity = 0;
name(nameHw).number = EXECNAME;
name(nameHw).defn = NIL;
name(nameHw).mod = currentModule;
hashName(nameHw);
module(currentModule).names=cons(nameHw,module(currentModule).names);
+ name(nameHw).nextNameHash = nameHash[h];
+ nameHash[h] = nameHw;
return nameHw++;
}
-Name findName(t) /* locate name in name table */
+Name findName(t) /* Locate name in name table */
Text t; {
Name n = nameHash[nHash(t)];
return n;
}
-Name addName(nm) /* Insert Name in name table - if no clash is caused */
-Name nm; {
+Name addName(nm) /* Insert Name in name table - if */
+Name nm; { /* no clash is caused */
Name oldnm = findName(name(nm).text);
if (isNull(oldnm)) {
hashName(nm);
+#if !IGNORE_MODULES
module(currentModule).names=cons(nm,module(currentModule).names);
+#endif
return nm;
- } else {
+ } else
return oldnm;
- }
}
-static Void local hashName(nm) /* Insert Name into hash table */
+static Void local hashName(nm) /* Insert Name into hash table */
Name nm; {
- Text t = name(nm).text;
- Int h = nHash(t);
+ Text t = name(nm).text;
+ Int h = nHash(t);
name(nm).nextNameHash = nameHash[h];
nameHash[h] = nm;
}
-Name findQualName(line,id) /* locate (possibly qualified) name in name table */
-Int line;
-Cell id; {
- assert(isPair(id));
+Name findQualName(id) /* Locate (possibly qualified) name*/
+Cell id; { /* in name table */
+ if (!isPair(id))
+ internal("findQualName");
switch (fst(id)) {
case VARIDCELL :
case VAROPCELL :
case CONOPCELL :
return findName(textOf(id));
case QUALIDENT : {
+#if IGNORE_MODULES
+ return findName(qtextOf(id));
+#else /* !IGNORE_MODULES */
Text t = qtextOf(id);
Module m = findQualifier(qmodOf(id));
List es = NIL;
List subentities = NIL;
Cell c = fst(e);
if (isTycon(c)
- && (tycon(c).what == DATATYPE
- || tycon(c).what == NEWTYPE))
+ && (tycon(c).what==DATATYPE || tycon(c).what==NEWTYPE))
subentities = tycon(c).defn;
else if (isClass(c))
subentities = cclass(c).members;
}
}
return NIL;
+#endif /* !IGNORE_MODULES */
}
default : internal("findQualName2");
}
+ assert(0); return 0; /* NOTREACHED */
}
/* --------------------------------------------------------------------------
Int arity;
Int no;
Int rep; { /* Really AsmRep */
- Name n = newName(t);
+ Name n = newName(t,NIL);
name(n).arity = arity;
name(n).number = cfunNo(no);
name(n).type = NIL;
Name c; {
List cns;
cns = name(s).defn;
- for (; nonNull(cns); cns=tl(cns)) {
+ for (; nonNull(cns); cns=tl(cns))
if (fst(hd(cns))==c)
return intOf(snd(hd(cns)));
- }
internal("sfunPos");
- return 0;/*NOTREACHED*/
+ return 0;/* NOTREACHED */
}
static List local insertName(nm,ns) /* insert name nm into sorted list */
String pat; /* to list of names ns */
List ns; { /* Null pattern matches every name */
Name nm; /* (Names with NIL type, or hidden */
+#if 1
for (nm=NAMEMIN; nm<nameHw; ++nm) /* or invented names are excluded) */
if (!inventedText(name(nm).text) && nonNull(name(nm).type)) {
String str = textToStr(name(nm).text);
ns = insertName(nm,ns);
}
return ns;
+#else
+ List mns = module(currentModule).names;
+ for(; nonNull(mns); mns=tl(mns)) {
+ Name nm = hd(mns);
+ if (!inventedText(name(nm).text)) {
+ String str = textToStr(name(nm).text);
+ if (str[0]!='_' && (!pat || stringMatch(pat,str)))
+ ns = insertName(nm,ns);
+ }
+ }
+ return ns;
+#endif
}
/* --------------------------------------------------------------------------
static Class classHw; /* next unused class */
static List classes; /* list of classes in current scope */
static Inst instHw; /* next unused instance record */
-#if USE_DICTHW
-static Int dictHw; /* next unused dictionary number */
-#endif
struct strClass DEFTABLE(tabClass,NUM_CLASSES); /* table of class records */
struct strInst far *tabInst; /* (pointer to) table of instances */
cclass(classHw).defaults = NIL;
cclass(classHw).instances = NIL;
classes=cons(classHw,classes);
+#if !IGNORE_MODULES
cclass(classHw).mod = currentModule;
module(currentModule).classes=cons(classHw,module(currentModule).classes);
+#endif
return classHw++;
}
return NIL;
}
-Class addClass(c) /* Insert Class in class list - if no clash caused */
-Class c; {
+Class addClass(c) /* Insert Class in class list */
+Class c; { /* - if no clash caused */
Class oldc = findClass(cclass(c).text);
if (isNull(oldc)) {
classes=cons(c,classes);
+#if !IGNORE_MODULES
module(currentModule).classes=cons(c,module(currentModule).classes);
+#endif
return c;
- } else
+ }
+ else
return oldc;
}
-Class findQualClass(c) /* look for (possibly qualified) class in class list */
-Cell c; {
+Class findQualClass(c) /* Look for (possibly qualified) */
+Cell c; { /* class in class list */
if (!isQualIdent(c)) {
return findClass(textOf(c));
} else {
- Text t = qtextOf(c);
- Module m = findQualifier(qmodOf(c));
+#if IGNORE_MODULES
+ return findClass(qtextOf(c));
+#else /* !IGNORE_MODULES */
+ Text t = qtextOf(c);
+ Module m = findQualifier(qmodOf(c));
List es = NIL;
- if (isNull(m)) return NIL;
- for(es=module(m).exports; nonNull(es); es=tl(es)) {
+ if (isNull(m))
+ return NIL;
+ for (es=module(m).exports; nonNull(es); es=tl(es)) {
Cell e = hd(es);
if (isPair(e) && isClass(fst(e)) && cclass(fst(e)).text==t)
return fst(e);
}
+#endif
}
return NIL;
}
-Inst newInst() { /* add new instance to table */
+Inst newInst() { /* Add new instance to table */
if (instHw-INSTMIN >= NUM_INSTS) {
ERRMSG(0) "Instance storage space exhausted"
EEND;
inst(instHw).specifics = NIL;
inst(instHw).implements = NIL;
inst(instHw).builder = NIL;
- inst(instHw).mod = currentModule;
+ /* from STG */ inst(instHw).mod = currentModule;
return instHw++;
}
+#ifdef DEBUG_DICTS
+extern Void printInst Args((Inst));
+
+Void printInst(in)
+Inst in; {
+ Class cl = inst(in).c;
+ Printf("%s-", textToStr(cclass(cl).text));
+ printType(stdout,inst(in).t);
+}
+#endif /* DEBUG_DICTS */
+
Inst findFirstInst(tc) /* look for 1st instance involving */
Tycon tc; { /* the type constructor tc */
return findNextInst(tc,INSTMIN-1);
Cell DEFTABLE(cellStack,NUM_STACK); /* Storage for cells on stack */
StackPtr sp; /* stack pointer */
+#if GIMME_STACK_DUMPS
+
+#define UPPER_DISP 5 /* # display entries on top of stack */
+#define LOWER_DISP 5 /* # display entries on bottom of stack*/
+
+Void hugsStackOverflow() { /* Report stack overflow */
+ extern Int rootsp;
+ extern Cell evalRoots[];
+
+ ERRMSG(0) "Control stack overflow" ETHEN
+ if (rootsp>=0) {
+ Int i;
+ if (rootsp>=UPPER_DISP+LOWER_DISP) {
+ for (i=0; i<UPPER_DISP; i++) {
+ ERRTEXT "\nwhile evaluating: " ETHEN
+ ERREXPR(evalRoots[rootsp-i]);
+ }
+ ERRTEXT "\n..." ETHEN
+ for (i=LOWER_DISP-1; i>=0; i--) {
+ ERRTEXT "\nwhile evaluating: " ETHEN
+ ERREXPR(evalRoots[i]);
+ }
+ }
+ else {
+ for (i=rootsp; i>=0; i--) {
+ ERRTEXT "\nwhile evaluating: " ETHEN
+ ERREXPR(evalRoots[i]);
+ }
+ }
+ }
+ ERRTEXT "\n"
+ EEND;
+}
+
+#else /* !GIMME_STACK_DUMPS */
+
Void hugsStackOverflow() { /* Report stack overflow */
ERRMSG(0) "Control stack overflow"
EEND;
}
+#endif /* !GIMME_STACK_DUMPS */
+
/* --------------------------------------------------------------------------
* Module storage:
*
*
* ------------------------------------------------------------------------*/
+#if !IGNORE_MODULES
static Module moduleHw; /* next unused Module */
struct Module DEFTABLE(tabModule,NUM_MODULE); /* Module storage */
Module currentModule; /* Module currently being processed*/
Text t; {
Module m;
for(m=MODMIN; m<moduleHw; ++m) {
- if (module(m).text==t) {
+ if (module(m).text==t)
return m;
- }
}
return NIL;
}
case CONIDCELL : return findModule(textOf(c));
default : internal("findModid");
}
+ assert(0); return 0; /* NOTREACHED */
}
static local Module findQualifier(t) /* locate Module in import list */
return modulePreludeHugs;
}
for (ms=module(currentModule).qualImports; nonNull(ms); ms=tl(ms)) {
- if (textOf(fst(hd(ms)))==t) {
+ if (textOf(fst(hd(ms)))==t)
return snd(hd(ms));
- }
}
+#if 1 /* mpj */
+ if (module(currentModule).text==t)
+ return currentModule;
+#endif
return NIL;
}
Int i;
if (m!=currentModule) {
currentModule = m; /* This is the only assignment to currentModule */
- for (i=0; i<TYCONHSZ; ++i) {
+ for (i=0; i<TYCONHSZ; ++i)
tyconHash[i] = NIL;
- }
mapProc(hashTycon,module(m).tycons);
- for (i=0; i<NAMEHSZ; ++i) {
+ for (i=0; i<NAMEHSZ; ++i)
nameHash[i] = NIL;
- }
mapProc(hashName,module(m).names);
classes = module(m).classes;
}
}
+#endif /* !IGNORE_MODULES */
/* --------------------------------------------------------------------------
* Script file storage:
Text textHw;
Text nextNewText;
Text nextNewDText;
- Int syntaxHw;
+#if !IGNORE_MODULES
Module moduleHw;
+#endif
Tycon tyconHw;
Name nameHw;
Class classHw;
Inst instHw;
-#if USE_DICTHW
- Int dictHw;
-#endif
#if TREX
Ext extHw;
#endif
}
#ifdef DEBUG_SHOWUSE
showUse("Text", textHw, NUM_TEXT);
- showUse("Syntax", syntaxHw, NUM_SYNTAX);
+#if !IGNORE_MODULES
showUse("Module", moduleHw-MODMIN, NUM_MODULE);
+#endif
showUse("Tycon", tyconHw-TYCMIN, NUM_TYCON);
showUse("Name", nameHw-NAMEMIN, NUM_NAME);
showUse("Class", classHw-CLASSMIN, NUM_CLASSES);
scripts[scriptHw].textHw = textHw;
scripts[scriptHw].nextNewText = nextNewText;
scripts[scriptHw].nextNewDText = nextNewDText;
- scripts[scriptHw].syntaxHw = syntaxHw;
+#if !IGNORE_MODULES
scripts[scriptHw].moduleHw = moduleHw;
+#endif
scripts[scriptHw].tyconHw = tyconHw;
scripts[scriptHw].nameHw = nameHw;
scripts[scriptHw].classHw = classHw;
scripts[scriptHw].instHw = instHw;
-#if USE_DICTHW
- scripts[scriptHw].dictHw = dictHw;
-#endif
#if TREX
scripts[scriptHw].extHw = extHw;
#endif
return scriptHw++;
}
+Bool isPreludeScript() { /* Test whether this is the Prelude*/
+ return (scriptHw==0);
+}
+
+#if !IGNORE_MODULES
+Bool moduleThisScript(m) /* Test if given module is defined */
+Module m; { /* in current script file */
+ return scriptHw<1 || m>=scripts[scriptHw-1].moduleHw;
+}
+
+Module lastModule() { /* Return module in current script file */
+ return (moduleHw>MODMIN ? moduleHw-1 : modulePrelude);
+}
+#endif /* !IGNORE_MODULES */
+
#define scriptThis(nm,t,tag) Script nm(x) \
t x; { \
Script s=0; \
scriptThis(scriptThisClass,Class,classHw)
#undef scriptThis
-Module lastModule() { /* Return module in current script file */
- return (moduleHw-1);
-}
-
-static Module local moduleOfScript(s)
+Module moduleOfScript(s)
Script s; {
- return scripts[s-1].moduleHw;
+ return (s==0) ? modulePrelude : scripts[s-1].moduleHw;
}
+#if !IGNORE_MODULES
String fileOfModule(m)
Module m; {
Script s;
+ if (m == modulePrelude) {
+ return STD_PRELUDE;
+ }
for(s=0; s<scriptHw; ++s) {
if (scripts[s].moduleHw == m) {
return textToStr(scripts[s].file);
}
return 0;
}
+#endif
-static Script local scriptThisFile(f)
+Script scriptThisFile(f)
Text f; {
Script s;
for (s=0; s < scriptHw; ++s) {
return s+1;
}
}
+ if (f == findText(STD_PRELUDE)) {
+ return 0;
+ }
return (-1);
}
textHw = scripts[sno].textHw;
nextNewText = scripts[sno].nextNewText;
nextNewDText = scripts[sno].nextNewDText;
- syntaxHw = scripts[sno].syntaxHw;
+#if !IGNORE_MODULES
+ moduleHw = scripts[sno].moduleHw;
+#endif
tyconHw = scripts[sno].tyconHw;
nameHw = scripts[sno].nameHw;
classHw = scripts[sno].classHw;
for (i=moduleHw; i >= scripts[sno].moduleHw; --i) {
if (module(i).objectFile) {
- printf("closing objectFile for module %d\n",i);
- dlclose(module(i).objectFile);
+ printf("[bogus] closing objectFile for module %d\n",i);
+ /*dlclose(module(i).objectFile);*/
}
}
moduleHw = scripts[sno].moduleHw;
textHash[i][j] = NOTEXT;
}
+#if IGNORE_MODULES
+ for (i=0; i<TYCONHSZ; ++i) {
+ Tycon tc = tyconHash[i];
+ while (nonNull(tc) && tc>=tyconHw)
+ tc = tycon(tc).nextTyconHash;
+ tyconHash[i] = tc;
+ }
+
+ for (i=0; i<NAMEHSZ; ++i) {
+ Name n = nameHash[i];
+ while (nonNull(n) && n>=nameHw)
+ n = name(n).nextNameHash;
+ nameHash[i] = n;
+ }
+#else /* !IGNORE_MODULES */
currentModule=NIL;
for (i=0; i<TYCONHSZ; ++i) {
tyconHash[i] = NIL;
for (i=0; i<NAMEHSZ; ++i) {
nameHash[i] = NIL;
}
+#endif /* !IGNORE_MODULES */
for (i=CLASSMIN; i<classHw; i++) {
List ins = cclass(i).instances;
Int heapSize = DEFAULTHEAP; /* number of cells in heap */
Heap heapFst; /* array of fst component of pairs */
Heap heapSnd; /* array of snd component of pairs */
+#ifndef GLOBALfst
Heap heapTopFst;
+#endif
+#ifndef GLOBALsnd
Heap heapTopSnd;
+#endif
Bool consGC = TRUE; /* Set to FALSE to turn off gc from*/
/* C stack; use with extreme care! */
+#if PROFILING
+Heap heapThd, heapTopThd; /* to keep record of producers */
+Int sysCount; /* record unattached cells */
+Name producer; /* current producer, if any */
+Bool profiling = FALSE; /* should profiling be performed */
+Int profInterval = MAXPOSINT; /* interval between samples */
+FILE *profile = 0; /* pointer to profiler log, if any */
+#endif
+Long numCells;
+Int numGcs; /* number of garbage collections */
Int cellsRecovered; /* number of cells recovered */
static Cell freeList; /* free list of unused cells */
static Cell lsave, rsave; /* save components of pair */
+#if GC_WEAKPTRS
+static List weakPtrs; /* list of weak ptrs */
+ /* reconstructed during every GC */
+List finalizers = NIL;
+List liveWeakPtrs = NIL;
+#endif
+
#if GC_STATISTICS
static Int markCount, stackRoots;
#define startGC() \
if (gcMessages) { \
- printf("\n"); \
+ Printf("\n"); \
fflush(stdout); \
}
#define endGC() \
if (gcMessages) { \
- printf("\n"); \
+ Printf("\n"); \
fflush(stdout); \
}
#define start() markCount = 0
#define end(thing,rs) \
if (gcMessages) { \
- printf("GC: %-18s: %4d cells, %4d roots.\n", thing, markCount, rs); \
+ Printf("GC: %-18s: %4d cells, %4d roots.\n", thing, markCount, rs); \
fflush(stdout); \
}
#define recordMark() markCount++
freeList = snd(freeList);
fst(c) = l;
snd(c) = r;
+#if PROFILING
+ thd(c) = producer;
+#endif
+ numCells++;
return c;
}
Void overwrite(dst,src) /* overwrite dst cell with src cell*/
-Pair dst, src; { /* both *MUST* be pairs */
- assert(isPair(dst) && isPair(src));
- fst(dst) = fst(src);
- snd(dst) = snd(src);
-}
-
-Void overwrite2(dst,src1,src2) /* overwrite dst cell with src cell*/
-Pair dst;
-Cell src1, src2; {
- assert(isPair(dst));
- fst(dst) = src1;
- snd(dst) = src2;
+Cell dst, src; { /* both *MUST* be pairs */
+ if (isPair(dst) && isPair(src)) {
+ fst(dst) = fst(src);
+ snd(dst) = snd(src);
+ }
+ else
+ internal("overwrite");
}
static Int *marks;
Cell c; { /* cells reachable from given root */
/* markCell(c) is only called if c */
/* is a pair */
- { register place = placeInSet(c);
- register mask = maskInSet(c);
+ { register int place = placeInSet(c);
+ register int mask = maskInSet(c);
if (marks[place]&mask)
return c;
else {
fst(c) = markCell(fst(c));
markSnd(c);
}
- else if (isNull(fst(c)) || fst(c)>=BCSTAG)
+ else if (isNull(fst(c)) || fst(c)>=BCSTAG) {
markSnd(c);
+ }
return c;
}
mb: if (!isPair(c))
return;
- { register place = placeInSet(c);
- register mask = maskInSet(c);
+ { register int place = placeInSet(c);
+ register int mask = maskInSet(c);
if (marks[place]&mask)
return;
else {
gcStarted();
for (i=0; i<marksSize; ++i) /* initialise mark set to empty */
marks[i] = 0;
-
+#if GC_WEAKPTRS
+ weakPtrs = NIL; /* clear list of weak pointers */
+#endif
everybody(MARK); /* Mark all components of system */
+#if IO_HANDLES
+ for (i=0; i<NUM_HANDLES; ++i) /* release any unused handles */
+ if (nonNull(handles[i].hcell)) {
+ register place = placeInSet(handles[i].hcell);
+ register mask = maskInSet(handles[i].hcell);
+ if ((marks[place]&mask)==0)
+ freeHandle(i);
+ }
+#endif
+#if GC_MALLOCPTRS
+ for (i=0; i<NUM_MALLOCPTRS; ++i) /* release any unused mallocptrs */
+ if (isPair(mallocPtrs[i].mpcell)) {
+ register place = placeInSet(mallocPtrs[i].mpcell);
+ register mask = maskInSet(mallocPtrs[i].mpcell);
+ if ((marks[place]&mask)==0)
+ incMallocPtrRefCnt(i,-1);
+ }
+#endif /* GC_MALLOCPTRS */
+#if GC_WEAKPTRS
+ /* After GC completes, we scan the list of weak pointers that are
+ * still live and zap their contents unless the contents are still
+ * live (by some other means).
+ * Note that this means the contents must itself be heap allocated.
+ * This means it can't be a nullary constructor or an Int or a Name
+ * or lots of other things - hope this doesn't bite too hard.
+ */
+ for (; nonNull(weakPtrs); weakPtrs=nextWeakPtr(weakPtrs)) {
+ Cell ptr = derefWeakPtr(weakPtrs);
+ if (isGenPair(ptr)) {
+ Int place = placeInSet(ptr);
+ Int mask = maskInSet(ptr);
+ if ((marks[place]&mask)==0) {
+ /* printf("Zapping weak pointer %d\n", ptr); */
+ derefWeakPtr(weakPtrs) = NIL;
+ } else {
+ /* printf("Keeping weak pointer %d\n", ptr); */
+ }
+ } else if (nonNull(ptr)) {
+ printf("Weak ptr contains object which isn't heap allocated %d\n", ptr);
+ }
+ }
+
+ if (nonNull(liveWeakPtrs) || nonNull(finalizers)) {
+ Bool anyMarked; /* Weak pointers with finalizers */
+ List wps;
+ List newFins = NIL;
+
+ /* Step 1: iterate until we've found out what is reachable */
+ do {
+ anyMarked = FALSE;
+ for (wps=liveWeakPtrs; nonNull(wps); wps=tl(wps)) {
+ Cell wp = hd(wps);
+ Cell k = fst(snd(wp));
+ if (isNull(k)) {
+ internal("bad weak ptr");
+ }
+ if (isMarked(k)) {
+ Cell vf = snd(snd(wp));
+ if (!isMarked(fst(vf)) || !isMarked(snd(vf))) {
+ mark(fst(vf));
+ mark(snd(vf));
+ anyMarked = TRUE;
+ }
+ }
+ }
+ } while (anyMarked);
+
+ /* Step 2: Now we know which weak pointers will die, so we can */
+ /* remove them from the live set and gather their finalizers. But */
+ /* note that we mustn't mark *anything* at this stage or we will */
+ /* corrupt our view of what's alive, and what's dead. */
+ wps = NIL;
+ while (nonNull(liveWeakPtrs)) {
+ Cell wp = hd(liveWeakPtrs);
+ List nx = tl(liveWeakPtrs);
+ Cell k = fst(snd(wp));
+ if (!isMarked(k)) { /* If the key is dead, then*/
+ Cell vf = snd(snd(wp)); /* stomp on weak pointer */
+ fst(vf) = snd(vf);
+ snd(vf) = newFins;
+ newFins = vf; /* reuse because we can't */
+ fst(snd(wp)) = NIL; /* reallocate here ... */
+ snd(snd(wp)) = NIL;
+ snd(wp) = NIL;
+ liveWeakPtrs = nx;
+ } else {
+ tl(liveWeakPtrs) = wps; /* Otherwise, weak pointer */
+ wps = liveWeakPtrs;/* survives to face another*/
+ liveWeakPtrs = nx; /* garbage collection */
+ }
+ }
+
+ /* Step 3: Now we've identified the live cells and the newly */
+ /* scheduled finalizers, but we had better make sure that they are */
+ /* all marked now, including any internal structure, to ensure that*/
+ /* they make it to the other side of gc. */
+ for (liveWeakPtrs=wps; nonNull(wps); wps=tl(wps)) {
+ mark(snd(hd(wps)));
+ }
+ mark(liveWeakPtrs);
+ mark(newFins);
+ finalizers = revOnto(newFins,finalizers);
+ }
+
+#endif /* GC_WEAKPTRS */
gcScanning(); /* scan mark set */
mask = 1;
place = 0;
recovered = 0;
j = 0;
+#if PROFILING
+ if (profile) {
+ sysCount = 0;
+ for (i=NAMEMIN; i<nameHw; i++)
+ name(i).count = 0;
+ }
+#endif
freeList = NIL;
for (i=1; i<=heapSize; i++) {
if ((marks[place] & mask) == 0) {
freeList = -i;
recovered++;
}
+#if PROFILING
+ else if (nonNull(thd(-i)))
+ name(thd(-i)).count++;
+ else
+ sysCount++;
+#endif
mask <<= 1;
if (++j == bitsPerWord) {
place++;
gcRecovered(recovered);
breakOn(breakStat); /* restore break trapping if nec. */
+#if PROFILING
+ if (profile) {
+ fprintf(profile,"BEGIN_SAMPLE %ld.00\n",numReductions);
+/* For the time being, we won't include the system count in the output:
+ if (sysCount>0)
+ fprintf(profile," SYSTEM %d\n",sysCount);
+*/
+ /* Accumulate costs in top level objects */
+ for (i=NAMEMIN; i<nameHw; i++) {
+ Name cc = i;
+ /* Use of "while" instead of "if" is pure paranoia - ADR */
+ while (isName(name(cc).parent))
+ cc = name(cc).parent;
+ if (i != cc) {
+ name(cc).count += name(i).count;
+ name(i).count = 0;
+ }
+ }
+ for (i=NAMEMIN; i<nameHw; i++)
+ if (name(i).count>0)
+ if (isPair(name(i).parent)) {
+ Pair p = name(i).parent;
+ Cell f = fst(p);
+ fprintf(profile," ");
+ if (isClass(f))
+ fprintf(profile,"%s",textToStr(cclass(f).text));
+ else {
+ fprintf(profile,"%s_",textToStr(cclass(inst(f).c).text));
+ /* Will hp2ps accept the spaces produced by this? */
+ printPred(profile,inst(f).head);
+ }
+ fprintf(profile,"_%s %d\n",
+ textToStr(name(snd(p)).text),
+ name(i).count);
+ } else {
+ fprintf(profile," %s %d\n",
+ textToStr(name(i).text),
+ name(i).count);
+ }
+ fprintf(profile,"END_SAMPLE %ld.00\n",numReductions);
+ }
+#endif
+
/* can only return if freeList is nonempty on return. */
if (recovered<minRecovery || isNull(freeList)) {
ERRMSG(0) "Garbage collection fails to reclaim sufficient space"
cellsRecovered = recovered;
}
+#if PROFILING
+Void profilerLog(s) /* turn heap profiling on, saving log*/
+String s; { /* in specified file */
+ if ((profile=fopen(s,"w")) != NULL) {
+ fprintf(profile,"JOB \"Hugs Heap Profile\"\n");
+ fprintf(profile,"DATE \"%s\"\n",timeString());
+ fprintf(profile,"SAMPLE_UNIT \"reductions\"\n");
+ fprintf(profile,"VALUE_UNIT \"cells\"\n");
+ }
+ else {
+ ERRMSG(0) "Cannot open profile log file \"%s\"", s
+ EEND;
+ }
+}
+#endif
+
/* --------------------------------------------------------------------------
* Code for saving last expression entered:
*
* Miscellaneous operations on heap cells:
* ------------------------------------------------------------------------*/
-/* profiling suggests that the number of calls to whatIs() is typically */
+/* Profiling suggests that the number of calls to whatIs() is typically */
/* rather high. The recoded version below attempts to improve the average */
/* performance for whatIs() using a binary search for part of the analysis */
else return MODULE;
else if (c>=OFFMIN) return OFFSET;
#if TREX
- else if (c>=EXTMIN) return EXT;
+ else return (c>=EXTMIN) ?
+ EXT : TUPLE;
+#else
+ else return TUPLE;
#endif
- else return TUPLE;
/* if (isPair(c)) {
register Cell fstc = fst(c);
return isTag(fstc) ? fstc : AP;
}
+ if (c>=INTMIN) return INTCELL;
if (c>=CHARMIN) return CHARCELL;
if (c>=CLASSMIN) return CLASS;
if (c>=INSTMIN) return INSTANCE;
Int depth; {
if (0 == depth) {
Printf("...");
+#if 0 /* Not in this version of Hugs */
+ } else if (isPair(c) && !isGenPair(c)) {
+ extern Void printEvalCell Args((Cell, Int));
+ printEvalCell(c,depth);
+#endif
} else {
Int tag = whatIs(c);
switch (tag) {
Cell mkInt(n) /* make cell representing integer */
Int n; {
- return isSmall(INTZERO+n) ? INTZERO+n : pair(INTCELL,n);
+ return (MINSMALLINT <= n && n <= MAXSMALLINT)
+ ? INTZERO+n
+ : pair(INTCELL,n);
}
-#if PTR_ON_HEAP
+#if BIGNUMS
+Bool isBignum(c) /* cell holds bignum value? */
+Cell c; {
+ return c==ZERONUM || (isPair(c) && (fst(c)==POSNUM || fst(c)==NEGNUM));
+}
+#endif
+
#if SIZEOF_INTP == SIZEOF_INT
typedef union {Int i; Ptr p;} IntOrPtr;
Cell mkPtr(p)
Cell c;
{
IntOrPtr x;
- assert(isPtr(c));
+ assert(fst(c) == PTRCELL);
x.i = snd(c);
return x.p;
}
+#elif SIZEOF_INTP == 2*SIZEOF_INT
+typedef union {struct {Int i1; Int i2;} i; Ptr p;} IntOrPtr;
+Cell mkPtr(p)
+Ptr p;
+{
+ IntOrPtr x;
+ x.p = p;
+ return pair(PTRCELL,pair(mkInt(x.i.i1),mkInt(x.i.i2)));
+}
+
+Ptr ptrOf(c)
+Cell c;
+{
+ IntOrPtr x;
+ assert(fst(c) == PTRCELL);
+ x.i.i1 = intOf(fst(snd(c)));
+ x.i.i2 = intOf(snd(snd(c)));
+ return x.p;
+}
#else
-/* For 8 byte addresses (used on the Alpha), we'll have to work harder */
-#error "PTR_ON_HEAP not supported on this architecture"
-#endif
-#endif
+#warning "type Addr not supported on this architecture - don't use it"
+Cell mkPtr(p)
+Ptr p;
+{
+ ERRMSG(0) "mkPtr: type Addr not supported on this architecture"
+ EEND;
+}
-String stringNegate( s )
-String s;
+Ptr ptrOf(c)
+Cell c;
{
- if (s[0] == '-') {
- return &s[1];
- } else {
- static char t[100];
- t[0] = '-';
- strcpy(&t[1],s); /* ToDo: use strncpy instead */
- return t;
- }
+ ERRMSG(0) "ptrOf: type Addr not supported on this architecture"
+ EEND;
}
+#endif
/* --------------------------------------------------------------------------
* List operations:
Int length(xs) /* calculate length of list xs */
List xs; {
Int n = 0;
- for (n=0; nonNull(xs); ++n)
+ for (; nonNull(xs); ++n)
xs = tl(xs);
return n;
}
}
}
-List revDupOnto(xs,ys) /* non-destructively prepend xs backwards onto ys */
+List dupOnto(xs,ys) /* non-destructively prepend xs backwards onto ys */
List xs;
List ys; {
- for( ; nonNull(xs); xs=tl(xs)) {
+ for (; nonNull(xs); xs=tl(xs))
ys = cons(hd(xs),ys);
- }
return ys;
}
-List dupListOnto(xs,ys) /* Duplicate spine of list xs onto ys */
-List xs;
-List ys; {
- return revOnto(revDupOnto(xs,NIL),ys);
+List dupList(xs) /* Duplicate spine of list xs */
+List xs; {
+ List ys = NIL;
+ for (; nonNull(xs); xs=tl(xs))
+ ys = cons(hd(xs),ys);
+ return rev(ys);
}
List revOnto(xs,ys) /* Destructively reverse elements of*/
return ys;
}
-Bool eqList(as,bs)
-List as;
-List bs; {
- while (nonNull(as) && nonNull(bs) && hd(as)==hd(bs)) {
- as=tl(as);
- bs=tl(bs);
+#if 0
+List delete(xs,y) /* Delete first use of y from xs */
+List xs;
+Cell y; {
+ if (isNull(xs)) {
+ return xs;
+ } else if (hs(xs) == y) {
+ return tl(xs);
+ } else {
+ tl(xs) = delete(tl(xs),y);
+ return xs;
}
- return (isNull(as) && isNull(bs));
}
+List minus(xs,ys) /* Delete members of ys from xs */
+List xs, ys; {
+ mapAccum(delete,xs,ys);
+ return xs;
+}
+#endif
+
Cell varIsMember(t,xs) /* Test if variable is a member of */
Text t; /* given list of variables */
List xs; {
return NIL;
}
+Name nameIsMember(t,ns) /* Test if name with text t is a */
+Text t; /* member of list of names xs */
+List ns; {
+ for (; nonNull(ns); ns=tl(ns))
+ if (t==name(hd(ns)).text)
+ return hd(ns);
+ return NIL;
+}
+
Cell intIsMember(n,xs) /* Test if integer n is member of */
Int n; /* given list of integers */
List xs; {
return NIL;
}
-List replicate(n,x) /* create list of n copies of x */
+List replicate(n,x) /* create list of n copies of x */
Int n;
Cell x; {
List xs=NIL;
- assert(n>=0);
- while (0<n--) {
+ while (0<n--)
xs = cons(x,xs);
- }
return xs;
}
-List diffList(xs,ys) /* list difference: xs\ys */
-List xs, ys; { /* result contains all elements of */
- List result = NIL; /* `xs' not appearing in `ys' */
- while (nonNull(xs)) {
- List next = tl(xs);
- if (!cellIsMember(hd(xs),ys)) {
- tl(xs) = result;
- result = xs;
+List diffList(from,take) /* list difference: from\take */
+List from, take; { /* result contains all elements of */
+ List result = NIL; /* `from' not appearing in `take' */
+
+ while (nonNull(from)) {
+ List next = tl(from);
+ if (!cellIsMember(hd(from),take)) {
+ tl(from) = result;
+ result = from;
}
- xs = next;
+ from = next;
}
return rev(result);
}
List xs; {
List ys = xs;
- assert(n>=0);
if (n==0)
return NIL;
while (1<n-- && nonNull(xs))
return ys;
}
-List splitAt(n,xs) /* drop n things from front of list */
+List splitAt(n,xs) /* drop n things from front of list*/
Int n;
List xs; {
- assert(n>=0);
for(; n>0; --n) {
xs = tl(xs);
}
Cell nth(n,xs) /* extract n'th element of list */
Int n;
List xs; {
- assert(n>=0);
for(; n>0 && nonNull(xs); --n, xs=tl(xs)) {
}
- assert(nonNull(xs));
+ if (isNull(xs))
+ internal("nth");
return hd(xs);
}
Cell nthArg(n,e) /* return nth arg in application */
Int n; /* of function to m args (m>=n) */
Cell e; { /* nthArg n (f x0 x1 ... xm) = xn */
- assert(n>=0);
for (n=numArgs(e)-n-1; n>0; n--)
e = fun(e);
return arg(e);
}
/* --------------------------------------------------------------------------
+ * Handle operations:
+ * ------------------------------------------------------------------------*/
+
+#if IO_HANDLES
+struct strHandle DEFTABLE(handles,NUM_HANDLES);
+
+Cell openHandle(s,hmode,binary) /* open handle to file named s in */
+String s; /* the specified hmode */
+Int hmode;
+Bool binary; {
+ Int i;
+
+ for (i=0; i<NUM_HANDLES && nonNull(handles[i].hcell); ++i)
+ ; /* Search for unused handle*/
+ if (i>=NUM_HANDLES) { /* If at first we don't */
+ garbageCollect(); /* succeed, garbage collect*/
+ for (i=0; i<NUM_HANDLES && nonNull(handles[i].hcell); ++i)
+ ; /* and try again ... */
+ }
+ if (i>=NUM_HANDLES) { /* ... before we give up */
+ ERRMSG(0) "Too many handles open; cannot open \"%s\"", s
+ EEND;
+ }
+ else { /* prepare to open file */
+ String stmode;
+ if (binary) {
+ stmode = (hmode&HAPPEND) ? "ab+" :
+ (hmode&HWRITE) ? "wb+" :
+ (hmode&HREAD) ? "rb" : (String)0;
+ } else {
+ stmode = (hmode&HAPPEND) ? "a+" :
+ (hmode&HWRITE) ? "w+" :
+ (hmode&HREAD) ? "r" : (String)0;
+ }
+ if (stmode && (handles[i].hfp=fopen(s,stmode))) {
+ handles[i].hmode = hmode;
+ return (handles[i].hcell = ap(HANDCELL,i));
+ }
+ }
+ return NIL;
+}
+
+static Void local freeHandle(n) /* release handle storage when no */
+Int n; { /* heap references to it remain */
+ if (0<=n && n<NUM_HANDLES && nonNull(handles[n].hcell)) {
+ if (n>HSTDERR && handles[n].hmode!=HCLOSED && handles[n].hfp) {
+ fclose(handles[n].hfp);
+ handles[n].hfp = 0;
+ }
+ fst(handles[n].hcell) = snd(handles[n].hcell) = NIL;
+ handles[n].hcell = NIL;
+ }
+}
+#endif
+
+#if GC_MALLOCPTRS
+/* --------------------------------------------------------------------------
+ * Malloc Ptrs:
+ * ------------------------------------------------------------------------*/
+
+struct strMallocPtr mallocPtrs[NUM_MALLOCPTRS];
+
+/* It might GC (because it uses a table not a list) which will trash any
+ * unstable pointers.
+ * (It happens that we never use it with unstable pointers.)
+ */
+Cell mkMallocPtr(ptr,cleanup) /* create a new malloc pointer */
+Ptr ptr;
+Void (*cleanup) Args((Ptr)); {
+ Int i;
+ for (i=0; i<NUM_MALLOCPTRS && mallocPtrs[i].refCount!=0; ++i)
+ ; /* Search for unused entry */
+ if (i>=NUM_MALLOCPTRS) { /* If at first we don't */
+ garbageCollect(); /* succeed, garbage collect*/
+ for (i=0; i<NUM_MALLOCPTRS && mallocPtrs[i].refCount!=0; ++i)
+ ; /* and try again ... */
+ }
+ if (i>=NUM_MALLOCPTRS) { /* ... before we give up */
+ ERRMSG(0) "Too many ForeignObjs open"
+ EEND;
+ }
+ mallocPtrs[i].ptr = ptr;
+ mallocPtrs[i].cleanup = cleanup;
+ mallocPtrs[i].refCount = 1;
+ return (mallocPtrs[i].mpcell = ap(MPCELL,i));
+}
+
+Void incMallocPtrRefCnt(n,i) /* change ref count of MallocPtr */
+Int n;
+Int i; {
+ if (!(0<=n && n<NUM_MALLOCPTRS && mallocPtrs[n].refCount > 0))
+ internal("freeMallocPtr");
+ mallocPtrs[n].refCount += i;
+ if (mallocPtrs[n].refCount <= 0) {
+ mallocPtrs[n].cleanup(mallocPtrs[n].ptr);
+
+ mallocPtrs[n].ptr = 0;
+ mallocPtrs[n].cleanup = 0;
+ mallocPtrs[n].refCount = 0;
+ mallocPtrs[n].mpcell = NIL;
+ }
+}
+#endif /* GC_MALLOCPTRS */
+
+/* --------------------------------------------------------------------------
+ * Stable pointers
+ * This is a mechanism that allows the C world to manipulate pointers into the
+ * Haskell heap without having to worry that the garbage collector is going
+ * to delete it or move it around.
+ * The implementation and interface is based on my implementation in
+ * GHC - but, at least for now, is simplified by using a fixed size
+ * table of stable pointers.
+ * ------------------------------------------------------------------------*/
+
+#if GC_STABLEPTRS
+
+/* Each entry in the stable pointer table is either a heap pointer
+ * or is not currently allocated.
+ * Unallocated entries are threaded together into a freelist.
+ * The last entry in the list contains the Cell 0; all other values
+ * contain a Cell whose value is the next free stable ptr in the list.
+ * It follows that stable pointers are strictly positive (>0).
+ */
+static Cell stablePtrTable[NUM_STABLEPTRS];
+static Int sptFreeList;
+#define SPT(sp) stablePtrTable[(sp)-1]
+
+static Void local resetStablePtrs() {
+ Int i;
+ /* It would be easier to build the free list in the other direction
+ * but, when debugging, it's way easier to understand if the first
+ * pointer allocated is "1".
+ */
+ for(i=1; i < NUM_STABLEPTRS; ++i)
+ SPT(i) = i+1;
+ SPT(NUM_STABLEPTRS) = 0;
+ sptFreeList = 1;
+}
+
+Int mkStablePtr(c) /* Create a stable pointer */
+Cell c; {
+ Int i = sptFreeList;
+ if (i == 0)
+ return 0;
+ sptFreeList = SPT(i);
+ SPT(i) = c;
+ return i;
+}
+
+Cell derefStablePtr(p) /* Dereference a stable pointer */
+Int p; {
+ if (!(1 <= p && p <= NUM_STABLEPTRS)) {
+ internal("derefStablePtr");
+ }
+ return SPT(p);
+}
+
+Void freeStablePtr(i) /* Free a stable pointer */
+Int i; {
+ SPT(i) = sptFreeList;
+ sptFreeList = i;
+}
+
+#undef SPT
+#endif /* GC_STABLEPTRS */
+
+/* --------------------------------------------------------------------------
+ * plugin support
+ * ------------------------------------------------------------------------*/
+
+/*---------------------------------------------------------------------------
+ * GreenCard entry points
+ *
+ * GreenCard generated code accesses Hugs data structures and functions
+ * (only) via these functions (which are stored in the virtual function
+ * table hugsAPI1.
+ *-------------------------------------------------------------------------*/
+
+#if GREENCARD
+
+static Cell makeTuple Args((Int));
+static Cell makeInt Args((Int));
+static Cell makeChar Args((Char));
+static Char CharOf Args((Cell));
+static Cell makeFloat Args((FloatPro));
+static Void* derefMallocPtr Args((Cell));
+static Cell* Fst Args((Cell));
+static Cell* Snd Args((Cell));
+
+static Cell makeTuple(n) Int n; { return mkTuple(n); }
+static Cell makeInt(n) Int n; { return mkInt(n); }
+static Cell makeChar(n) Char n; { return mkChar(n); }
+static Char CharOf(n) Cell n; { return charOf(n); }
+static Cell makeFloat(n) FloatPro n; { return mkFloat(n); }
+static Void* derefMallocPtr(n) Cell n; { return derefMP(n); }
+static Cell* Fst(n) Cell n; { return (Cell*)&fst(n); }
+static Cell* Snd(n) Cell n; { return (Cell*)&snd(n); }
+
+HugsAPI1* hugsAPI1() {
+ static HugsAPI1 api;
+ static Bool initialised = FALSE;
+ if (!initialised) {
+ api.nameTrue = nameTrue;
+ api.nameFalse = nameFalse;
+ api.nameNil = nameNil;
+ api.nameCons = nameCons;
+ api.nameJust = nameJust;
+ api.nameNothing = nameNothing;
+ api.nameLeft = nameLeft;
+ api.nameRight = nameRight;
+ api.nameUnit = nameUnit;
+ api.nameIORun = nameIORun;
+ api.makeInt = makeInt;
+ api.makeChar = makeChar;
+ api.CharOf = CharOf;
+ api.makeFloat = makeFloat;
+ api.makeTuple = makeTuple;
+ api.pair = pair;
+ api.mkMallocPtr = mkMallocPtr;
+ api.derefMallocPtr = derefMallocPtr;
+ api.mkStablePtr = mkStablePtr;
+ api.derefStablePtr = derefStablePtr;
+ api.freeStablePtr = freeStablePtr;
+ api.eval = eval;
+ api.evalWithNoError = evalWithNoError;
+ api.evalFails = evalFails;
+ api.whnfArgs = &whnfArgs;
+ api.whnfHead = &whnfHead;
+ api.whnfInt = &whnfInt;
+ api.whnfFloat = &whnfFloat;
+ api.garbageCollect = garbageCollect;
+ api.stackOverflow = hugsStackOverflow;
+ api.internal = internal;
+ api.registerPrims = registerPrims;
+ api.addPrimCfun = addPrimCfun;
+ api.inventText = inventText;
+ api.Fst = Fst;
+ api.Snd = Snd;
+ api.cellStack = cellStack;
+ api.sp = &sp;
+ }
+ return &api;
+}
+
+#endif /* GREENCARD */
+
+
+/* --------------------------------------------------------------------------
* storage control:
* ------------------------------------------------------------------------*/
switch (what) {
case RESET : clearStack();
+ /* the next 2 statements are particularly important
+ * if you are using GLOBALfst or GLOBALsnd since the
+ * corresponding registers may be reset to their
+ * uninitialised initial values by a longjump.
+ */
+ heapTopFst = heapFst + heapSize;
+ heapTopSnd = heapSnd + heapSize;
+#if PROFILING
+ heapTopThd = heapThd + heapSize;
+ if (profile) {
+ garbageCollect();
+ fclose(profile);
+#if HAVE_HP2PS
+ system("hp2ps profile.hp");
+#endif
+ profile = 0;
+ }
+#endif
+#if IO_HANDLES
+ handles[HSTDIN].hmode = HREAD;
+ handles[HSTDOUT].hmode = HAPPEND;
+ handles[HSTDERR].hmode = HAPPEND;
+#endif
+#if GC_MALLOCPTRS
+ for (i=0; i<NUM_MALLOCPTRS; i++)
+ mallocPtrs[i].mpcell = NIL;
+#endif
+#if !HSCRIPT
+#if GC_STABLEPTRS
+ resetStablePtrs();
+#endif
+#endif
consGC = TRUE;
lsave = NIL;
rsave = NIL;
case MARK :
start();
for (i=NAMEMIN; i<nameHw; ++i) {
+ mark(name(i).parent);
mark(name(i).defn);
mark(name(i).stgVar);
mark(name(i).type);
}
end("Names", nameHw-NAMEMIN);
+#if !IGNORE_MODULES
start();
for (i=MODMIN; i<moduleHw; ++i) {
mark(module(i).tycons);
mark(module(i).qualImports);
}
end("Modules", moduleHw-MODMIN);
+#endif
start();
for (i=TYCMIN; i<tyconHw; ++i) {
start();
for (i=INSTMIN; i<instHw; ++i) {
- mark(inst(i).kinds);
mark(inst(i).head);
+ mark(inst(i).kinds);
mark(inst(i).specifics);
mark(inst(i).implements);
}
mark(lsave);
mark(rsave);
end("Last expression", 3);
+#if IO_HANDLES
+ start();
+ mark(handles[HSTDIN].hcell);
+ mark(handles[HSTDOUT].hcell);
+ mark(handles[HSTDERR].hcell);
+ end("Standard handles", 3);
+#endif
+
+#if GC_STABLEPTRS
+ start();
+ for (i=0; i<NUM_STABLEPTRS; ++i)
+ mark(stablePtrTable[i]);
+ end("Stable pointers", NUM_STABLEPTRS);
+#endif
+
+#if GC_WEAKPTRS
+ mark(finalizers);
+#endif
if (consGC) {
start();
heapTopFst = heapFst + heapSize;
heapTopSnd = heapSnd + heapSize;
+#if PROFILING
+ heapThd = heapAlloc(heapSize);
+ if (heapThd==(Heap)0) {
+ ERRMSG(0) "Cannot allocate profiler storage space"
+ EEND;
+ }
+ heapTopThd = heapThd + heapSize;
+ profile = 0;
+ if (0 == profInterval)
+ profInterval = heapSize / DEF_PROFINTDIV;
+#endif
for (i=1; i<heapSize; ++i) {
fst(-i) = FREECELL;
snd(-i) = -(i+1);
}
snd(-heapSize) = NIL;
freeList = -1;
+ numGcs = 0;
consGC = TRUE;
lsave = NIL;
rsave = NIL;
}
TABALLOC(text, char, NUM_TEXT)
- TABALLOC(tabSyntax, struct strSyntax, NUM_SYNTAX)
TABALLOC(tyconHash, Tycon, TYCONHSZ)
TABALLOC(tabTycon, struct strTycon, NUM_TYCON)
TABALLOC(nameHash, Name, NAMEHSZ)
#endif
clearStack();
+#if IO_HANDLES
+ TABALLOC(handles, struct strHandle, NUM_HANDLES)
+ for (i=0; i<NUM_HANDLES; i++)
+ handles[i].hcell = NIL;
+ handles[HSTDIN].hcell = ap(HANDCELL,HSTDIN);
+ handles[HSTDIN].hfp = stdin;
+ handles[HSTDOUT].hcell = ap(HANDCELL,HSTDOUT);
+ handles[HSTDOUT].hfp = stdout;
+ handles[HSTDERR].hcell = ap(HANDCELL,HSTDERR);
+ handles[HSTDERR].hfp = stderr;
+#endif
+
textHw = 0;
nextNewText = NUM_TEXT;
nextNewDText = (-1);
for (i=0; i<TEXTHSZ; ++i)
textHash[i][0] = NOTEXT;
- syntaxHw = 0;
+#if !IGNORE_MODULES
moduleHw = MODMIN;
+#endif
tyconHw = TYCMIN;
for (i=0; i<TYCONHSZ; ++i)
tyconHash[i] = NIL;
+#if GC_WEAKPTRS
+ finalizers = NIL;
+ liveWeakPtrs = NIL;
+#endif
+
+#if GC_STABLEPTRS
+ resetStablePtrs();
+#endif
+
#if TREX
extHw = EXTMIN;
#endif
-/* -*- mode: hugs-c; -*- */
+
/* --------------------------------------------------------------------------
* Defines storage datatypes: Text, Name, Module, Tycon, Cell, List, Pair,
* Triple, ...
*
- * 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
+ * Hugs 98 is Copyright (c) Mark P Jones, Alastair Reid and the Yale
+ * Haskell Group 1994-99, and is distributed as Open Source software
+ * under the Artistic License; see the file "Artistic" that is included
+ * in the distribution for details.
*
* $RCSfile: storage.h,v $
- * $Revision: 1.2 $
- * $Date: 1998/12/02 13:22:43 $
+ * $Revision: 1.3 $
+ * $Date: 1999/02/03 17:08:41 $
* ------------------------------------------------------------------------*/
/* --------------------------------------------------------------------------
* ------------------------------------------------------------------------*/
typedef Int Text; /* text string */
-typedef Word Syntax; /* syntax (assoc,preced) */
+typedef Unsigned Syntax; /* syntax (assoc,preced) */
typedef Int Cell; /* general cell value */
typedef Cell far *Heap; /* storage of heap */
typedef Cell Pair; /* pair cell */
typedef Cell Inst; /* instance of type class */
typedef Cell Triple; /* triple of cell values */
typedef Cell List; /* list of cells */
-typedef Cell Bignum; /* integer literal */
+typedef Cell Bignum; /* bignum integer */
typedef Cell Float; /* floating pt literal */
#if TREX
typedef Cell Ext; /* extension label */
#define MAX_PREC 9 /* strongest binding operator */
#define FUN_PREC (MAX_PREC+2) /* binding of function symbols */
#define DEF_PREC MAX_PREC
-#define APPLIC 00000 /* written applicatively */
-#define LEFT_ASS 02000 /* left associative infix */
-#define RIGHT_ASS 04000 /* right associative infix */
-#define NON_ASS 06000 /* non associative infix */
-#define DEF_ASS NON_ASS
+#define APPLIC 0 /* written applicatively */
+#define LEFT_ASS 1 /* left associative infix */
+#define RIGHT_ASS 2 /* right associative infix */
+#define NON_ASS 3 /* non associative infix */
+#define DEF_ASS LEFT_ASS
+
+#define UMINUS_PREC 6 /* Change these settings at your */
+#define UMINUS_ASSOC LEFT_ASS /* own risk; they may not work! */
#define assocOf(x) ((x)&NON_ASS)
-#define precOf(x) ((x)&(~NON_ASS))
-#define mkSyntax(a,p) ((a)|(p))
+#define precOf(x) ((x)>>2)
+#define mkSyntax(a,p) ((a)|((p)<<2))
#define DEF_OPSYNTAX mkSyntax(DEF_ASS,DEF_PREC)
+#define NO_SYNTAX (-1)
extern Void addSyntax Args((Int,Text,Syntax));
extern Syntax syntaxOf Args((Text));
#define fst(c) heapTopFst[c]
#define snd(c) heapTopSnd[c]
+#if PROFILING
+extern Heap heapThd, heapTopThd;
+#define thd(c) heapTopThd[c]
+extern Name producer;
+extern Bool profiling;
+extern Int profInterval;
+extern Void profilerLog Args((String));
+#endif
extern Pair pair Args((Cell,Cell));
extern Void garbageCollect Args((Void));
#define CONOPCELL 8 /* Operator constructor: snd :: Text */
#define STRCELL 9 /* String literal: snd :: Text */
#define INTCELL 10 /* Int literal: snd :: Int */
+#define ADDPAT 11 /* (_+k) pattern discr: snd :: Int */
#define FLOATCELL 15 /* Floating Pt literal: snd :: Text */
#define BIGCELL 16 /* Integer literal: snd :: Text */
#if PTR_ON_HEAP
extern Bool isQualIdent Args((Cell));
extern Bool isIdent Args((Cell));
-extern String stringNegate Args((String));
+#if 0
+Originally ...
+#define isFloat(c) (isPair(c) && fst(c)==FLOATCELL)
+extern Cell mkFloat Args((FloatPro));
+extern FloatPro floatOf Args((Cell));
+extern String floatToString Args((FloatPro));
+extern FloatPro stringToFloat Args((String));
+#else
+#define isFloat(c) (isPair(c) && fst(c)==FLOATCELL)
+#define stringToFloat(s) pair(FLOATCELL,findText(s))
+#define floatToString(f) textToStr(snd(f))
+#define floatEq(f1,f2) (snd(f1) == snd(f2))
+#define floatNegate(f) stringToFloat(stringNegate(floatToString(f)))
+#define floatOf(f) atof(floatToString(f))
+#endif
+
+
-#define intEq(x,y) (intOf(x) == intOf(y))
-#define intNegate(x) mkInt(-intOf(x))
#define isFloat(c) (isPair(c) && fst(c)==FLOATCELL)
#define stringToFloat(s) pair(FLOATCELL,findText(s))
#define floatEq(f1,f2) (snd(f1) == snd(f2))
#define floatNegate(f) stringToFloat(stringNegate(floatToString(f)))
#define floatOf(f) atof(floatToString(f))
+#define mkFloat(f) (f) /* ToDo: is this right? */
-#define isBignum(c) (isPair(c) && fst(c)==BIGCELL)
-#define stringToBignum(s) pair(BIGCELL,findText(s))
#define bignumToString(b) textToStr(snd(b))
-#define bignumEq(b1,b2) (snd(b1) == snd(b2))
-#define bignumNegate(b) stringToBignum(stringNegate(bignumToString(b)))
-#define bignumOf(b) atoi(bignumToString(b)) /* ToDo: overflow check */
+
#if PTR_ON_HEAP
#define isPtr(c) (isPair(c) && fst(c)==PTRCELL)
#define COMP 26 /* COMP snd :: (Exp,[Qual]) */
#define ASPAT 27 /* ASPAT snd :: (Var,Exp) */
#define ESIGN 28 /* ESIGN snd :: (Exp,Type) */
-#define CASE 29 /* CASE snd :: (Exp,[Alt]) */
-#define NUMCASE 30 /* NUMCASE snd :: (Exp,Disc,Rhs) */
-#define FATBAR 31 /* FATBAR snd :: (Exp,Exp) */
-#define LAZYPAT 32 /* LAZYPAT snd :: Exp */
+#define RSIGN 29 /* RSIGN snd :: (Rhs,Type) */
+#define CASE 30 /* CASE snd :: (Exp,[Alt]) */
+#define NUMCASE 31 /* NUMCASE snd :: (Exp,Disc,Rhs) */
+#define FATBAR 32 /* FATBAR snd :: (Exp,Exp) */
+#define LAZYPAT 33 /* LAZYPAT snd :: Exp */
#define DERIVE 35 /* DERIVE snd :: Cell */
-#if NPLUSK
-#define ADDPAT 36 /* (_+k) pattern discr: snd :: Cell */
+#if BREAK_FLOATS
+#define FLOATCELL 36 /* FLOATCELL snd :: (Int,Int) */
+#endif
+
+#if BIGNUMS
+#define POSNUM 37 /* POSNUM snd :: [Int] */
+#define NEGNUM 38 /* NEGNUM snd :: [Int] */
#endif
#define BOOLQUAL 39 /* BOOLQUAL snd :: Exp */
#define QWHERE 40 /* QWHERE snd :: [Decl] */
#define FROMQUAL 41 /* FROMQUAL snd :: (Exp,Exp) */
#define DOQUAL 42 /* DOQUAL snd :: Exp */
+#define MONADCOMP 43 /* MONADCOMP snd :: ((m,m0),(Exp,[Qual])*/
#define GUARDED 44 /* GUARDED snd :: [guarded exprs] */
-#define ARRAY 45 /* Array: snd :: (Bounds,[Values]) */
-#define MUTVAR 46 /* Mutvar: snd :: Cell */
+#define ARRAY 45 /* Array snd :: (Bounds,[Values]) */
+#define MUTVAR 46 /* Mutvar snd :: Cell */
+#if INTERNAL_PRIMS
+#define HUGSOBJECT 47 /* HUGSOBJECT snd :: Cell */
+#endif
#define POLYTYPE 50 /* POLYTYPE snd :: (Kind,Type) */
#define QUAL 51 /* QUAL snd :: ([Classes],Type) */
#define RANK2 52 /* RANK2 snd :: (Int,Type) */
#define EXIST 53 /* EXIST snd :: (Int,Type) */
-#define POLYREC 54 /* POLYREC: snd :: (Int,Type) */
-#define BIGLAM 55 /* BIGLAM: snd :: (vars,patterns) */
+#define POLYREC 54 /* POLYREC snd :: (Int,Type) */
+#define BIGLAM 55 /* BIGLAM snd :: (vars,patterns) */
+#define CDICTS 56 /* CDICTS snd :: ([Pred],Type) */
-#define LABC 60 /* LABC: snd :: (con,[(Vars,Type)]) */
-#define CONFLDS 61 /* CONFLDS: snd :: (con,[Field]) */
-#define UPDFLDS 62 /* UPDFLDS: snd :: (Exp,[con],[Field]) */
+#define LABC 60 /* LABC snd :: (con,[(Vars,Type)]) */
+#define CONFLDS 61 /* CONFLDS snd :: (con,[Field]) */
+#define UPDFLDS 62 /* UPDFLDS snd :: (Exp,[con],[Field]) */
#if TREX
-#define RECORD 63 /* RECORD: snd :: [Val] */
-#define EXTCASE 64 /* EXTCASE: snd :: (Exp,Disc,Rhs) */
-#define RECSEL 65 /* RECSEL: snd :: Ext */
+#define RECORD 63 /* RECORD snd :: [Val] */
+#define EXTCASE 64 /* EXTCASE snd :: (Exp,Disc,Rhs) */
+#define RECSEL 65 /* RECSEL snd :: Ext */
#endif
+#define IMPDEPS 68 /* IMPDEPS snd :: [Binding] */
#define QUALIDENT 70 /* Qualified identifier snd :: (Id,Id) */
#define HIDDEN 71 /* hiding import list snd :: [Entity] */
#define MODULEENT 72 /* module in export list snd :: con */
-#define ONLY 75 /* ONLY: snd :: Exp (used in parser)*/
-#define NEG 76 /* NEG: snd :: Exp (used in parser)*/
+#define INFIX 80 /* INFIX snd :: (see tidyInfix) */
+#define ONLY 81 /* ONLY snd :: Exp */
+#define NEG 82 /* NEG snd :: Exp */
-#define IMPDEPS 78 /* IMPDEFS: snd :: [Binding] */
-
-#define STGVAR 80 /* STGVAR snd :: (StgRhs,info) */
-#define STGAPP 81 /* STGAPP snd :: (StgVar,[Arg]) */
-#define STGPRIM 82 /* STGPRIM snd :: (PrimOp,[Arg]) */
-#define STGCON 83 /* STGCON snd :: (StgCon,[Arg]) */
-#define PRIMCASE 84 /* PRIMCASE snd :: (Expr,[PrimAlt]) */
+#if SIZEOF_INTP != SIZEOF_INT
+#define PTRCELL 90 /* C Heap Pointer snd :: (Int,Int) */
+#endif
-/* Used when parsing GHC interface files */
-#define DICTAP 85 /* DICTTYPE snd :: (QClassId,[Type]) */
+#define STGVAR 92 /* STGVAR snd :: (StgRhs,info) */
+#define STGAPP 93 /* STGAPP snd :: (StgVar,[Arg]) */
+#define STGPRIM 94 /* STGPRIM snd :: (PrimOp,[Arg]) */
+#define STGCON 95 /* STGCON snd :: (StgCon,[Arg]) */
+#define PRIMCASE 96 /* PRIMCASE snd :: (Expr,[PrimAlt]) */
/* Last constructor tag must be less than SPECMIN */
#define DOTDOT 106 /* ".." in import/export list */
+#if BIGNUMS
+#define ZERONUM 108 /* The zero bignum (see POSNUM, NEGNUM) */
+#endif
+
#define NAME 110 /* whatIs code for isName */
#define TYCON 111 /* whatIs code for isTycon */
#define CLASS 112 /* whatIs code for isClass */
#endif
#define SIGDECL 120 /* Signature declaration */
-#define PREDEFINED 121 /* predefined name, not yet filled */
+#define FIXDECL 121 /* Fixity declaration */
+#define FUNBIND 122 /* Function binding */
+#define PATBIND 123 /* Pattern binding */
-#define DATATYPE 130 /* datatype type constructor */
-#define NEWTYPE 131 /* newtype type constructor */
-#define SYNONYM 132 /* synonym type constructor */
-#define RESTRICTSYN 133 /* synonym with restricted scope */
+#define DATATYPE 130 /* Datatype type constructor */
+#define NEWTYPE 131 /* Newtype type constructor */
+#define SYNONYM 132 /* Synonym type constructor */
+#define RESTRICTSYN 133 /* Synonym with restricted scope */
-#define NODEPENDS 135 /* stop calculation of deps in type check*/
+#define NODEPENDS 135 /* Stop calculation of deps in type check*/
+#define PREDEFINED 136 /* Predefined name, not yet filled */
/* --------------------------------------------------------------------------
* Tuple data/type constructors:
#define MODMIN (OFFMIN+NUM_OFFSETS)
+#if IGNORE_MODULES
+#define setCurrModule(m) doNothing()
+#else /* !IGNORE_MODULES */
#define isModule(c) (MODMIN<=(c) && (c)<TYCMIN)
#define mkModule(n) (MODMIN+(n))
#define module(n) tabModule[(n)-MODMIN]
extern Module findModid Args((Cell));
extern Void setCurrModule Args((Module));
+#define isPrelude(m) (m==modulePrelude)
+#endif /* !IGNORE_MODULES */
+
/* --------------------------------------------------------------------------
* Type constructor names:
* ------------------------------------------------------------------------*/
struct strTycon {
Text text;
Int line;
+#if !IGNORE_MODULES
Module mod; /* module that defines it */
+#endif
Int arity;
Kind kind; /* kind (includes arity) of Tycon */
Cell what; /* DATATYPE/SYNONYM/RESTRICTSYN... */
Cell defn;
- Name conToTag; /* used in derived code */
- Name tagToCon;
Tycon nextTyconHash;
};
extern Tycon findTycon Args((Text));
extern Tycon addTycon Args((Tycon));
extern Tycon findQualTycon Args((Cell));
-extern Tycon addPrimTycon Args((Text,Kind,Int,Cell,Cell));
+extern Tycon addPrimTycon Args((Text,Kind,Int,Cell,Cell));
#define isSynonym(h) (isTycon(h) && tycon(h).what==SYNONYM)
#define mkPolyType(n,t) pair(POLYTYPE,pair(n,t))
Text text;
Int line;
Module mod; /* module that defines it */
+ Syntax syntax;
+ Cell parent;
Int arity;
Int number;
Cell type;
#define mfunOf(n) ((-1)-name(n).number)
#define mfunNo(i) ((-1)-(i))
-extern Name newName Args((Text));
+extern Name newName Args((Text,Cell));
extern Name findName Args((Text));
extern Name addName Args((Name));
-extern Name findQualName Args((Int,Cell));
+extern Name findQualName Args((Cell));
extern Name addPrimCfun Args((Text,Int,Int,Int));
extern Int sfunPos Args((Name,Name));
* Type class values:
* ------------------------------------------------------------------------*/
-#define INSTMIN (NAMEMIN+NUM_NAME) /* instances */
+#define INSTMIN (NAMEMIN+NUM_NAME) /* instances */
#define isInst(c) (INSTMIN<=(c) && (c)<CLASSMIN)
#define mkInst(n) (INSTMIN+(n))
#define instOf(c) ((Int)((c)-INSTMIN))
#define cclass(n) tabClass[(n)-CLASSMIN]
struct strClass {
- Text text; /* Name of class */
- Int line; /* Line where declaration begins */
- Module mod; /* module that defines it */
- Int level; /* Level in class hierarchy */
- Int arity; /* Number of arguments */
- Kinds kinds; /* Kinds of constructors in class */
- Cell head; /* Head of class */
- Name dcon; /* Dictionay constructor function */
- List supers; /* :: [Pred] */
- Int numSupers; /* length(supers) */
- List dsels; /* Superclass dictionary selectors */
- List members; /* :: [Name] */
- Int numMembers; /* length(members) */
- Name dbuild; /* Default dictionary builder */
- List defaults; /* :: [Name] */
- List instances; /* :: [Inst] */
+ Text text; /* Name of class */
+ Int line; /* Line where declaration begins */
+#if !IGNORE_MODULES
+ Module mod; /* module that declares it */
+#endif
+ Int level; /* Level in class hierarchy */
+ Int arity; /* Number of arguments */
+ Kinds kinds; /* Kinds of constructors in class */
+ Cell head; /* Head of class */
+ Name dcon; /* Dictionary constructor function */
+ List supers; /* :: [Pred] */
+ Int numSupers; /* length(supers) */
+ List dsels; /* Superclass dictionary selectors */
+ List members; /* :: [Name] */
+ Int numMembers; /* length(members) */
+ Name dbuild; /* Default dictionary builder */
+ List defaults; /* :: [Name] */
+ List instances; /* :: [Inst] */
};
extern struct strClass DECTABLE(tabClass);
* ------------------------------------------------------------------------*/
#define INTMIN (CHARMIN+NUM_CHARS)
-#define INTMAX MAXPOSINT
+#define INTMAX (MAXPOSINT)
#define isSmall(c) (INTMIN<=(c))
#define INTZERO (INTMIN/2 + INTMAX/2)
+#define MINSMALLINT (INTMIN - INTZERO)
+#define MAXSMALLINT (INTMAX - INTZERO)
#define mkDigit(c) ((Cell)((c)+INTMIN))
#define digitOf(c) ((Int)((c)-INTMIN))
extern Bool isInt Args((Cell));
extern Int intOf Args((Cell));
extern Cell mkInt Args((Int));
+#if BIGNUMS
+extern Bool isBignum Args((Cell));
+#endif
/* --------------------------------------------------------------------------
* Implementation of triples:
#define tl(c) snd(c)
extern Int length Args((List));
-extern List appendOnto Args((List,List)); /* destructive */
-extern List revDupOnto Args((List,List)); /* non-destructive */
-extern List dupListOnto Args((List,List)); /* non-destructive */
-extern List revOnto Args((List,List)); /* destructive */
-#define reverse(xs) revDupOnto((xs),NIL) /* non-destructive */
-#define dupList(xs) dupListOnto((xs),NIL) /* non-destructive */
-#define rev(xs) revOnto((xs),NIL) /* destructive */
+extern List appendOnto Args((List,List)); /* destructive */
+extern List dupOnto Args((List,List));
+extern List dupList Args((List));
+extern List revOnto Args((List, List)); /* destructive */
+#define rev(xs) revOnto((xs),NIL) /* destructive */
extern Cell cellIsMember Args((Cell,List));
extern Cell cellAssoc Args((Cell,List));
extern Cell cellRevAssoc Args((Cell,List));
extern Bool eqList Args((List,List));
extern Cell varIsMember Args((Text,List));
+extern Name nameIsMember Args((Text,List));
extern Cell intIsMember Args((Int,List));
-extern List replicate Args((Int,Cell));
-extern List diffList Args((List,List)); /* destructive */
-extern List deleteCell Args((List,Cell)); /* non-destructive */
-extern List take Args((Int,List)); /* destructive */
-extern List splitAt Args((Int,List)); /* non-destructive */
+extern List replicate Args((Int,Cell));
+extern List diffList Args((List,List)); /* destructive */
+extern List deleteCell Args((List,Cell)); /* non-destructive */
+extern List take Args((Int,List)); /* destructive */
+extern List splitAt Args((Int,List)); /* non-destructive */
extern Cell nth Args((Int,List));
-extern List removeCell Args((Cell,List)); /* destructive */
+extern List removeCell Args((Cell,List)); /* destructive */
/* The following macros provide `inline expansion' of some common ways of
* traversing, using and modifying lists:
* with identifiers used elsewhere.
*/
-#define mapBasic(_init,_step) {List Zs=(_init);\
- for(;nonNull(Zs);Zs=tl(Zs)) \
- _step;}
-#define mapModify(_init,_step) mapBasic(_init,hd(Zs)=_step)
+#define mapBasic(_init,_step) {List Zs=(_init);\
+ for(;nonNull(Zs);Zs=tl(Zs)) \
+ _step;}
+#define mapModify(_init,_step) mapBasic(_init,hd(Zs)=_step)
-#define mapProc(_f,_xs) mapBasic(_xs,_f(hd(Zs)))
-#define map1Proc(_f,_a,_xs) mapBasic(_xs,_f(_a,hd(Zs)))
-#define map2Proc(_f,_a,_b,_xs) mapBasic(_xs,_f(_a,_b,hd(Zs)))
-#define map3Proc(_f,_a,_b,_c,_xs) mapBasic(_xs,_f(_a,_b,_c,hd(Zs)))
+#define mapProc(_f,_xs) mapBasic(_xs,_f(hd(Zs)))
+#define map1Proc(_f,_a,_xs) mapBasic(_xs,_f(_a,hd(Zs)))
+#define map2Proc(_f,_a,_b,_xs) mapBasic(_xs,_f(_a,_b,hd(Zs)))
+#define map3Proc(_f,_a,_b,_c,_xs) mapBasic(_xs,_f(_a,_b,_c,hd(Zs)))
+#define map4Proc(_f,_a,_b,_c,_d,_xs) mapBasic(_xs,_f(_a,_b,_c,_d,hd(Zs)))
-#define mapOver(_f,_xs) mapModify(_xs,_f(hd(Zs)))
-#define map1Over(_f,_a,_xs) mapModify(_xs,_f(_a,hd(Zs)))
-#define map2Over(_f,_a,_b,_xs) mapModify(_xs,_f(_a,_b,hd(Zs)))
-#define map3Over(_f,_a,_b,_c,_xs) mapModify(_xs,_f(_a,_b,_c,hd(Zs)))
+#define mapOver(_f,_xs) mapModify(_xs,_f(hd(Zs)))
+#define map1Over(_f,_a,_xs) mapModify(_xs,_f(_a,hd(Zs)))
+#define map2Over(_f,_a,_b,_xs) mapModify(_xs,_f(_a,_b,hd(Zs)))
+#define map3Over(_f,_a,_b,_c,_xs) mapModify(_xs,_f(_a,_b,_c,hd(Zs)))
+#define map4Over(_f,_a,_b,_c,_d,_xs) mapModify(_xs,_f(_a,_b,_c,_d,hd(Zs)))
/* This is just what you want for functions with accumulating parameters */
#define mapAccum(_f,_acc,_xs) mapBasic(_xs,_acc=_f(_acc,hd(Zs)))
* ------------------------------------------------------------------------*/
#define ap(f,x) pair(f,x)
-#define ap1(f,x) ap(f,x)
-#define ap2(f,x,y) ap(ap(f,x),y)
+#define ap1(f,x) ap(f,x)
+#define ap2(f,x,y) ap(ap(f,x),y)
#define ap3(f,x,y,z) ap(ap(ap(f,x),y),z)
#define fun(c) fst(c)
#define arg(c) snd(c)
#define drop() sp--
#define top() stack(sp)
#define pushed(n) stack(sp-(n))
+#define topfun(f) top()=ap((f),top())
+#define toparg(x) top()=ap(top(),(x))
extern Void hugsStackOverflow Args((Void));
* ------------------------------------------------------------------------*/
extern Script startNewScript Args((String));
+extern Bool moduleThisScript Args((Module));
+extern Module moduleOfScript Args((Script));
+extern Bool isPreludeScript Args((Void));
extern Module lastModule Args((Void));
+extern Script scriptThisFile Args((Text));
extern Script scriptThisName Args((Name));
extern Script scriptThisTycon Args((Tycon));
extern Script scriptThisInst Args((Inst));
extern Void dropScriptsFrom Args((Script));
/* --------------------------------------------------------------------------
+ * I/O Handles:
+ * ------------------------------------------------------------------------*/
+
+#if IO_HANDLES
+#define HSTDIN 0 /* Numbers for standard handles */
+#define HSTDOUT 1
+#define HSTDERR 2
+
+struct strHandle { /* Handle description and status flags */
+ Cell hcell; /* Heap representation of handle (or NIL) */
+ FILE *hfp; /* Corresponding file pointer */
+ Int hmode; /* Current mode: see below */
+};
+
+#define HCLOSED 0000 /* no I/O permitted */
+#define HSEMICLOSED 0001 /* semiclosed reads only */
+#define HREAD 0002 /* set to enable reads from handle */
+#define HWRITE 0004 /* set to enable writes to handle */
+#define HAPPEND 0010 /* opened in append mode */
+
+extern Cell openHandle Args((String,Int,Bool));
+extern struct strHandle DECTABLE(handles);
+#endif
+
+/* --------------------------------------------------------------------------
+ * Malloc Pointers
+ * ------------------------------------------------------------------------*/
+
+#if GC_MALLOCPTRS
+struct strMallocPtr { /* Malloc Ptr description */
+ Cell mpcell; /* Back pointer to MPCELL */
+ Void *ptr; /* Pointer into C world */
+ Int refCount; /* Reference count */
+ Void (*cleanup) Args((Void *)); /* Code to free the C pointer */
+};
+
+extern struct strMallocPtr mallocPtrs[];
+extern Cell mkMallocPtr Args((Void *, Void (*)(Void *)));
+extern Void freeMallocPtr Args((Cell));
+extern Void incMallocPtrRefCnt Args((Int, Int));
+
+#define mpOf(c) snd(c)
+#define derefMP(c) (mallocPtrs[(Int)mpOf(c)].ptr)
+#endif /* GC_MALLOCPTRS */
+
+/* --------------------------------------------------------------------------
+ * Weak Pointers
+ * ------------------------------------------------------------------------*/
+
+#if GC_WEAKPTRS
+#define mkWeakPtr(c) pair(WEAKCELL,pair(c,NIL))
+#define derefWeakPtr(c) fst(snd(c))
+#define nextWeakPtr(c) snd(snd(c))
+
+extern List finalizers;
+extern List liveWeakPtrs;
+
+#endif /* GC_WEAKPTRS */
+
+/* --------------------------------------------------------------------------
+ * Stable pointers
+ * ------------------------------------------------------------------------*/
+
+#if GC_STABLEPTRS
+extern Int mkStablePtr Args((Cell));
+extern Cell derefStablePtr Args((Int));
+extern Void freeStablePtr Args((Int));
+#endif /* GC_STABLEPTRS */
+
+/* --------------------------------------------------------------------------
+ * Plugins
+ * ------------------------------------------------------------------------*/
+
+#if PLUGINS
+/* This is an exact copy of the declaration found in GreenCard.h */
+
+typedef int HugsStackPtr;
+typedef int HugsStablePtr;
+typedef Pointer HugsForeign;
+
+typedef struct {
+
+ /* evaluate next argument */
+ int (*getInt ) Args(());
+ unsigned int (*getWord ) Args(());
+ void* (*getAddr ) Args(());
+ float (*getFloat ) Args(());
+ double (*getDouble) Args(());
+ char (*getChar ) Args(());
+ HugsForeign (*getForeign) Args(());
+ HugsStablePtr (*getStablePtr) Args(());
+
+ /* push part of result */
+ void (*putInt ) Args((int));
+ void (*putWord ) Args((unsigned int));
+ void (*putAddr ) Args((void*));
+ void (*putFloat ) Args((double));
+ void (*putDouble) Args((double));
+ void (*putChar ) Args((char));
+ void (*putForeign) Args((HugsForeign, void (*)(HugsForeign)));
+ void (*putStablePtr) Args((HugsStablePtr));
+
+ /* return n values in IO monad or Id monad */
+ void (*returnIO) Args((HugsStackPtr, int));
+ void (*returnId) Args((HugsStackPtr, int));
+ int (*runIO) Args((int));
+
+ /* free a stable pointer */
+ void (*freeStablePtr) Args((HugsStablePtr));
+
+ /* register the prim table */
+ void (*registerPrims) Args((struct primInfo*));
+
+ /* garbage collect */
+ void (*garbageCollect) Args(());
+
+} HugsAPI2;
+
+extern HugsAPI2* hugsAPI2 Args((Void));
+typedef Void (*InitModuleFun2) Args((HugsAPI2*));
+
+typedef struct {
+ Name nameTrue, nameFalse;
+ Name nameNil, nameCons;
+ Name nameJust, nameNothing;
+ Name nameLeft, nameRight;
+ Name nameUnit;
+ Name nameIORun;
+
+ Cell (*makeInt) Args((Int));
+
+ Cell (*makeChar) Args((Char));
+ Char (*CharOf) Args((Cell));
+
+ Cell (*makeFloat) Args((FloatPro));
+ Cell (*makeTuple) Args((Int));
+ Pair (*pair) Args((Cell,Cell));
+
+ Cell (*mkMallocPtr) Args((Void *, Void (*)(Void *)));
+ Void *(*derefMallocPtr) Args((Cell));
+
+ Int (*mkStablePtr) Args((Cell));
+ Cell (*derefStablePtr) Args((Int));
+ Void (*freeStablePtr) Args((Int));
+
+ Void (*eval) Args((Cell));
+ Cell (*evalWithNoError) Args((Cell));
+ Void (*evalFails) Args((StackPtr));
+ Int *whnfArgs;
+ Cell *whnfHead;
+ Int *whnfInt;
+ Float *whnfFloat;
+
+ Void (*garbageCollect) Args(());
+ Void (*stackOverflow) Args(());
+ Void (*internal) Args((String)) HUGS_noreturn;
+
+ Void (*registerPrims) Args((struct primInfo*));
+ Name (*addPrimCfun) Args((Text,Int,Int,Cell));
+ Text (*inventText) Args(());
+
+ Cell *(*Fst) Args((Cell));
+ Cell *(*Snd) Args((Cell));
+
+ Cell *cellStack;
+ StackPtr *sp;
+} HugsAPI1;
+
+extern HugsAPI1* hugsAPI1 Args((Void));
+typedef Void (*InitModuleFun1) Args((HugsAPI1*));
+#endif /* PLUGINS */
+
+
+/* --------------------------------------------------------------------------
* Misc:
* ------------------------------------------------------------------------*/
-extern Void setLastExpr Args((Cell));
-extern Cell getLastExpr Args((Void));
+extern Void setLastExpr Args((Cell));
+extern Cell getLastExpr Args((Void));
extern List addTyconsMatching Args((String,List));
-extern List addNamesMatching Args((String,List));
+extern List addNamesMatching Args((String,List));
/*-------------------------------------------------------------------------*/
-/* -*- mode: hugs-c; -*- */
+
/* --------------------------------------------------------------------------
- * subst.c: Copyright (c) Mark P Jones 1991-1998. All rights reserved.
- * See NOTICE for details and conditions of use etc...
- * Hugs version 1.3c, March 1998
- *
* Provides an implementation for the `current substitution' used during
* type and kind inference in both static analysis and type checking.
+ *
+ * Hugs 98 is Copyright (c) Mark P Jones, Alastair Reid and the Yale
+ * Haskell Group 1994-99, and is distributed as Open Source software
+ * under the Artistic License; see the file "Artistic" that is included
+ * in the distribution for details.
+ *
+ * $RCSfile: subst.c,v $
+ * $Revision: 1.3 $
+ * $Date: 1999/02/03 17:08:42 $
* ------------------------------------------------------------------------*/
#include "prelude.h"
#if TREX
static Bool local inserter Args((Type,Int,Type,Int));
static Int local remover Args((Text,Type,Int));
+static Int local tailVar Args((Type,Int));
#endif
static Bool local kvarToVarBind Args((Tyvar *,Tyvar *));
static Bool local kvarToTypeBind Args((Tyvar *,Type,Int));
tyvars[numTyvars-n].bound = NIL;
tyvars[numTyvars-n].kind = STAR;
#ifdef DEBUG_TYPES
- printf("new type variable: _%d ::: ",numTyvars-n);
+ Printf("new type variable: _%d ::: ",numTyvars-n);
printKind(stdout,tyvars[numTyvars-n].kind);
- putchar('\n');
+ Putchar('\n');
#endif
}
return beta;
tyvars[numTyvars].bound = NIL;
tyvars[numTyvars].kind = fst(k);
#ifdef DEBUG_TYPES
- printf("new type variable: _%d ::: ",numTyvars);
+ Printf("new type variable: _%d ::: ",numTyvars);
printKind(stdout,tyvars[numTyvars].kind);
- putchar('\n');
+ Putchar('\n');
#endif
numTyvars++;
}
tyv->bound = t;
tyv->offs = o;
#ifdef DEBUG_TYPES
- printf("binding type variable: _%d to ",vn);
+ Printf("binding type variable: _%d to ",vn);
printType(stdout,debugType(t,o));
- putchar('\n');
+ Putchar('\n');
#endif
}
* Marking fixed variables in type expressions:
* ------------------------------------------------------------------------*/
-Void clearMarks() { /* set all unbound type vars to */
+Void clearMarks() { /* Set all unbound type vars to */
Int i; /* unused generic variables */
for (i=0; i<numTyvars; ++i)
if (!isBound(tyvar(i)))
nextGeneric = 0;
}
+Void markAllVars() { /* Set all unbound type vars to */
+ Int i; /* be fixed vars */
+ for (i=0; i<numTyvars; ++i)
+ if (!isBound(tyvar(i)))
+ tyvar(i)->offs = FIXED_TYVAR;
+ genericVars = NIL;
+ nextGeneric = 0;
+}
+
Void resetGenerics() { /* Reset all generic vars to unused*/
Int i;
for (i=0; i<numTyvars; ++i)
Type t;
Int o; {
switch (whatIs(t)) {
+ case POLYTYPE :
+ case QUAL :
#if TREX
- case EXT :st
+ case EXT :
#endif
case TYCON :
case TUPLE : return;
case RANK2 : markType(snd(snd(t)),o);
return;
- case POLYTYPE : /* No need to mark generic types */
- return;
default : internal("markType");
}
Int vn; { /* type bound to given type var */
Tyvar *tyv = tyvar(vn);
- if (isBound(tyv))
+ if ((tyv->bound)==SKOLEM) {
+ return mkInt(vn);
+ } else if (tyv->bound) {
return copyType(tyv->bound,tyv->offs);
+ }
switch (tyv->offs) {
case FIXED_TYVAR : return mkInt(vn);
Type a = arg(fun(t));
if (isPolyType(a))
a = dropRank1(a,alpha,n);
- as = ap2(typeArrow,a,as);
+ as = fn(a,as);
t = arg(t);
}
t = ap(RANK2,pair(r,revOnto(as,t)));
for (i=intOf(r); i>0; i--) {
Type a = arg(fun(t));
a = isPolyType(a) ? liftRank1Body(a,m) : copyType(a,alpha);
- as = ap2(typeArrow,a,as);
+ as = fn(a,as);
t = arg(t);
}
t = ap(RANK2,pair(r,revOnto(as,copyType(t,alpha))));
#endif
}
#ifdef DEBUG_KINDS
- printf("getKind c = %d, whatIs=%d\n",c,whatIs(c));
+ Printf("getKind c = %d, whatIs=%d\n",c,whatIs(c));
#endif
internal("getKind");
return STAR;/* not reached */
tyv1->bound = aVar;
tyv1->offs = tyvNum(tyv2);
#ifdef DEBUG_TYPES
- printf("vv binding tyvar: _%d to _%d\n",tyvNum(tyv1),tyvNum(tyv2));
+ Printf("vv binding tyvar: _%d to _%d\n",tyvNum(tyv1),tyvNum(tyv2));
#endif
}
return TRUE;
tyv->bound = t;
tyv->offs = o;
#ifdef DEBUG_TYPES
- printf("vt binding type variable: _%d to ",tyvNum(tyv));
+ Printf("vt binding type variable: _%d to ",tyvNum(tyv));
printType(stdout,debugType(t,o));
- putchar('\n');
+ Putchar('\n');
#endif
return TRUE;
}
Int a2 = argCount;
#ifdef DEBUG_TYPES
- printf("tt unifying types: ");
+ Printf("tt unifying types: ");
printType(stdout,debugType(t1,o1));
- printf(" with ");
+ Printf(" with ");
printType(stdout,debugType(t2,o2));
- putchar('\n');
+ Putchar('\n');
#endif
-
if (isOffset(h1) || isInt(h1)) h1=NIL; /* represent var by NIL*/
if (isOffset(h2) || isInt(h2)) h2=NIL;
#if TREX
if (isExt(h1) || isExt(h2)) {
- if (a1==2 && isExt(h1) && a2==2 && isExt(h2))
- return inserter(fun(t1),o1,t2,o2) &&
- unify(arg(t1),o1,aVar,
- remover(extText(h1),t2,o2));
- else {
+ if (a1==2 && isExt(h1) && a2==2 && isExt(h2)) {
+ if (extText(h1)==extText(h2)) {
+ return unify(arg(fun(t1)),o1,arg(fun(t2)),o2) &&
+ unify(arg(t1),o1,arg(t2),o2);
+ } else {
+ return inserter(t1,o1,t2,o2) &&
+ unify(arg(t1),o1,aVar,
+ remover(extText(h1),t2,o2));
+ }
+ } else {
unifyFails = "rows are not compatible";
return FALSE;
}
}
#if TREX
-static Bool local inserter(ins,o,r,or) /* Insert field into row (r,or) */
-Type ins; /* inserter (ins,o), where ins is */
-Int o; /* an applic of an EXT to a type. */
+static Bool local inserter(r1,o1,r,o) /* Insert first field in (r1,o1) */
+Type r1; /* into row (r,o), both of which */
+Int o1; /* are known to begin with an EXT */
Type r;
-Int or; {
- Text labt = extText(fun(ins)); /* Find the text of the label */
+Int o; {
+ Text labt = extText(fun(fun(r1))); /* Find the text of the label */
+#ifdef DEBUG_TYPES
+ Printf("inserting ");
+ printType(stdout,debugType(r1,o1));
+ Printf(" into ");
+ printType(stdout,debugType(r,o));
+ Putchar('\n');
+#endif
for (;;) {
Tyvar *tyv;
- deRef(tyv,r,or);
+ deRef(tyv,r,o);
if (tyv) {
- Int beta = newTyvars(1); /* Extend row with new field */
+ Int beta; /* Test for common tail */
+ if (tailVar(arg(r1),o1)==tyvNum(tyv)) {
+ unifyFails = "distinct rows have common tail";
+ return FALSE;
+ }
+ beta = newTyvars(1); /* Extend row with new field */
tyvar(beta)->kind = ROW;
- return varToTypeBind(tyv,ap(ins,mkInt(beta)),o);
+ return varToTypeBind(tyv,ap(fun(r1),mkInt(beta)),o1);
}
else if (isAp(r) && isAp(fun(r)) && isExt(fun(fun(r)))) {
if (labt==extText(fun(fun(r))))/* Compare existing fields */
- return unify(arg(ins),o,extField(r),or);
+ return unify(arg(fun(r1)),o1,extField(r),o);
r = extRow(r); /* Or skip to next field */
}
else { /* Nothing else will match */
Tyvar *tyv;
Int beta = newTyvars(1);
tyvar(beta)->kind = ROW;
+#ifdef DEBUG_TYPES
+ Printf("removing %s from",textToStr(l));
+ printType(stdout,debugType(r,o));
+ Putchar('\n');
+#endif
deRef(tyv,r,o);
if (tyv || !isAp(r) || !isAp(fun(r)) || !isExt(fun(fun(r))))
internal("remover");
bindTv(beta,r,o);
return beta;
}
+
+
+static Int local tailVar(r,o) /* Find var at tail end of a row */
+Type r;
+Int o; {
+ for (;;) {
+ Tyvar *tyv;
+ deRef(tyv,r,o);
+ if (tyv) {
+ return tyvNum(tyv);
+ }
+ else if (isAp(r) && isAp(fun(r)) && isExt(fun(fun(r)))) {
+ r = extRow(r);
+ }
+ else {
+ return (-1);
+ }
+ }
+}
#endif
+
Bool typeMatches(type,mt) /* test if type matches monotype mt*/
-Type type, mt; {
+ Type type, mt; { /* imported from STG Hugs */
Bool result;
if (isPolyType(type) || whatIs(type)==QUAL)
return FALSE;
return result;
}
+
+#if IO_MONAD
+Bool isProgType(ks,type) /* Test if type is of the form */
+List ks; /* IO t for some t. */
+Type type; {
+ Bool result;
+ Int alpha;
+ Int beta;
+ if (isPolyType(type) || whatIs(type)==QUAL)
+ return FALSE;
+ emptySubstitution();
+ alpha = newKindedVars(ks);
+ beta = newTyvars(1);
+ bindOnlyAbove(beta);
+ result = unify(type,alpha,typeProgIO,beta);
+ unrestrictBind();
+ emptySubstitution();
+ return result;
+}
+#endif
+
/* --------------------------------------------------------------------------
* Matching predicates:
*
return pi1==pi;
}
+#if TREX
+static Cell trexShow = NIL; /* Used to test for show on records*/
+static Cell trexEq = NIL; /* Used to test for eq on records */
+#endif
+
Inst findInstFor(pi,o) /* Find matching instance for pred */
Cell pi; /* (pi,o), or otherwise NIL. If a */
Int o; { /* match is found, then tyvars from*/
unrestrictBind();
#if TREX
- { Int showRow = strcmp(textToStr(cclass(c).text),"ShowRecRow");
- Int eqRow = strcmp(textToStr(cclass(c).text),"EqRecRow");
+ { Bool wantShow = (c==findQualClass(trexShow));
+ Bool wantEither = wantShow || (c==findQualClass(trexEq));
- if (showRow==0 || eqRow==0) { /* Generate instances of */
+ if (wantEither) { /* Generate instances of */
Type t = arg(pi); /* ShowRecRow and EqRecRow */
Tyvar *tyv; /* on the fly */
Cell e;
break;
}
if (isNull(in))
- in = (showRow==0) ? addRecShowInst(c,e)
- : addRecEqInst(c,e);
+ in = (wantShow ? addRecShowInst(c,e) : addRecEqInst(c,e));
typeOff = newKindedVars(extKind);
bindTv(typeOff,arg(fun(t)),o);
bindTv(typeOff+1,arg(t),o);
tyv1->bound = aVar;
tyv1->offs = tyvNum(tyv2);
#ifdef DEBUG_KINDS
- printf("vv binding kvar: _%d to _%d\n",tyvNum(tyv1),tyvNum(tyv2));
+ Printf("vv binding kvar: _%d to _%d\n",tyvNum(tyv1),tyvNum(tyv2));
#endif
}
return TRUE;
tyv->bound = t;
tyv->offs = o;
#ifdef DEBUG_KINDS
- printf("vt binding kind variable: _%d to ",tyvNum(tyv));
+ Printf("vt binding kind variable: _%d to ",tyvNum(tyv));
printType(stdout,debugType(t,o));
- putchar('\n');
+ Putchar('\n');
#endif
return TRUE;
}
return kvarToTypeBind(kyv2,k1,o1); /* k2 variable, k1 not */
else {
#ifdef DEBUG_KINDS
- printf("unifying kinds: ");
+ Printf("unifying kinds: ");
printType(stdout,debugType(k1,o1));
- printf(" with ");
+ Printf(" with ");
printType(stdout,debugType(k2,o2));
- putchar('\n');
+ Putchar('\n');
#endif
if (k1==STAR && k2==STAR) /* k1, k2 not vars */
return TRUE;
mark(typeIs);
mark(predsAre);
mark(genericVars);
+#if TREX
+ mark(trexShow);
+ mark(trexEq);
+#endif
break;
case INSTALL : substitution(RESET);
simpleKindCache[i] = NIL;
varKindCache[i] = NIL;
}
+#if TREX
+ trexShow = mkQCon(findText("Trex"),
+ findText("ShowRecRow"));
+ trexEq = mkQCon(findText("Trex"),
+ findText("EqRecRow"));
+#endif
break;
}
}
-/* -*- mode: hugs-c; -*- */
+
/* --------------------------------------------------------------------------
- * subst.h: Copyright (c) Mark P Jones 1991-1998. All rights reserved.
- * See NOTICE for details and conditions of use etc...
- * Hugs version 1.3c, March 1998
- *
* Definitions for substitution data structure and operations.
+ *
+ * Hugs 98 is Copyright (c) Mark P Jones, Alastair Reid and the Yale
+ * Haskell Group 1994-99, and is distributed as Open Source software
+ * under the Artistic License; see the file "Artistic" that is included
+ * in the distribution for details.
+ *
+ * $RCSfile: subst.h,v $
+ * $Revision: 1.3 $
+ * $Date: 1999/02/03 17:08:43 $
* ------------------------------------------------------------------------*/
typedef struct { /* Each type variable contains: */
#define tyvar(n) (tyvars+(n)) /* nth type variable */
#define tyvNum(t) ((t)-tyvars) /* and the corresp. inverse funct. */
#define isBound(t) (((t)->bound) && ((t)->bound!=SKOLEM))
-#define aVar mkOffset(0) /* Simple skeleton for type var */
-#define bVar mkOffset(1) /* Simple skeleton for type var */
+#define aVar mkOffset(0) /* Simple skeletons for type vars */
+#define bVar mkOffset(1)
#define enterBtyvs() btyvars = cons(NIL,btyvars)
#define leaveBtyvs() btyvars = tl(btyvars)
extern Void expandSyn Args((Tycon, Int, Type *, Int *));
extern Void clearMarks Args((Void));
+extern Void markAllVars Args((Void));
extern Void resetGenerics Args((Void));
extern Void markTyvar Args((Int));
extern Void markType Args((Type,Int));
extern Bool sameSchemes Args((Type,Type));
-extern Bool typeMatches Args((Type,Type));
-
/*-------------------------------------------------------------------------*/
-/* -*- mode: hugs-c; -*- */
+<<<<<<<<<<<<<< variant A
+
+>>>>>>>>>>>>>> variant B
+======= end of combination
/* --------------------------------------------------------------------------
* This file provides a simple mechanism for measuring elapsed time on Unix
* machines (more precisely, on any machine with an rusage() function).
* optimizations, means that there are much more significant overheads than
* can be accounted for by small variations in Hugs code.
*
- * 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
+ * Hugs 98 is Copyright (c) Mark P Jones, Alastair Reid and the Yale
+ * Haskell Group 1994-99, and is distributed as Open Source software
+ * under the Artistic License; see the file "Artistic" that is included
+ * in the distribution for details.
*
* $RCSfile: timer.c,v $
- * $Revision: 1.2 $
- * $Date: 1998/12/02 13:22:46 $
+ * $Revision: 1.3 $
+ * $Date: 1999/02/03 17:08:43 $
* ------------------------------------------------------------------------*/
* Hugs version 1.4, December 1997
*
* $RCSfile: translate.c,v $
- * $Revision: 1.3 $
- * $Date: 1999/01/13 16:47:26 $
+ * $Revision: 1.4 $
+ * $Date: 1999/02/03 17:08:44 $
* ------------------------------------------------------------------------*/
#include "prelude.h"
#include "storage.h"
+#include "backend.h"
#include "connect.h"
#include "errors.h"
-#include "stg.h"
-#include "compiler.h"
-#include "pmc.h" /* for discrArity */
-#include "hugs.h" /* for debugCode */
-#include "type.h" /* for conToTagType, tagToConType */
#include "link.h"
-#include "pp.h"
#include "dynamic.h"
#include "Assembler.h"
-#include "translate.h"
/* ---------------------------------------------------------------- */
}
case GUARDED:
{
- List guards = reverse(snd(e));
+ List guards = rev(snd(e));
e = failExpr;
for(; nonNull(guards); guards=tl(guards)) {
Cell g = hd(guards);
return e;
}
+#if 0
+ToDo: reinstate eventually
/* \ v -> case v of { ...; Ci _ _ -> i; ... } */
Void implementConToTag(t)
Tycon t; {
if (etxt) free(etxt);
}
}
+#endif
Void implementCfun(c,scs) /* Build implementation for constr */
Name c; /* fun c. scs lists integers (1..)*/
/* box results */
if (strcmp(r_reps,"B") == 0) {
- StgPrimAlt altF = mkStgPrimAlt(singleton(mkStgPrimVar(mkInt(0),mkStgRep(INT_REP),NIL)),
+ StgPrimAlt altF = mkStgPrimAlt(singleton(
+ mkStgPrimVar(mkInt(0),
+ mkStgRep(INT_REP),NIL)
+ ),
nameFalse);
StgPrimAlt altT = mkStgPrimAlt(singleton(mkStgPrimVar(NIL,mkStgRep(INT_REP),NIL)),
nameTrue);
b_args = mkBoxedVars(a_reps);
u_args = mkUnboxedVars(a_reps);
if (addState) {
- List actual_args = appendOnto(extra_args,dupListOnto(u_args,singleton(s0)));
+ List actual_args = appendOnto(extra_args,dupOnto(u_args,singleton(s0)));
StgRhs rhs = makeStgLambda(singleton(s0),
unboxVars(a_reps,b_args,u_args,
mkStgPrimCase(mkStgPrim(op,actual_args),
-/* -*- mode: hugs-c; -*- */
+
/* --------------------------------------------------------------------------
- * type.c: Copyright (c) Mark P Jones 1991-1998. All rights reserved.
- * See NOTICE for details and conditions of use etc...
- * Hugs version 1.3c, March 1998
- *
* This is the Hugs type checker
+ *
+ * Hugs 98 is Copyright (c) Mark P Jones, Alastair Reid and the Yale
+ * Haskell Group 1994-99, and is distributed as Open Source software
+ * under the Artistic License; see the file "Artistic" that is included
+ * in the distribution for details.
+ *
+ * $RCSfile: type.c,v $
+ * $Revision: 1.3 $
+ * $Date: 1999/02/03 17:08:44 $
* ------------------------------------------------------------------------*/
#include "prelude.h"
#include "storage.h"
+#include "backend.h"
#include "connect.h"
-#include "input.h"
-#include "static.h"
-#include "hugs.h" /* for target */
-#include "pat.h" /* for failFree */
#include "errors.h"
#include "subst.h"
-#include "type.h"
-#include "link.h"
#include "Assembler.h" /* for AsmCTypes */
/*#define DEBUG_TYPES*/
/*#define DEBUG_KINDS*/
/*#define DEBUG_DEFAULTS*/
/*#define DEBUG_SELS*/
-/*#define DEBUG_CODE*/
/*#define DEBUG_DEPENDS*/
/*#define DEBUG_DERIVING*/
+/*#define DEBUG_CODE*/
Bool catchAmbigs = FALSE; /* TRUE => functions with ambig. */
/* types produce error */
+#if 1
+//ToDo: perhaps this should be somewhere else (link.c?)
+//all this stuff came with 98, and not STG
+Type typeArrow, typeList; /* Important primitive types */
+Type typeUnit;
+
+Module modulePrelude;
+
+static Type typeInt, typeDouble;
+static Type typeInteger, typeAddr;
+static Type typeString, typeChar;
+static Type typeBool, typeMaybe;
+static Type typeOrdering;
+
+Class classEq, classOrd; /* `standard' classes */
+Class classIx, classEnum;
+Class classShow, classRead;
+#if EVAL_INSTANCES
+Class classEval;
+#endif
+Class classBounded;
+
+Class classReal, classIntegral; /* `numeric' classes */
+Class classRealFrac, classRealFloat;
+Class classFractional, classFloating;
+Class classNum;
+
+List stdDefaults; /* standard default values */
+
+Name nameFromInt, nameFromDouble; /* coercion of numerics */
+Name nameFromInteger;
+Name nameEq, nameCompare; /* derivable names */
+Name nameLe;
+Name nameShowsPrec;
+Name nameReadsPrec;
+Name nameMinBnd, nameMaxBnd;
+Name nameIndex, nameInRange;
+Name nameRange;
+Name nameMult, namePlus;
+Name nameTrue, nameFalse; /* primitive boolean constructors */
+Name nameNil, nameCons; /* primitive list constructors */
+Name nameJust, nameNothing; /* primitive Maybe constructors */
+Name nameLeft, nameRight; /* primitive Either constructors */
+Name nameUnit; /* primitive Unit type constructor */
+Name nameLT, nameEQ; /* Ordering constructors */
+Name nameGT;
+Class classMonad; /* Monads */
+Name nameReturn, nameBind; /* for translating monad comps */
+Name nameMFail;
+Name nameGt; /* for readsPrec */
+#if EVAL_INSTANCES
+Name nameStrict, nameSeq; /* Members of class Eval */
+#endif
+
+#if IO_MONAD
+Type typeProgIO; /* For the IO monad, IO () */
+Name nameUserErr; /* loosely coupled IOError cfuns */
+Name nameNameErr, nameSearchErr;
+#endif
+#if IO_HANDLES
+Name nameWriteErr, nameIllegal;
+Name nameEOFErr;
+#endif
+
+#if TREX
+Type typeNoRow; /* Empty row */
+Type typeRec; /* Record formation */
+Name nameNoRec; /* Empty record */
+#endif
+
+//end ToDo
+#endif
+
/* --------------------------------------------------------------------------
* Local function prototypes:
* ------------------------------------------------------------------------*/
static Void local leavePendingBtyvs Args((Void));
static Cell local patBtyvs Args((Cell));
static Void local doneBtyvs Args((Int));
+static Void local enterSkolVars Args((Void));
+static Void local leaveSkolVars Args((Int,Type,Int,Int));
static Void local typeError Args((Int,Cell,Cell,String,Type,Int));
static Void local reportTypeError Args((Int,Cell,Cell,String,Type,Type));
static Int local funcType Args((Int));
static Void local typeCase Args((Int,Int,Cell));
static Void local typeComp Args((Int,Type,Cell,List));
+static Cell local typeMonadComp Args((Int,Cell));
static Void local typeDo Args((Int,Cell));
-static Cell local compZero Args((List,Int));
static Void local typeConFlds Args((Int,Cell));
static Void local typeUpdFlds Args((Int,Cell));
static Cell local typeFreshPat Args((Int,Cell));
static Void local typeDefnGroup Args((List));
static Pair local typeSel Args((Name));
+static List offsetTyvarsIn Args((Type,List));
+static Type conToTagType Args((Tycon));
+static Type tagToConType Args((Tycon));
+
+
/* --------------------------------------------------------------------------
* Frequently used type skeletons:
* ------------------------------------------------------------------------*/
-static Type arrow; /* mkOffset(0) -> mkOffset(1) */
+/* ToDo: move these to link.c and call them 'typeXXXX' */
+ Type arrow; /* mkOffset(0) -> mkOffset(1) */
static Type boundPair; /* (mkOffset(0),mkOffset(0)) */
-static Type listof; /* [ mkOffset(0) ] */
+ Type listof; /* [ mkOffset(0) ] */
static Type typeVarToVar; /* mkOffset(0) -> mkOffset(0) */
-static Cell predNum; /* Num (mkOffset(0)) */
-static Cell predFractional; /* Fractional (mkOffset(0)) */
-static Cell predIntegral; /* Integral (mkOffset(0)) */
+ Cell predNum; /* Num (mkOffset(0)) */
+ Cell predFractional; /* Fractional (mkOffset(0)) */
+ Cell predIntegral; /* Integral (mkOffset(0)) */
static Kind starToStar; /* Type -> Type */
-static Cell predMonad; /* Monad (mkOffset(0)) */
-static Cell predMonad0; /* Monad0 (mkOffset(0)) */
+ Cell predMonad; /* Monad (mkOffset(0)) */
/* --------------------------------------------------------------------------
* Assumptions:
static List varsBounds; /*::[[(Var,Type)]] not overloaded */
static List depends; /*::[?[Var]] dependents/NODEPENDS */
static List skolVars; /*::[[Var]] skolem vars */
+static List localEvs; /*::[[(Pred,offset,ev)]] */
+static List savedPs; /*::[[(Pred,offset,ev)]] */
static Cell dummyVar; /* Used to put extra tvars into ass*/
#define saveVarsAss() List saveAssump = hd(varsBounds)
varsBounds = NIL;
depends = NIL;
skolVars = NIL;
+ localEvs = NIL;
+ savedPs = NIL;
}
static Void local enterBindings() { /* Add new level to assumption sets */
Int beta = newTyvars(1);
addVarAssump(v,mkInt(beta));
#ifdef DEBUG_TYPES
- printf("variable, assume ");
+ Printf("variable, assume ");
printExp(stdout,v);
- printf(" :: _%d\n",beta);
+ Printf(" :: _%d\n",beta);
#endif
return beta;
}
ta = pair(POLYREC,pair(ta,type));
hd(defnBounds) = cons(pair(v,ta), hd(defnBounds));
#ifdef DEBUG_TYPES
- printf("definition, assume ");
+ Printf("definition, assume ");
printExp(stdout,v);
- printf(" :: _%d\n",beta);
+ Printf(" :: _%d\n",beta);
#endif
bindTv(beta,typeIs,typeOff); /* Bind beta to new type skeleton */
}
/* --------------------------------------------------------------------------
+ * Predicates:
+ * ------------------------------------------------------------------------*/
+
+#include "preds.c"
+
+/* --------------------------------------------------------------------------
* Bound and skolemized type variables:
* ------------------------------------------------------------------------*/
snd(hd(bts)) = mkInt(beta);
}
}
- skolVars = cons(NIL,skolVars);
return p;
}
hd(pendingBtyvs) = cons(pair(mkInt(l),hd(btyvars)),hd(pendingBtyvs));
hd(btyvars) = NIL;
}
+}
+
+static Void local enterSkolVars() {
+ skolVars = cons(NIL,skolVars);
+ localEvs = cons(NIL,localEvs);
+ savedPs = cons(preds,savedPs);
+ preds = NIL;
+}
+
+static Void local leaveSkolVars(l,t,o,m)
+Int l;
+Type t;
+Int o;
+Int m; {
+ if (nonNull(hd(localEvs))) { /* Check for local predicates */
+ List sks = hd(skolVars);
+ List sps = NIL;
+ if (isNull(sks)) {
+ internal("leaveSkolVars");
+ }
+ markAllVars(); /* Mark all variables in current */
+ do { /* substitution, then unmark sks. */
+ tyvar(intOf(fst(hd(sks))))->offs = UNUSED_GENERIC;
+ sks = tl(sks);
+ } while (nonNull(sks));
+ sps = elimPredsUsing(hd(localEvs),sps);
+ preds = revOnto(preds,sps);
+ }
if (nonNull(hd(skolVars))) { /* Check that Skolem vars do not */
List vs; /* escape their scope */
+ Int i = 0;
clearMarks(); /* Look for occurences in the */
- markType(typeIs,typeOff); /* result type */
+ for (; i<m; i++) /* inferred type */
+ markTyvar(o+i);
+ markType(t,o);
for (vs=hd(skolVars); nonNull(vs); vs=tl(vs)) {
Int vn = intOf(fst(hd(vs)));
if (tyvar(vn)->offs == FIXED_TYVAR) {
Cell tv = copyTyvar(vn);
- Type t = copyType(typeIs,typeOff);
- ERRMSG(l) "Existentially quantified variable in result type"
+ Type ty = liftRank2(t,o,m);
+ ERRMSG(l) "Existentially quantified variable in inferred type"
ETHEN
- ERRTEXT "\nvariable : " ETHEN ERRTYPE(tv);
- ERRTEXT "\nfrom pattern : " ETHEN ERREXPR(snd(hd(vs)));
- ERRTEXT "\nresult type : " ETHEN ERRTYPE(t);
+ ERRTEXT "\n*** Variable : " ETHEN ERRTYPE(tv);
+ ERRTEXT "\n*** From pattern : " ETHEN ERREXPR(snd(hd(vs)));
+ ERRTEXT "\n*** Result type : " ETHEN ERRTYPE(ty);
ERRTEXT "\n"
EEND;
}
for (vs=hd(skolVars); nonNull(vs); vs=tl(vs)) {
Int vn = intOf(fst(hd(vs)));
if (tyvar(vn)->offs == FIXED_TYVAR) {
- ERRMSG(l) "Existentially quantified variable from pattern "
+ ERRMSG(l)
+ "Existentially quantified variable escapes from pattern "
ETHEN ERREXPR(snd(hd(vs)));
- ERRTEXT " appears in enclosing assumptions" /*so there!*/
+ ERRTEXT "\n"
EEND;
}
}
}
+ localEvs = tl(localEvs);
skolVars = tl(skolVars);
+ preds = revOnto(preds,hd(savedPs));
+ savedPs = tl(savedPs);
}
/* --------------------------------------------------------------------------
- * Predicates:
- * ------------------------------------------------------------------------*/
-
-#include "preds.c"
-
-/* --------------------------------------------------------------------------
* Type errors:
* ------------------------------------------------------------------------*/
{ List vs = genericVars;
for (; nonNull(vs); vs=tl(vs)) {
Int v = intOf(hd(vs));
- printf("%c :: ", ('a'+tyvar(v)->offs));
+ Printf("%c :: ", ('a'+tyvar(v)->offs));
printKind(stdout,tyvar(v)->kind);
- putchar('\n');
+ Putchar('\n');
}
}
#endif
static int number = 0;
Cell retv;
int mynumber = number++;
- printf("%d) to check: ",mynumber);
+ Printf("%d) to check: ",mynumber);
printExp(stdout,e);
- putchar('\n');
+ Putchar('\n');
retv = mytypeExpr(l,e);
- printf("%d) result: ",mynumber);
+ Printf("%d) result: ",mynumber);
printType(stdout,debugType(typeIs,typeOff));
- putchar('\n');
+ Putchar('\n');
return retv;
}
static Cell local mytypeExpr(l,e) /* Determine type of expr/pattern */
case TUPLE : typeTuple(e);
break;
-#if OVERLOADED_CONSTANTS
- case BIGCELL : { Int alpha = newTyvars(1);
+#if BIGNUMS
+ case POSNUM :
+ case ZERONUM :
+ case NEGNUM : { Int alpha = newTyvars(1);
inferType(aVar,alpha);
- return ap2(nameFromInteger,
- assumeEvid(predNum,alpha),
- e);
+ return ap(ap(nameFromInteger,
+ assumeEvid(predNum,alpha)),
+ e);
}
-
+#endif
case INTCELL : { Int alpha = newTyvars(1);
inferType(aVar,alpha);
- return ap2(nameFromInt,
- assumeEvid(predNum,alpha),
- e);
+ return ap(ap(nameFromInt,
+ assumeEvid(predNum,alpha)),
+ e);
}
case FLOATCELL : { Int alpha = newTyvars(1);
inferType(aVar,alpha);
- return ap2(nameFromDouble,
- assumeEvid(predFractional,alpha),
- e);
+ return ap(ap(nameFromDouble,
+ assumeEvid(predFractional,alpha)),
+ e);
}
-#else
- case BIGCELL : inferType(typeBignum,0);
- break;
- case INTCELL : inferType(typeInt,0);
- break;
- case FLOATCELL : inferType(typeFloat,0);
- break;
-#endif
case STRCELL : inferType(typeString,0);
break;
#if TREX
case EXT : { Int beta = newTyvars(2);
Cell pi = ap(e,aVar);
- Type t = fn(mkOffset(0),
- fn(ap(typeRec,mkOffset(1)),
- ap(typeRec,ap2(e,mkOffset(0),
- mkOffset(1)))));
+ Type t = fn(aVar,
+ fn(ap(typeRec,bVar),
+ ap(typeRec,ap(ap(e,aVar),bVar))));
tyvar(beta+1)->kind = ROW;
inferType(t,beta);
return ap(e,assumeEvid(pi,beta+1));
break;
case LETREC : enterBindings();
+ enterSkolVars();
mapProc(typeBindings,fst(snd(e)));
snd(snd(e)) = typeExpr(l,snd(snd(e)));
leaveBindings();
+ leaveSkolVars(l,typeIs,typeOff,0);
break;
case FINLIST : { Int beta = newTyvars(1);
case DOCOMP : typeDo(l,e);
break;
- case COMP : { Int beta = newTyvars(1);
- typeComp(l,listof,snd(e),snd(snd(e)));
- bindTv(beta,typeIs,typeOff);
- inferType(listof,beta);
- }
- break;
+ case COMP : return typeMonadComp(l,e);
case CASE : { Int beta = newTyvars(2); /* discr result */
check(l,fst(snd(e)),NIL,discr,aVar,beta);
case RECSEL : { Int beta = newTyvars(2);
Cell pi = ap(snd(e),aVar);
Type t = fn(ap(typeRec,
- ap2(snd(e),mkOffset(0),
- mkOffset(1))),aVar);
+ ap(ap(snd(e),aVar),
+ bVar)),aVar);
tyvar(beta+1)->kind = ROW;
inferType(t,beta);
return ap(e,assumeEvid(pi,beta+1));
instantiate(typeIs); /* Deal with polymorphism ... */
if (nonNull(predsAre)) { /* ... and with qualified types. */
- Cell evs = NIL;
- for (; nonNull(predsAre); predsAre=tl(predsAre))
+ List evs = NIL;
+ for (; nonNull(predsAre); predsAre=tl(predsAre)) {
evs = cons(assumeEvid(hd(predsAre),typeOff),evs);
- if (!isName(h) || !isCfun(h))
+ }
+ if (!isName(h) || !isCfun(h)) {
h = applyToArgs(h,rev(evs));
+ }
+ }
+
+ if (whatIs(typeIs)==CDICTS) { /* Deal with local dictionaries */
+ List evs = makePredAss(fst(snd(typeIs)),typeOff);
+ List ps = evs;
+ typeIs = snd(snd(typeIs));
+ for (; nonNull(ps); ps=tl(ps)) {
+ h = ap(h,thd3(hd(ps)));
+ }
+ if (tcMode==EXPRESSION) {
+ preds = revOnto(evs,preds);
+ } else {
+ hd(localEvs) = revOnto(evs,hd(localEvs));
+ }
}
if (whatIs(typeIs)==EXIST) { /* Deal with existential arguments */
Int n = intOf(fst(snd(typeIs)));
typeIs = snd(snd(typeIs));
- if (!isCfun(h) || n>typeFree)
+ if (!isCfun(getHead(h)) || n>typeFree) {
internal("typeAp2");
- else if (tcMode!=EXPRESSION) {
+ } else if (tcMode!=EXPRESSION) {
Int alpha = typeOff + typeFree;
for (; n>0; n--) {
bindTv(alpha-n,SKOLEM,0);
Bool added = FALSE;
saveVarsAss();
+ enterSkolVars();
if (whatIs(t)==RANK2) {
if (n<(nr2=intOf(fst(snd(t))))) {
ERRMSG(l) "Definition requires at least %d parameters on lhs",
restoreVarsAss();
doneBtyvs(l);
+ leaveSkolVars(l,origt,o,m);
}
static Int local funcType(n) /*return skeleton for function type*/
static String caseExpr = "case expression";
saveVarsAss();
-
+ enterSkolVars();
fst(c) = typeFreshPat(l,patBtyvs(fst(c)));
shouldBe(l,fst(c),NIL,casePat,aVar,beta);
snd(c) = typeRhs(snd(c));
restoreVarsAss();
doneBtyvs(l);
+ leaveSkolVars(l,typeIs,typeOff,0);
}
static Void local typeComp(l,m,e,qs) /* type check comprehension */
break;
case QWHERE : enterBindings();
+ enterSkolVars();
mapProc(typeBindings,snd(q));
typeComp(l,m,e,qs1);
leaveBindings();
+ leaveSkolVars(l,typeIs,typeOff,0);
break;
case FROMQUAL : { Int beta = newTyvars(1);
saveVarsAss();
check(l,snd(snd(q)),NIL,genQual,m,beta);
+ enterSkolVars();
fst(snd(q))
= typeFreshPat(l,patBtyvs(fst(snd(q))));
shouldBe(l,fst(snd(q)),NIL,genQual,aVar,beta);
typeComp(l,m,e,qs1);
restoreVarsAss();
doneBtyvs(l);
+ leaveSkolVars(l,typeIs,typeOff,0);
}
break;
}
}
+static Cell local typeMonadComp(l,e) /* type check monad comprehension */
+Int l;
+Cell e; {
+ Int alpha = newTyvars(1);
+ Int beta = newTyvars(1);
+ Cell mon = ap(mkInt(beta),aVar);
+ Cell m = assumeEvid(predMonad,beta);
+ tyvar(beta)->kind = starToStar;
+#if !MONAD_COMPS
+ bindTv(beta,typeList,0);
+#endif
+
+ typeComp(l,mon,snd(e),snd(snd(e)));
+ bindTv(alpha,typeIs,typeOff);
+ inferType(mon,alpha);
+ return ap(MONADCOMP,pair(m,snd(e)));
+}
+
static Void local typeDo(l,e) /* type check do-notation */
Int l;
Cell e; {
typeComp(l,mon,snd(e),snd(snd(e)));
shouldBe(l,fst(snd(e)),NIL,finGen,mon,alpha);
- snd(e) = pair(pair(m,compZero(snd(snd(e)),beta)),snd(e));
-}
-
-static Cell local compZero(qs,beta) /* return evidence for Monad0 beta */
-List qs; /* if needed for qualifiers qs */
-Int beta; {
- for (; nonNull(qs); qs=tl(qs))
- switch (whatIs(hd(qs))) {
- case FROMQUAL : if (failFree(fst(snd(hd(qs)))))
- break;
- /* intentional fall-thru */
- case BOOLQUAL : return assumeEvid(predMonad0,beta);
- }
- return NIL;
+ snd(e) = pair(m,snd(e));
}
static Void local typeConFlds(l,e) /* Type check a construction */
if (isVar(fst(b))) { /* function-binding? */
Cell t = fst(snd(b));
- if (whatIs(t)==IMPDEPS) /* Discard implicitly typed deps */
+ if (whatIs(t)==IMPDEPS) { /* Discard implicitly typed deps */
fst(snd(b)) = t = NIL; /* in a restricted binding group. */
+ }
fst(snd(b)) = localizeBtyvs(t);
restrictedAss(rhsLine(snd(hd(snd(snd(b))))), fst(b), t);
- }
- else { /* pattern-binding? */
+ } else { /* pattern-binding? */
List vs = fst(b);
List ts = fst(snd(b));
Int line = rhsLine(snd(snd(snd(b))));
- for (; nonNull(vs); vs=tl(vs))
+ for (; nonNull(vs); vs=tl(vs)) {
if (nonNull(ts)) {
restrictedAss(line,hd(vs),hd(ts)=localizeBtyvs(hd(ts)));
ts = tl(ts);
- }
- else
+ } else {
restrictedAss(line,hd(vs),NIL);
+ }
+ }
}
}
fst(snd(hd(bs1))) = NIL; /* reset imps type fields */
#ifdef DEBUG_DEPENDS
- printf("Binding group:");
+ Printf("Binding group:");
for (bs1=imps; nonNull(bs1); bs1=tl(bs1)) {
- printf(" [imp:");
+ Printf(" [imp:");
for (bs=hd(bs1); nonNull(bs); bs=tl(bs))
- printf(" %s",textToStr(textOf(fst(hd(bs)))));
- printf("]");
+ Printf(" %s",textToStr(textOf(fst(hd(bs)))));
+ Printf("]");
}
if (nonNull(exps)) {
- printf(" [exp:");
+ Printf(" [exp:");
for (bs=exps; nonNull(bs); bs=tl(bs))
- printf(" %s",textToStr(textOf(fst(hd(bs)))));
- printf("]");
+ Printf(" %s",textToStr(textOf(fst(hd(bs)))));
+ Printf("]");
}
- printf("\n");
+ Printf("\n");
#endif
/* ----------------------------------------------------------------------
normPreds(line);
savePreds = elimOuterPreds(savePreds);
- if (nonNull(preds) && resolveDefs(genvarAllAss(hd(defnBounds))))
+ if (nonNull(preds) && resolveDefs(genvarAllAss(hd(defnBounds)))) {
savePreds = elimOuterPreds(savePreds);
+ }
map1Proc(genBind,preds,hd(imps));
if (nonNull(preds)) {
map1Proc(qualifyBinding,preds,hd(imps));
}
+ h98CheckType(line,"inferred type",
+ fst(hd(hd(defnBounds))),snd(hd(hd(defnBounds))));
hd(varsBounds) = revOnto(hd(defnBounds),hd(varsBounds));
}
resetGenerics(); /* Make sure we're general enough */
ps = copyPreds(ps);
t = generalize(ps,liftRank2(t,o,m));
+
if (!sameSchemes(t,fst(snd(b))))
tooGeneral(line,fst(b),fst(snd(b)),t);
+ h98CheckType(line,"inferred type",fst(b),t);
if (nonNull(preds)) /* Check context was strong enough */
cantEstablish(line,extbind,fst(b),t,ps);
for (ps=supers; nonNull(ps); ps=tl(ps)) { /* Superclass dictionaries */
Cell pi = hd(ps);
- Cell ev = scEntail(params,fst3(pi),intOf(snd3(pi)));
- if (isNull(ev))
- ev = inEntail(evids,fst3(pi),intOf(snd3(pi)));
+ Cell ev = scEntail(params,fst3(pi),intOf(snd3(pi)),0);
+ if (isNull(ev))
+ ev = inEntail(evids,fst3(pi),intOf(snd3(pi)),0);
if (isNull(ev)) {
clearMarks();
ERRMSG(inst(in).line) "Cannot build superclass instance" ETHEN
ERRTEXT "\n*** Instance : " ETHEN
- ERRPRED(copyPred(inst(in).head,beta));
+ ERRPRED(copyPred(inst(in).head,beta));
ERRTEXT "\n*** Context supplied : " ETHEN
- ERRCONTEXT(copyPreds(params));
+ ERRCONTEXT(copyPreds(params));
ERRTEXT "\n*** Required superclass : " ETHEN
- ERRPRED(copyPred(fst3(pi),intOf(snd3(pi))));
+ ERRPRED(copyPred(fst3(pi),intOf(snd3(pi))));
ERRTEXT "\n"
EEND;
}
Type rt;
#ifdef DEBUG_TYPES
- printf("Type check member: ");
+ Printf("Type check member: ");
printExp(stdout,mem);
- printf(" :: ");
+ Printf(" :: ");
printType(stdout,name(mem).type);
- printf("\nfor the instance: ");
+ Printf("\nfor the instance: ");
printPred(stdout,head);
- printf("\n");
+ Printf("\n");
#endif
instantiate(name(mem).type); /* Find required type */
rt = generalize(qs,liftRank2(t,o,m));
#ifdef DEBUG_TYPES
- printf("Required type is: ");
+ Printf("Required type is: ");
printType(stdout,rt);
- printf("\n");
+ Printf("\n");
#endif
hd(defnBounds) = NIL; /* Type check each alternative */
ps = copyPreds(ps);
t = generalize(ps,liftRank2(t,o,m));
#ifdef DEBUG_TYPES
- printf("Inferred type is: ");
+ Printf("Inferred type is: ");
printType(stdout,t);
- printf("\n");
+ Printf("\n");
#endif
if (!sameSchemes(t,rt))
tooGeneral(line,mem,rt,t);
Int l = rhsLine(snd(pb));
tcMode = OLD_PATTERN;
+ enterPendingBtyvs();
+ fst(pb) = patBtyvs(fst(pb));
check(l,fst(pb),NIL,lhsPat,aVar,beta);
tcMode = EXPRESSION;
snd(pb) = typeRhs(snd(pb));
shouldBe(l,rhsExpr(snd(pb)),NIL,rhs,aVar,beta);
+ doneBtyvs(l);
+ leavePendingBtyvs();
}
}
break;
case LETREC : enterBindings();
+ enterSkolVars();
mapProc(typeBindings,fst(snd(e)));
snd(snd(e)) = typeRhs(snd(snd(e)));
leaveBindings();
+ leaveSkolVars(rhsLine(snd(snd(e))),typeIs,typeOff,0);
break;
+ case RSIGN : fst(snd(e)) = typeRhs(fst(snd(e)));
+ shouldBe(rhsLine(fst(snd(e))),
+ rhsExpr(fst(snd(e))),NIL,
+ "result type",
+ snd(snd(e)),0);
+ return fst(snd(e));
+
default : snd(e) = typeExpr(intOf(fst(e)),snd(e));
break;
}
switch (whatIs(rhs)) {
case GUARDED : return snd(snd(hd(snd(rhs))));
case LETREC : return rhsExpr(snd(snd(rhs)));
+ case RSIGN : return rhsExpr(fst(snd(rhs)));
default : return snd(rhs);
}
}
switch (whatIs(rhs)) {
case GUARDED : return intOf(fst(hd(snd(rhs))));
case LETREC : return rhsLine(snd(snd(rhs)));
+ case RSIGN : return rhsLine(fst(snd(rhs)));
default : return intOf(fst(rhs));
}
}
#ifdef DEBUG_TYPES
printExp(stdout,v);
- printf(" :: ");
+ Printf(" :: ");
printType(stdout,snd(ass));
- printf("\n");
+ Printf("\n");
#endif
}
}
t = mkPolyType(k,t);
#ifdef DEBUG_KINDS
- printf("Generalized type: ");
+ Printf("Generalized type: ");
printType(stdout,t);
- printf(" ::: ");
+ Printf(" ::: ");
printKind(stdout,k);
- printf("\n");
+ Printf("\n");
#endif
}
return t;
ctxt = copyPreds(preds);
type = generalize(ctxt,copyType(type,beta));
inputExpr = qualifyExpr(0,preds,inputExpr);
+ h98CheckType(0,"inferred type",inputExpr,type);
typeChecker(RESET);
emptySubstitution();
return type;
typeChecker(RESET);
emptySubstitution();
+ enterSkolVars();
enterBindings();
setGoal("Type checking",t);
EEND;
}
+ if (nonNull(hd(skolVars))) {
+ Cell b = hd(bs);
+ Name n = findName(isVar(fst(b)) ? textOf(fst(b)) : textOf(hd(fst(b))));
+ Int l = nonNull(n) ? name(n).line : 0;
+ leaveSkolVars(l,typeUnit,0,0);
+ enterSkolVars();
+ }
+
for (as=hd(varsBounds); nonNull(as); as=tl(as)) {
Cell a = hd(as); /* add infered types to environment*/
Name n = findName(textOf(fst(a)));
Int m;
#ifdef DEBUG_SELS
- printf("Selector %s, cns=",textToStr(name(s).text));
+ Printf("Selector %s, cns=",textToStr(name(s).text));
printExp(stdout,cns);
- putchar('\n');
+ Putchar('\n');
#endif
emptySubstitution();
map1Proc(qualify,preds,alts);
#ifdef DEBUG_SELS
- printf("Inferred arity = %d, type = ",name(s).arity);
+ Printf("Inferred arity = %d, type = ",name(s).arity);
printType(stdout,name(s).type);
- putchar('\n');
+ Putchar('\n');
#endif
return pair(s,alts);
}
+
/* --------------------------------------------------------------------------
* Local function prototypes:
* ------------------------------------------------------------------------*/
*
* ------------------------------------------------------------------------*/
-List offsetTyvarsIn(t,vs) /* add list of offset tyvars in t */
+static List offsetTyvarsIn(t,vs) /* add list of offset tyvars in t */
Type t; /* to list vs */
List vs; {
switch (whatIs(t)) {
static Type stateVar = NIL;
static Type alphaVar = NIL;
static Type betaVar = NIL;
+static Type gammaVar = NIL;
static Int nextVar = 0;
static Void clearTyVars( void )
stateVar = NIL;
alphaVar = NIL;
betaVar = NIL;
+ gammaVar = NIL;
nextVar = 0;
}
return betaVar;
}
+static Type mkGammaVar( void )
+{
+ if (isNull(gammaVar)) {
+ gammaVar = mkOffset(nextVar++);
+ }
+ return gammaVar;
+}
+
static Type local basicType(k)
Char k; {
switch (k) {
return mkAlphaVar(); /* polymorphic */
case BETA_REP:
return mkBetaVar(); /* polymorphic */
+ case GAMMA_REP:
+ return mkGammaVar(); /* polymorphic */
default:
printf("Kind: '%c'\n",k);
internal("basicType");
}
+ assert(0); return 0; /* NOTREACHED */
}
/* Generate type of primop based on list of arg types and result types:
}
/* forall a1 .. am. TC a1 ... am -> Int */
-Type conToTagType(t)
+static Type conToTagType(t)
Tycon t; {
Type ty = t;
List tvars = NIL;
}
/* forall a1 .. am. Int -> TC a1 ... am */
-Type tagToConType(t)
+static Type tagToConType(t)
Tycon t; {
Type ty = t;
List tvars = NIL;
* Type checker control:
* ------------------------------------------------------------------------*/
-Void mkTypes()
-{
- arrow = fn(aVar,mkOffset(1));
- listof = ap(typeList,aVar);
- predNum = ap(classNum,aVar);
- predFractional = ap(classFractional,aVar);
- predIntegral = ap(classIntegral,aVar);
- predMonad = ap(classMonad,aVar);
- predMonad0 = ap(classMonad0,aVar);
-}
-
Void typeChecker(what)
Int what; {
switch (what) {
mark(depends);
mark(pendingBtyvs);
mark(skolVars);
+ mark(localEvs);
+ mark(savedPs);
mark(dummyVar);
mark(preds);
mark(stdDefaults);
mark(predIntegral);
mark(starToStar);
mark(predMonad);
- mark(predMonad0);
+#if IO_MONAD
+ mark(typeProgIO);
+#endif
break;
case INSTALL : typeChecker(RESET);
dummyVar = inventVar();
+
+#if !IGNORE_MODULES
+ modulePrelude = newModule(textPrelude);
+ setCurrModule(modulePrelude);
+#endif
+
starToStar = simpleKind(1);
+
+ typeUnit = addPrimTycon(findText("()"),
+ STAR,0,DATATYPE,NIL);
+ typeArrow = addPrimTycon(findText("(->)"),
+ simpleKind(2),2,
+ DATATYPE,NIL);
+ typeList = addPrimTycon(findText("[]"),
+ starToStar,1,
+ DATATYPE,NIL);
+
+ arrow = fn(aVar,bVar);
+ listof = ap(typeList,aVar);
+ boundPair = ap(ap(mkTuple(2),aVar),aVar);
+
+ nameUnit = addPrimCfun(findText("()"),0,0,typeUnit);
+ tycon(typeUnit).defn
+ = singleton(nameUnit);
+
+ nameNil = addPrimCfun(findText("[]"),0,1,
+ mkPolyType(starToStar,
+ listof));
+ nameCons = addPrimCfun(findText(":"),2,2,
+ mkPolyType(starToStar,
+ fn(aVar,
+ fn(listof,
+ listof))));
+ name(nameCons).syntax
+ = mkSyntax(RIGHT_ASS,5);
+
+ tycon(typeList).defn
+ = cons(nameNil,cons(nameCons,NIL));
+
typeVarToVar = fn(aVar,aVar);
+#if TREX
+ typeNoRow = addPrimTycon(findText("EmptyRow"),
+ ROW,0,DATATYPE,NIL);
+ typeRec = addPrimTycon(findText("Rec"),
+ pair(ROW,STAR),1,
+ DATATYPE,NIL);
+ nameNoRec = addPrimCfun(findText("EmptyRec"),0,0,
+ ap(typeRec,typeNoRow));
+#else
+ /* bogus definitions to avoid changing the prelude */
+ addPrimCfun(findText("Rec"), 0,0,typeUnit);
+ addPrimCfun(findText("EmptyRow"), 0,0,typeUnit);
+ addPrimCfun(findText("EmptyRec"), 0,0,typeUnit);
+#endif
+#if IO_MONAD
+ nameUserErr = addPrimCfun(inventText(),1,1,NIL);
+ nameNameErr = addPrimCfun(inventText(),1,2,NIL);
+ nameSearchErr= addPrimCfun(inventText(),1,3,NIL);
+#if IO_HANDLES
+ nameIllegal = addPrimCfun(inventText(),0,4,NIL);
+ nameWriteErr = addPrimCfun(inventText(),1,5,NIL);
+ nameEOFErr = addPrimCfun(inventText(),1,6,NIL);
+#endif
+#endif
break;
}
}
projects / ghc-hetmet.git / commitdiff