-/* -*- 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
+ *
+ * The Hugs 98 system is Copyright (c) Mark P Jones, Alastair Reid, the
+ * Yale Haskell Group, and the Oregon Graduate Institute of Science and
+ * Technology, 1994-1999, All rights reserved. It is distributed as
+ * free software under the license in the file "License", which is
+ * included in the distribution.
+ *
+ * $RCSfile: type.c,v $
+ * $Revision: 1.36 $
+ * $Date: 2000/05/26 17:42:18 $
* ------------------------------------------------------------------------*/
-#include "prelude.h"
+#include "hugsbasictypes.h"
#include "storage.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 "Rts.h" /* to make StgPtr visible in Assembler.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*/
-Bool catchAmbigs = FALSE; /* TRUE => functions with ambig. */
- /* types produce error */
-
/* --------------------------------------------------------------------------
* Local function prototypes:
* ------------------------------------------------------------------------*/
-static Void local emptyAssumption Args((Void));
-static Void local enterBindings Args((Void));
-static Void local leaveBindings Args((Void));
-static Int local defType Args((Cell));
-static Type local useType Args((Cell));
-static Void local markAssumList Args((List));
-static Cell local findAssum Args((Text));
-static Pair local findInAssumList Args((Text,List));
-static List local intsIntersect Args((List,List));
-static List local genvarAllAss Args((List));
-static List local genvarAnyAss Args((List));
-static Int local newVarsBind Args((Cell));
-static Void local newDefnBind Args((Cell,Type));
-
-static Void local enterPendingBtyvs Args((Void));
-static Void local leavePendingBtyvs Args((Void));
-static Cell local patBtyvs Args((Cell));
-static Void local doneBtyvs Args((Int));
-
-static Void local typeError Args((Int,Cell,Cell,String,Type,Int));
-static Void local reportTypeError Args((Int,Cell,Cell,String,Type,Type));
-static Void local cantEstablish Args((Int,String,Cell,Type,List));
-static Void local tooGeneral Args((Int,Cell,Type,Type));
-
-static Cell local typeExpr Args((Int,Cell));
-
-static Cell local typeAp Args((Int,Cell));
-static Type local typeExpected Args((Int,String,Cell,Type,Int,Int,Bool));
-static Void local typeAlt Args((String,Cell,Cell,Type,Int,Int));
-static Int local funcType Args((Int));
-static Void local typeCase Args((Int,Int,Cell));
-static Void local typeComp Args((Int,Type,Cell,List));
-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 typeBindings Args((List));
-static Void local removeTypeSigs Args((Cell));
-
-static Void local monorestrict Args((List));
-static Void local restrictedBindAss Args((Cell));
-static Void local restrictedAss Args((Int,Cell,Type));
-
-static Void local unrestricted Args((List));
-static List local itbscc Args((List));
-static Void local addEvidParams Args((List,Cell));
-
-static Void local typeClassDefn Args((Class));
-static Void local typeInstDefn Args((Inst));
-static Void local typeMember Args((String,Name,Cell,List,Cell,Int));
-
-static Void local typeBind Args((Cell));
-static Void local typeDefAlt Args((Int,Cell,Pair));
-static Cell local typeRhs Args((Cell));
-static Void local guardedType Args((Int,Cell));
-
-static Void local genBind Args((List,Cell));
-static Void local genAss Args((Int,List,Cell,Type));
-static Type local genTest Args((Int,Cell,List,Type,Type,Int));
-static Type local generalize Args((List,Type));
-static Bool local equalTypes Args((Type,Type));
-
-static Void local typeDefnGroup Args((List));
-static Pair local typeSel Args((Name));
+static Void local emptyAssumption ( Void );
+static Void local enterBindings ( Void );
+static Void local leaveBindings ( Void );
+static Int local defType ( Cell );
+static Type local useType ( Cell );
+static Void local markAssumList ( List );
+static Cell local findAssum ( Text );
+static Pair local findInAssumList ( Text,List );
+static List local intsIntersect ( List,List );
+static List local genvarAllAss ( List );
+static List local genvarAnyAss ( List );
+static Int local newVarsBind ( Cell );
+static Void local newDefnBind ( Cell,Type );
+
+static Void local enterPendingBtyvs ( Void );
+static Void local leavePendingBtyvs ( Void );
+static Cell local patBtyvs ( Cell );
+static Void local doneBtyvs ( Int );
+static Void local enterSkolVars ( Void );
+static Void local leaveSkolVars ( Int,Type,Int,Int );
+
+static Void local typeError ( Int,Cell,Cell,String,Type,Int );
+static Void local reportTypeError ( Int,Cell,Cell,String,Type,Type );
+static Void local cantEstablish ( Int,String,Cell,Type,List );
+static Void local tooGeneral ( Int,Cell,Type,Type );
+
+static Cell local typeExpr ( Int,Cell );
+
+static Cell local typeAp ( Int,Cell );
+static Type local typeExpected ( Int,String,Cell,Type,Int,Int,Bool );
+static Void local typeAlt ( String,Cell,Cell,Type,Int,Int );
+static Int local funcType ( Int );
+static Void local typeCase ( Int,Int,Cell );
+static Void local typeComp ( Int,Type,Cell,List );
+static Cell local typeMonadComp ( Int,Cell );
+static Void local typeDo ( Int,Cell );
+static Void local typeConFlds ( Int,Cell );
+static Void local typeUpdFlds ( Int,Cell );
+#if IPARAM
+static Cell local typeWith ( Int,Cell );
+#endif
+static Cell local typeFreshPat ( Int,Cell );
+
+static Void local typeBindings ( List );
+static Void local removeTypeSigs ( Cell );
-/* --------------------------------------------------------------------------
- * Frequently used type skeletons:
- * ------------------------------------------------------------------------*/
+static Void local monorestrict ( List );
+static Void local restrictedBindAss ( Cell );
+static Void local restrictedAss ( Int,Cell,Type );
+
+static Void local unrestricted ( List );
+static List local itbscc ( List );
+static Void local addEvidParams ( List,Cell );
+
+static Void local typeClassDefn ( Class );
+static Void local typeInstDefn ( Inst );
+static Void local typeMember ( String,Name,Cell,List,Cell,Int );
+
+static Void local typeBind ( Cell );
+static Void local typeDefAlt ( Int,Cell,Pair );
+static Cell local typeRhs ( Cell );
+static Void local guardedType ( Int,Cell );
+
+static Void local genBind ( List,Cell );
+static Void local genAss ( Int,List,Cell,Type );
+static Type local genTest ( Int,Cell,List,Type,Type,Int );
+static Type local generalize ( List,Type );
+static Bool local equalTypes ( Type,Type );
+
+static Void local typeDefnGroup ( List );
+static Pair local typeSel ( Name );
-static Type arrow; /* mkOffset(0) -> mkOffset(1) */
-static Type boundPair; /* (mkOffset(0),mkOffset(0)) */
-static 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)) */
-static Kind starToStar; /* Type -> Type */
-static Cell predMonad; /* Monad (mkOffset(0)) */
-static Cell predMonad0; /* Monad0 (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*/
+Bool catchAmbigs = FALSE; /* TRUE => functions with ambig. */
+ /* types produce error */
+
+
#define saveVarsAss() List saveAssump = hd(varsBounds)
#define restoreVarsAss() hd(varsBounds) = saveAssump
#define addVarAssump(v,t) hd(varsBounds) = cons(pair(v,t),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));
+ normPreds(l);
+ 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
typeError(l,e,in,where,t,o);
#define check(l,e,in,where,t,o) e=typeExpr(l,e); shouldBe(l,e,in,where,t,o)
#define inferType(t,o) typeIs=t; typeOff=o
+#if IPARAM
+#define spTypeExpr(l,e) svPreds = preds; preds = NIL; e = typeExpr(l,e); preds = revOnto(preds,svPreds);
+#define spCheck(l,e,in,where,t,o) svPreds = preds; preds = NIL; check(l,e,in,where,t,o); preds = revOnto(preds,svPreds);
+#else
+#define spTypeExpr(l,e) e = typeExpr(l,e);
+#define spCheck(l,e,in,where,t,o) check(l,e,in,where,t,o);
+#endif
static Void local cantEstablish(line,wh,e,t,ps)
Int line; /* Complain when declared preds */
static int tcMode = EXPRESSION;
#ifdef DEBUG_TYPES
-static Cell local mytypeExpr Args((Int,Cell));
+static Cell local mytypeExpr ( Int,Cell));
static Cell local typeExpr(l,e)
Int l;
Cell e; {
static int number = 0;
Cell retv;
int mynumber = number++;
- printf("%d) to check: ",mynumber);
+ List ps;
+ STACK_CHECK
+ 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');
+ Printf("\n%d) preds: ",mynumber);
+ printContext(stdout,debugContext(preds));
+ Putchar('\n');
return retv;
}
static Cell local mytypeExpr(l,e) /* Determine type of expr/pattern */
static String aspat = "as (@) pattern";
static String typeSig = "type annotation";
static String lambda = "lambda expression";
+#if IPARAM
+ List svPreds;
+#endif
switch (whatIs(e)) {
case AP :
case NAME :
case VAROPCELL :
- case VARIDCELL : return typeAp(l,e);
+ case VARIDCELL :
+#if IPARAM
+ case IPVAR :
+#endif
+ return typeAp(l,e);
case TUPLE : typeTuple(e);
break;
-#if OVERLOADED_CONSTANTS
case BIGCELL : { Int alpha = newTyvars(1);
- inferType(aVar,alpha);
- return ap2(nameFromInteger,
- assumeEvid(predNum,alpha),
- e);
+ inferType(aVar,alpha);
+ return ap(ap(nameFromInteger,
+ assumeEvid(predNum,alpha)),
+ e);
}
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));
case UPDFLDS : typeUpdFlds(l,e);
break;
+#if IPARAM
+ case WITHEXP : return typeWith(l,e);
+#endif
+
case COND : { Int beta = newTyvars(1);
check(l,fst3(snd(e)),e,cond,typeBool,0);
- check(l,snd3(snd(e)),e,cond,aVar,beta);
- check(l,thd3(snd(e)),e,cond,aVar,beta);
+ spCheck(l,snd3(snd(e)),e,cond,aVar,beta);
+ spCheck(l,thd3(snd(e)),e,cond,aVar,beta);
tyvarType(beta);
}
break;
case LETREC : enterBindings();
+ enterSkolVars();
mapProc(typeBindings,fst(snd(e)));
- snd(snd(e)) = typeExpr(l,snd(snd(e)));
+ spTypeExpr(l,snd(snd(e)));
leaveBindings();
+ leaveSkolVars(l,typeIs,typeOff,0);
break;
case FINLIST : { Int beta = newTyvars(1);
List xs;
for (xs=snd(e); nonNull(xs); xs=tl(xs)) {
- check(l,hd(xs),e,list,aVar,beta);
+ spCheck(l,hd(xs),e,list,aVar,beta);
}
inferType(listof,beta);
}
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));
case LAZYPAT : snd(e) = typeExpr(l,snd(e));
break;
-#if NPLUSK
case ADDPAT : { Int alpha = newTyvars(1);
inferType(typeVarToVar,alpha);
return ap(e,assumeEvid(predIntegral,alpha));
}
-#endif
default : internal("typeExpr");
}
Cell p = NIL;
Cell a = e;
Int i;
+#if IPARAM
+ List svPreds;
+#endif
switch (whatIs(h)) {
case NAME : typeIs = name(h).type;
}
break;
+#if IPARAM
+ case IPVAR : { Text t = textOf(h);
+ Int alpha = newTyvars(1);
+ Cell ip = pair(ap(IPCELL,t),aVar);
+ Cell ev = assumeEvid(ip,alpha);
+ typeIs = mkInt(alpha);
+ h = ap(h,ev);
+ }
+ break;
+#endif
+
default : h = typeExpr(l,h);
break;
}
- if (isNull(typeIs))
+ if (isNull(typeIs)) {
internal("typeAp1");
+ }
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))
+ }
+ /* we now _always_ do this: 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);
for (as=getArgs(as); nonNull(as); as=tl(as), body=arg(body)) {
Type expect = dropRank1(arg(fun(body)),alpha,m);
- if (isPolyType(expect)) {
+ if (isPolyOrQualType(expect)) {
if (tcMode==EXPRESSION) /* poly/qual type in expr */
hd(as) = typeExpected(l,app,hd(as),expect,alpha,m,TRUE);
else if (hd(as)!=WILDCARD) { /* Pattern binding/match */
}
}
else { /* Not a poly/qual type */
- check(l,hd(as),e,app,expect,alpha);
+ spCheck(l,hd(as),e,app,expect,alpha);
}
h = ap(h,hd(as)); /* Save checked argument */
}
Int beta = funcType(n); /* check h::t1->t2->...->tn->rn+1 */
shouldBe(l,h,e,app,aVar,beta);
for (i=n; i>0; --i) { /* check e_i::t_i for each i */
- check(l,arg(a),e,app,aVar,beta+2*i-1);
+ spCheck(l,arg(a),e,app,aVar,beta+2*i-1);
p = a;
a = fun(a);
}
preds = NIL;
check(l,e,NIL,wh,t,o);
+ improve(l,ps,preds);
clearMarks();
mapProc(markAssumList,defnBounds);
mapProc(markPred,savePreds);
markBtyvs();
- for (i=0; i<n; i++)
- markTyvar(alpha+i);
+ if (n > 0) { /* mark alpha thru alpha+n-1, plus any */
+ /* type vars that are functionally */
+ List us = NIL, vs = NIL; /* dependent on them */
+ List fds = calcFunDepsPreds(preds);
+ for (i=0; i<n; i++) {
+ Type t1 = zonkTyvar(alpha+i);
+ us = zonkTyvarsIn(t1,us);
+ }
+ vs = oclose(fds,us);
+ for (; nonNull(vs); vs=tl(vs))
+ markTyvar(intOf(hd(vs)));
+ }
+ normPreds(l);
savePreds = elimPredsUsing(ps,savePreds);
if (nonNull(preds) && resolveDefs(genvarType(t,o,NIL)))
savePreds = elimPredsUsing(ps,savePreds);
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",
while (getHead(t)==typeArrow && argCount==2 && nonNull(ps)) {
Type ta = arg(fun(t));
- if (isPolyType(ta)) {
+ if (isPolyOrQualType(ta)) {
if (hd(ps)!=WILDCARD) {
if (!isVar(hd(ps))) {
ERRMSG(l) "Argument " ETHEN ERREXPR(hd(ps));
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 */
List qs; {
static String boolQual = "boolean qualifier";
static String genQual = "generator";
+#if IPARAM
+ List svPreds;
+#endif
- if (isNull(qs)) /* no qualifiers left */
- fst(e) = typeExpr(l,fst(e));
- else {
+ STACK_CHECK
+ if (isNull(qs)) { /* no qualifiers left */
+ spTypeExpr(l,fst(e));
+ } else {
Cell q = hd(qs);
List qs1 = tl(qs);
switch (whatIs(q)) {
- case BOOLQUAL : check(l,snd(q),NIL,boolQual,typeBool,0);
+ case BOOLQUAL : spCheck(l,snd(q),NIL,boolQual,typeBool,0);
typeComp(l,m,e,qs1);
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);
+ enterPendingBtyvs();
+ spCheck(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);
+ leavePendingBtyvs();
+ leaveSkolVars(l,typeIs,typeOff,0);
}
break;
- case DOQUAL : check(l,snd(q),NIL,genQual,m,newTyvars(1));
+ case DOQUAL : spCheck(l,snd(q),NIL,genQual,m,newTyvars(1));
typeComp(l,m,e,qs1);
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);
+ m = nameListMonad;
+#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 */
Int to;
Int tf;
Int i;
+#if IPARAM
+ List svPreds;
+#endif
instantiate(name(c).type);
for (; nonNull(predsAre); predsAre=tl(predsAre))
for (i=sfunPos(fst(hd(fs)),c); --i>0; t=arg(t))
;
t = dropRank1(arg(fun(t)),to,tf);
- if (isPolyType(t))
+ if (isPolyOrQualType(t))
snd(hd(fs)) = typeExpected(l,conExpr,snd(hd(fs)),t,to,tf,TRUE);
else {
- check(l,snd(hd(fs)),e,conExpr,t,to);
+ spCheck(l,snd(hd(fs)),e,conExpr,t,to);
}
}
for (i=name(c).arity; i>0; i--)
Int alpha = newTyvars(2+n);
Int i;
List fs1;
+#if IPARAM
+ List svPreds;
+#endif
/* Calculate type and translation for each expr in the field list */
for (fs1=fs, i=alpha+2; nonNull(fs1); fs1=tl(fs1), i++) {
- snd(hd(fs1)) = typeExpr(line,snd(hd(fs1)));
+ spTypeExpr(line,snd(hd(fs1)));
bindTv(i,typeIs,typeOff);
}
ts = rev(ts);
/* Type check expression to be updated */
- fst3(snd(e)) = typeExpr(line,fst3(snd(e)));
+ spTypeExpr(line,fst3(snd(e)));
bindTv(alpha,typeIs,typeOff);
for (; nonNull(cs); cs=tl(cs)) { /* Loop through constrs */
assumeEvid(hd(predsAre),typeOff);
if (whatIs(typeIs)==RANK2) {
- ERRMSG(line) "Sorry, record update syntax cannot currently be used for datatypes with polymorphic components"
+ ERRMSG(line) "Sorry, record update syntax cannot currently be "
+ "used for datatypes with polymorphic components"
EEND;
}
/* (typeIs,typeOff) still carry the result type when we exit the loop */
}
+#if IPARAM
+static Cell local typeWith(line,e) /* Type check a with */
+Int line;
+Cell e; {
+ List fs = snd(snd(e)); /* List of field specifications */
+ Int n = length(fs);
+ Int alpha = newTyvars(2+n);
+ Int i;
+ List fs1;
+ Cell tIs;
+ Cell tOff;
+ List dpreds = NIL, dp;
+ Cell bs = NIL;
+
+ /* Type check expression to be updated */
+ fst(snd(e)) = typeExpr(line,fst(snd(e)));
+ bindTv(alpha,typeIs,typeOff);
+ tIs = typeIs;
+ tOff = typeOff;
+ /* elim duplicate uses of imp params */
+ preds = scSimplify(preds);
+ /* extract preds that we're going to bind */
+ for (fs1=fs; nonNull(fs1); fs1=tl(fs1)) {
+ Text t = textOf(fst(hd(fs1)));
+ Cell p = findIPEvid(t);
+ dpreds = cons(p, dpreds);
+ if (nonNull(p)) {
+ removeIPEvid(t);
+ } else {
+ /* maybe give a warning message here... */
+ }
+ }
+ dpreds = rev(dpreds);
+
+ /* Calculate type and translation for each expr in the field list */
+ for (fs1=fs, dp=dpreds, i=alpha+2; nonNull(fs1); fs1=tl(fs1), dp=tl(dp), i++) {
+ static String with = "with";
+ Cell ev = hd(dp);
+ snd(hd(fs1)) = typeExpr(line,snd(hd(fs1)));
+ bindTv(i,typeIs,typeOff);
+ if (nonNull(ev)) {
+ shouldBe(line,fst(hd(fs1)),e,with,snd(fst3(ev)),intOf(snd3(ev)));
+ bs = cons(cons(pair(thd3(ev), cons(triple(NIL, mkInt(line), snd(hd(fs1))), NIL)), NIL), bs);
+ }
+ }
+ typeIs = tIs;
+ typeOff = tOff;
+ return (ap(LETREC,pair(bs,fst(snd(e)))));
+}
+#endif
+
static Cell local typeFreshPat(l,p) /* find type of pattern, assigning */
Int l; /* fresh type variables to each var */
Cell p; { /* bound in the pattern */
preds = NIL; /* Type check the bindings */
mapProc(restrictedBindAss,bs);
mapProc(typeBind,bs);
+ improve(line,NIL,preds);
normPreds(line);
elimTauts();
preds = revOnto(preds,savePreds);
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
/* ----------------------------------------------------------------------
preds = NIL;
mapProc(typeBind,hd(imps));
+ improve(line,NIL,preds);
clearMarks();
mapProc(markAssumList,tl(defnBounds));
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));
}
enterPendingBtyvs();
for (; nonNull(alts); alts=tl(alts))
typeAlt(extbind,fst(b),hd(alts),t,o,m);
+ improve(line,ps,preds);
leavePendingBtyvs();
if (nonNull(ps)) /* Add dict params, if necessary */
mapProc(markPred,savePreds);
markBtyvs();
+ normPreds(line);
savePreds = elimPredsUsing(ps,savePreds);
if (nonNull(preds)) {
List vs = NIL;
Int i = 0;
for (; i<m; ++i)
vs = cons(mkInt(o+i),vs);
- if (resolveDefs(vs))
+ if (resolveDefs(vs)) {
savePreds = elimPredsUsing(ps,savePreds);
+ }
if (nonNull(preds)) {
clearMarks();
reducePreds();
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);
* ------------------------------------------------------------------------*/
static Void local typeClassDefn(c) /* Type check implementations of */
-Class c; { /* defaults for class c */
+Class c; { /* defaults for class c */
/* ----------------------------------------------------------------------
- * Generate code for default dictionary builder function:
- *
- * class.C sc1 ... scn d = let v1 ... = ...
- * vm ... = ...
- * in Make.C sc1 ... scn v1 ... vm
- *
- * where sci are superclass dictionary parameters, vj are implementations
- * for member functions, either taken from defaults, or using "error" to
- * produce a suitable error message. (Additional line number values must
- * be added at appropriate places but, for clarity, these are not shown
- * above.)
+ * Generate code for default dictionary builder functions:
* --------------------------------------------------------------------*/
Int beta = newKindedVars(cclass(c).kinds);
- List params = makePredAss(cclass(c).supers,beta);
- Cell body = cclass(c).dcon;
- Cell pat = body;
+ Cell d = inventDictVar();
+ List dparam = singleton(triple(cclass(c).head,mkInt(beta),d));
List mems = cclass(c).members;
List defs = cclass(c).defaults;
List dsels = cclass(c).dsels;
- Cell d = inventDictVar();
- List args = NIL;
- List locs = NIL;
- Cell l = mkInt(cclass(c).line);
- List ps;
+ Cell pat = cclass(c).dcon;
+ Int width = cclass(c).numSupers + cclass(c).numMembers;
+ char buf[FILENAME_MAX+1];
+ Int i = 0;
+ Int j = 0;
- for (ps=params; nonNull(ps); ps=tl(ps)) {
- Cell v = thd3(hd(ps));
- body = ap(body,v);
- pat = ap(pat,inventVar());
- args = cons(v,args);
+ if (isNull(defs) && nonNull(mems)) {
+ defs = cclass(c).defaults = cons(NIL,NIL);
}
- args = revOnto(args,singleton(d));
- params = appendOnto(params,
- singleton(triple(cclass(c).head,mkInt(beta),d)));
for (; nonNull(mems); mems=tl(mems)) {
- Cell v = inventVar(); /* Pick a name for component */
- Cell imp = NIL;
-
- if (nonNull(defs)) { /* Look for default implementation */
- imp = hd(defs);
- defs = tl(defs);
- }
-
- if (isNull(imp)) { /* Generate undefined member msg */
- static String header = "Undefined member: ";
- String name = textToStr(name(hd(mems)).text);
- char msg[FILENAME_MAX+1];
- Int i;
- Int j;
-
- for (i=0; i<FILENAME_MAX && header[i]!='\0'; i++)
- msg[i] = header[i];
- for (j=0; (i+j)<FILENAME_MAX && name[j]!='\0'; j++)
- msg[i+j] = name[j];
- msg[i+j] = '\0';
-
- imp = pair(v,singleton(pair(NIL,ap(l,ap(nameError,
- mkStr(findText(msg)))))));
- }
- else { /* Use default implementation */
- fst(imp) = v;
- typeMember("default member binding",
- hd(mems),
- snd(imp),
- params,
- cclass(c).head,
- beta);
- }
-
- locs = cons(imp,locs);
- body = ap(body,v);
- pat = ap(pat,v);
+ /* static String deftext = "default_"; */
+ static String deftext = "$dm";
+ String s = textToStr(name(hd(mems)).text);
+ Name n;
+ i = j = 0;
+ for (; i<FILENAME_MAX && deftext[i]!='\0'; i++) {
+ buf[i] = deftext[i];
+ }
+ for(; (i+j)<FILENAME_MAX && s[j]!='\0'; j++) {
+ buf[i+j] = s[j];
+ }
+ buf[i+j] = '\0';
+ n = newName(findText(buf),c);
+
+ if (isNull(hd(defs))) { /* No default definition */
+ static String header = "Undefined member: ";
+ for (i=0; i<FILENAME_MAX && header[i]!='\0'; i++)
+ buf[i] = header[i];
+ for (j=0; (i+j)<FILENAME_MAX && s[j]!='\0'; j++)
+ buf[i+j] = s[j];
+ buf[i+j] = '\0';
+ name(n).line = cclass(c).line;
+ name(n).arity = 1;
+ name(n).defn = singleton(pair(singleton(d),
+ ap(mkInt(cclass(c).line),
+ ap(nameError,
+ mkStr(fixLitText(
+ findText(buf)))))));
+ } else { /* User supplied default defn */
+ List alts = snd(hd(defs));
+ Int line = rhsLine(snd(hd(alts)));
+
+ typeMember("default member binding",
+ hd(mems),
+ alts,
+ dparam,
+ cclass(c).head,
+ beta);
+
+ name(n).line = line;
+ name(n).arity = 1+length(fst(hd(alts)));
+ name(n).defn = alts;
+
+ for (; nonNull(alts); alts=tl(alts)) {
+ fst(hd(alts)) = cons(d,fst(hd(alts)));
+ }
+ }
+
+ hd(defs) = n;
+ genDefns = cons(n,genDefns);
+ if (isNull(tl(defs)) && nonNull(tl(mems))) {
+ tl(defs) = cons(NIL,NIL);
+ }
+ defs = tl(defs);
}
- body = ap(l,body);
- if (nonNull(locs))
- body = ap(LETREC,pair(singleton(locs),body));
- name(cclass(c).dbuild).defn
- = singleton(pair(args,body));
- genDefns = cons(cclass(c).dbuild,genDefns);
- cclass(c).defaults = NIL;
/* ----------------------------------------------------------------------
* Generate code for superclass and member function selectors:
* --------------------------------------------------------------------*/
- args = getArgs(pat);
- pat = singleton(pat);
- for (; nonNull(dsels); dsels=tl(dsels)) {
- name(hd(dsels)).defn = singleton(pair(pat,ap(l,hd(args))));
- args = tl(args);
- genDefns = cons(hd(dsels),genDefns);
+ for (i=0; i<width; i++) {
+ pat = ap(pat,inventVar());
+ }
+ pat = singleton(pat);
+ for (i=0; nonNull(dsels); dsels=tl(dsels)) {
+ name(hd(dsels)).defn = singleton(pair(pat,
+ ap(mkInt(cclass(c).line),
+ nthArg(i++,hd(pat)))));
+ genDefns = cons(hd(dsels),genDefns);
}
for (mems=cclass(c).members; nonNull(mems); mems=tl(mems)) {
- name(hd(mems)).defn = singleton(pair(pat,ap(mkInt(name(hd(mems)).line),
- hd(args))));
- args = tl(args);
- genDefns = cons(hd(mems),genDefns);
+ name(hd(mems)).defn = singleton(pair(pat,
+ ap(mkInt(name(hd(mems)).line),
+ nthArg(i++,hd(pat)))));
+ genDefns = cons(hd(mems),genDefns);
}
}
* .
* .
* scm = ...
- * d = f (class.C sc1 ... scm d)
- * omit if the / f (Make.C sc1' ... scm' v1' ... vk')
- * instance decl { = let vj ... = ...
- * has no imps \ in Make.C sc1' ... scm' ... vj ...
+ * vj ... = ...
+ * d = Make.C sc1 ... scm v1 ... vk
* in d
*
- * where sci are superclass dictionaries, d and f are new names, vj
+ * where sci are superclass dictionaries, d is a new name, vj
* is a newly generated name corresponding to the implementation of a
* member function. (Additional line number values must be added at
* appropriate places but, for clarity, these are not shown above.)
+ * If no implementation of a particular vj is available, then we use
+ * the default implementation, partially applied to d.
* --------------------------------------------------------------------*/
Int alpha = newKindedVars(cclass(inst(in).c).kinds);
Int beta = newKindedVars(inst(in).kinds);
List params = makePredAss(inst(in).specifics,beta);
Cell d = inventDictVar();
+ /*
List evids = cons(triple(inst(in).head,mkInt(beta),d),
appendOnto(dupList(params),supers));
+ */
+ List evids = dupList(params);
List imps = inst(in).implements;
Cell l = mkInt(inst(in).line);
- Cell dictDef = cclass(inst(in).c).dbuild;
+ Cell dictDef = cclass(inst(in).c).dcon;
+ List mems = cclass(inst(in).c).members;
+ List defs = cclass(inst(in).c).defaults;
List args = NIL;
List locs = NIL;
List 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 = NIL;
+#if EXPLAIN_INSTANCE_RESOLUTION
+ if (showInstRes) {
+ fputs("scEntail: ", stdout);
+ printContext(stdout,copyPreds(params));
+ fputs(" ||- ", stdout);
+ printPred(stdout, copyPred(fst3(pi),intOf(snd3(pi))));
+ fputc('\n', stdout);
+ }
+#endif
+ ev = scEntail(params,fst3(pi),intOf(snd3(pi)),0);
+ if (isNull(ev)) {
+#if EXPLAIN_INSTANCE_RESOLUTION
+ if (showInstRes) {
+ fputs("inEntail: ", stdout);
+ printContext(stdout,copyPreds(evids));
+ fputs(" ||- ", stdout);
+ printPred(stdout, copyPred(fst3(pi),intOf(snd3(pi))));
+ fputc('\n', stdout);
+ }
+#endif
+ 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;
}
locs = cons(pair(thd3(pi),singleton(pair(NIL,ap(l,ev)))),locs);
dictDef = ap(dictDef,thd3(pi));
}
- dictDef = ap(dictDef,d);
-
- if (isNull(imps)) /* No implementations */
- locs = cons(pair(d,singleton(pair(NIL,ap(l,dictDef)))),locs);
- else { /* Implementations supplied*/
- List mems = cclass(inst(in).c).members;
- Cell f = inventVar();
- Cell pat = cclass(inst(in).c).dcon;
- Cell res = pat;
- List locs1 = NIL;
-
- locs = cons(pair(d,singleton(pair(NIL,ap(l,ap(f,dictDef))))),
- locs);
-
- for (ps=supers; nonNull(ps); ps=tl(ps)){/* Add param for each sc */
- Cell v = inventVar();
- pat = ap(pat,v);
- res = ap(res,v);
- }
-
- for (; nonNull(mems); mems=tl(mems)) { /* For each member: */
- Cell v = inventVar();
- Cell imp = NIL;
- if (nonNull(imps)) { /* Look for implementation */
- imp = hd(imps);
- imps = tl(imps);
- }
+ for (; nonNull(defs); defs=tl(defs)) {
+ Cell imp = NIL;
+ if (nonNull(imps)) {
+ imp = hd(imps);
+ imps = tl(imps);
+ }
+ if (isNull(imp)) {
+ dictDef = ap(dictDef,ap(hd(defs),d));
+ } else {
+ Cell v = inventVar();
+ dictDef = ap(dictDef,v);
+ typeMember("instance member binding",
+ hd(mems),
+ snd(imp),
+ evids,
+ inst(in).head,
+ beta);
+ locs = cons(pair(v,snd(imp)),locs);
+ }
+ mems = tl(mems);
+ }
+ locs = cons(pair(d,singleton(pair(NIL,ap(l,dictDef)))),locs);
+
+ name(inst(in).builder).defn /* Register builder imp */
+ = singleton(pair(args,ap(LETREC,pair(singleton(locs),
+ ap(l,d)))));
+
+ /* Invent a GHC-compatible name for the instance decl */
+ {
+ char buf[FILENAME_MAX+1];
+ char buf2[10];
+ Int i, j;
+ String str;
+ Cell qq = inst(in).head;
+ Cell pp = NIL;
+ static String zdftext = "$f";
+
+ while (isAp(qq)) {
+ pp = cons(arg(qq),pp);
+ qq = fun(qq);
+ }
+ // pp is now the fwd list of args(?) to this pred
+
+ i = 0;
+ for (j = 0; i<FILENAME_MAX && zdftext[j]!='\0'; i++, j++) {
+ buf[i] = zdftext[j];
+ }
+ str = textToStr(cclass(inst(in).c).text);
+ for (j = 0; i<FILENAME_MAX && str[j]!='\0'; i++, j++) {
+ buf[i] = str[j];
+ }
+ if (nonNull(pp)) {
+ qq = hd(pp);
+ while (isAp(qq)) qq = fun(qq);
+ switch (whatIs(qq)) {
+ case TYCON: str = textToStr(tycon(qq).text); break;
+ case TUPLE: str = textToStr(ghcTupleText(qq)); break;
+ case OFFSET: sprintf(buf2,"%d",offsetOf(qq));
+ str = buf2;
+ break;
+ default: internal("typeInstDefn: making GHC name"); break;
+ }
+ for (j = 0; i<FILENAME_MAX && str[j]!='\0'; i++, j++) {
+ buf[i] = str[j];
+ }
+ }
- if (isNull(imp)) { /* If none, f will copy */
- pat = ap(pat,v); /* its argument unchanged */
- res = ap(res,v);
- }
- else { /* Otherwise, add the impl */
- pat = ap(pat,WILDCARD); /* to f as a local defn */
- res = ap(res,v);
- typeMember("instance member binding",
- hd(mems),
- snd(imp),
- evids,
- inst(in).head,
- beta);
- locs1 = cons(pair(v,snd(imp)),locs1);
- }
- }
- res = ap(l,res);
- if (nonNull(locs1)) /* Build the body of f */
- res = ap(LETREC,pair(singleton(locs1),res));
- pat = singleton(pat); /* And the arglist for f */
- locs = cons(pair(f,singleton(pair(pat,res))),locs);
+ buf[i++] = '\0';
+ name(inst(in).builder).text = findText(buf);
+ //fprintf ( stderr, "result = %s\n", buf );
}
- d = ap(l,d);
- name(inst(in).builder).defn /* Register builder imp */
- = singleton(pair(args,ap(LETREC,pair(singleton(locs),d))));
genDefns = cons(inst(in).builder,genDefns);
}
Type rt;
#ifdef DEBUG_TYPES
- printf("Type check member: ");
+ Printf("\nType check member: ");
printExp(stdout,mem);
- printf(" :: ");
+ Printf(" :: ");
printType(stdout,name(mem).type);
- printf("\nfor the instance: ");
+ Printf("\n for 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 */
typeAlt(wh,mem,hd(alts),t,o,m);
qualify(tl(ps),hd(alts)); /* Add any extra dict params */
}
+ improve(line,evids,preds);
leavePendingBtyvs();
evids = appendOnto(dupList(tl(ps)), /* Build full complement of dicts */
evids);
clearMarks();
+ normPreds(line);
qs = elimPredsUsing(evids,NIL);
if (nonNull(preds) && resolveDefs(genvarType(t,o,NIL)))
qs = elimPredsUsing(evids,qs);
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);
- if (nonNull(preds))
- cantEstablish(line,wh,mem,t,ps);
+ if (nonNull(preds)) {
+ preds = scSimplify(preds);
+ cantEstablish(line,wh,mem,t,ps);
+ }
}
/* --------------------------------------------------------------------------
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;
}
static String guarded = "guarded expression";
static String guard = "guard";
Int line = intOf(fst(gded));
+#if IPARAM
+ List svPreds;
+#endif
gded = snd(gded);
- check(line,fst(gded),NIL,guard,typeBool,0);
- check(line,snd(gded),NIL,guarded,aVar,beta);
+ spCheck(line,fst(gded),NIL,guard,typeBool,0);
+ spCheck(line,snd(gded),NIL,guarded,aVar,beta);
}
Cell rhsExpr(rhs) /* find first expression on a rhs */
Cell rhs; {
+ STACK_CHECK
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);
}
}
Int rhsLine(rhs) /* find line number associated with */
Cell rhs; { /* a right hand side */
+ STACK_CHECK
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;
static Bool local equalTypes(t1,t2) /* Compare simple types for equality*/
Type t1, t2; {
-
+ STACK_CHECK
et: if (whatIs(t1)!=whatIs(t2))
return FALSE;
type = typeIs;
beta = typeOff;
clearMarks();
+ improve(0,NIL,preds);
normPreds(0);
elimTauts();
preds = scSimplify(preds);
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)));
Type rng = NIL; /* Inferred range */
Cell nv = inventVar();
List alts = NIL;
- Int o;
- Int m;
+ Int o = 0; /* bogus init to keep gcc -O happy */
+ Int m = 0; /* bogus init to keep gcc -O happy */
#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:
- * ------------------------------------------------------------------------*/
-
-static Type local basicType Args((Char));
/* --------------------------------------------------------------------------
- *
+ * Local function prototypes:
* ------------------------------------------------------------------------*/
-List 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 */
+static Type local basicType ( Char );
- case EXIST :
- case RANK2 : return offsetTyvarsIn(snd(snd(t)),vs);
-
- default : return vs;
- }
-}
static Type stateVar = NIL;
static Type alphaVar = NIL;
static Type betaVar = NIL;
+static Type gammaVar = NIL;
+static Type deltaVar = NIL;
static Int nextVar = 0;
static Void clearTyVars( void )
stateVar = NIL;
alphaVar = NIL;
betaVar = NIL;
+ gammaVar = NIL;
+ deltaVar = NIL;
nextVar = 0;
}
return betaVar;
}
+static Type mkGammaVar( void )
+{
+ if (isNull(gammaVar)) {
+ gammaVar = mkOffset(nextVar++);
+ }
+ return gammaVar;
+}
+
+static Type mkDeltaVar( void )
+{
+ if (isNull(deltaVar)) {
+ deltaVar = mkOffset(nextVar++);
+ }
+ return deltaVar;
+}
+
static Type local basicType(k)
Char k; {
switch (k) {
return typeChar;
case INT_REP:
return typeInt;
-#ifdef PROVIDE_INT64
- case INT64_REP:
- return typeInt64;
-#endif
-#ifdef PROVIDE_INTEGER
case INTEGER_REP:
return typeInteger;
-#endif
-#ifdef PROVIDE_ADDR
case ADDR_REP:
return typeAddr;
-#endif
-#ifdef PROVIDE_WORD
case WORD_REP:
return typeWord;
-#endif
case FLOAT_REP:
return typeFloat;
case DOUBLE_REP:
return typeDouble;
-#ifdef PROVIDE_ARRAY
- case ARR_REP: return ap(typePrimArray,mkAlphaVar());
- case BARR_REP: return typePrimByteArray;
- case REF_REP: return ap2(typeRef,mkStateVar(),mkAlphaVar());
- case MUTARR_REP: return ap2(typePrimMutableArray,mkStateVar(),mkAlphaVar());
- case MUTBARR_REP: return ap(typePrimMutableByteArray,mkStateVar());
-#endif
-#ifdef PROVIDE_STABLE
+ case ARR_REP:
+ return ap(typePrimArray,mkAlphaVar());
+ case BARR_REP:
+ return typePrimByteArray;
+ case REF_REP:
+ return ap2(typeRef,mkStateVar(),mkAlphaVar());
+ case MUTARR_REP:
+ return ap2(typePrimMutableArray,mkStateVar(),mkAlphaVar());
+ case MUTBARR_REP:
+ return ap(typePrimMutableByteArray,mkStateVar());
case STABLE_REP:
return ap(typeStable,mkAlphaVar());
-#endif
#ifdef PROVIDE_WEAK
case WEAK_REP:
return ap(typeWeak,mkAlphaVar());
case FOREIGN_REP:
return typeForeign;
#endif
-#ifdef PROVIDE_CONCURRENT
case THREADID_REP:
return typeThreadId;
case MVAR_REP:
return ap(typeMVar,mkAlphaVar());
-#endif
case BOOL_REP:
return typeBool;
case HANDLER_REP:
return mkAlphaVar(); /* polymorphic */
case BETA_REP:
return mkBetaVar(); /* polymorphic */
+ case GAMMA_REP:
+ return mkGammaVar(); /* polymorphic */
+ case DELTA_REP:
+ return mkDeltaVar(); /* 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:
assert(length(tvars) == nextVar);
r = mkPolyType(simpleKind(length(tvars)),r);
}
-#if DEBUG_CODE
- if (debugCode) {
- printType(stdout,r); printf("\n");
- }
-#endif
return r;
}
* 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) {
case RESET : tcMode = EXPRESSION;
+ daSccs = NIL;
preds = NIL;
pendingBtyvs = NIL;
+ daSccs = NIL;
emptyAssumption();
break;
mark(depends);
mark(pendingBtyvs);
mark(skolVars);
+ mark(localEvs);
+ mark(savedPs);
mark(dummyVar);
+ mark(daSccs);
mark(preds);
mark(stdDefaults);
mark(arrow);
mark(predIntegral);
mark(starToStar);
mark(predMonad);
- mark(predMonad0);
+ mark(typeProgIO);
break;
- case INSTALL : typeChecker(RESET);
- dummyVar = inventVar();
- starToStar = simpleKind(1);
- typeVarToVar = fn(aVar,aVar);
- break;
+ case POSTPREL:
+
+ if (combined) {
+ setCurrModule(modulePrelude);
+ dummyVar = inventVar();
+ typeUnit = mkTuple(0);
+ arrow = fn(aVar,bVar);
+ listof = ap(typeList,aVar);
+ boundPair = ap(ap(mkTuple(2),aVar),aVar);
+ nameUnit = findQualNameWithoutConsultingExportList
+ (mkQVar(findText("PrelBase"),
+ findText("()")));
+ typeVarToVar = fn(aVar,aVar);
+ }
+ break;
+
+ case PREPREL :
+ typeChecker(RESET);
+
+ if (combined) {
+ Module m = findFakeModule(findText("PrelBase"));
+ setCurrModule(m);
+
+ starToStar = simpleKind(1);
+ typeList = addPrimTycon(findText("[]"),
+ starToStar,1,
+ DATATYPE,NIL);
+
+ listof = ap(typeList,aVar);
+ nameNil = addPrimCfun(findText("[]"),0,1,
+ mkPolyType(starToStar,
+ listof));
+ nameCons = addPrimCfun(findText(":"),2,2,
+ mkPolyType(starToStar,
+ fn(aVar,
+ fn(listof,
+ listof))));
+ name(nameNil).parent =
+ name(nameCons).parent = typeList;
+
+ name(nameCons).syntax
+ = mkSyntax(RIGHT_ASS,5);
+
+ tycon(typeList).defn
+ = cons(nameNil,cons(nameCons,NIL));
+
+ } else {
+ dummyVar = inventVar();
+
+ setCurrModule(modulePrelPrim);
+
+ starToStar = simpleKind(1);
+
+ typeUnit = findTycon(findText("()"));
+ assert(nonNull(typeUnit));
+
+ 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(nameNil).parent =
+ name(nameCons).parent = typeList;
+
+ 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
+ }
+ break;
+
}
}
projects / ghc-hetmet.git / blobdiff