* included in the distribution.
*
* $RCSfile: type.c,v $
- * $Revision: 1.10 $
- * $Date: 1999/10/16 02:17:26 $
+ * $Revision: 1.23 $
+ * $Date: 2000/02/03 13:55:22 $
* ------------------------------------------------------------------------*/
#include "prelude.h"
static Cell local typeAp Args((Int,Cell));
static Type local typeExpected Args((Int,String,Cell,Type,Int,Int,Bool));
-static Type local typeExpected2 Args((Int,String,Cell,Type,Int,Int));
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 Cell local typeWith(line,e) /* Type check a with */
Int line;
Cell e; {
- static String update = "with";
List fs = snd(snd(e)); /* List of field specifications */
- List ts = NIL; /* List of types for fields */
Int n = length(fs);
Int alpha = newTyvars(2+n);
Int i;
List defs = cclass(c).defaults;
List dsels = cclass(c).dsels;
Cell pat = cclass(c).dcon;
- Cell args = NIL;
Int width = cclass(c).numSupers + cclass(c).numMembers;
char buf[FILENAME_MAX+1];
Int i = 0;
}
for (; nonNull(mems); mems=tl(mems)) {
- static String deftext = "default_";
+ /* 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];
}
name(hd(dsels)).defn = singleton(pair(pat,
ap(mkInt(cclass(c).line),
nthArg(i++,hd(pat)))));
- name(hd(dsels)).inlineMe = TRUE;
genDefns = cons(hd(dsels),genDefns);
}
for (mems=cclass(c).members; nonNull(mems); mems=tl(mems)) {
for (ps=supers; nonNull(ps); ps=tl(ps)) { /* Superclass dictionaries */
Cell pi = hd(ps);
- Cell ev = scEntail(params,fst3(pi),intOf(snd3(pi)),0);
- if (isNull(ev))
+ 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
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)))));
- name(inst(in).builder).inlineMe = TRUE;
- name(inst(in).builder).isDBuilder = TRUE;
+ = 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];
+ 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];
+ }
+ for (; nonNull(pp); pp=tl(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;
+ default: internal("typeInstDefn: making GHC name"); break;
+ }
+ for (j = 0; i<FILENAME_MAX && str[j]!='\0'; i++, j++) {
+ buf[i] = str[j];
+ }
+ }
+
+ buf[i++] = '\0';
+ name(inst(in).builder).text = findText(buf);
+ //fprintf ( stderr, "result = %s\n", buf );
+ }
+
genDefns = cons(inst(in).builder,genDefns);
}
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));
static Type alphaVar = NIL;
static Type betaVar = NIL;
static Type gammaVar = NIL;
+static Type deltaVar = NIL;
static Int nextVar = 0;
static Void clearTyVars( void )
alphaVar = NIL;
betaVar = NIL;
gammaVar = NIL;
+ deltaVar = NIL;
nextVar = 0;
}
return gammaVar;
}
+static Type mkDeltaVar( void )
+{
+ if (isNull(deltaVar)) {
+ deltaVar = mkOffset(nextVar++);
+ }
+ return deltaVar;
+}
+
static Type local basicType(k)
Char k; {
switch (k) {
return typeFloat;
case DOUBLE_REP:
return typeDouble;
- 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());
+ 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());
#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 mkBetaVar(); /* polymorphic */
case GAMMA_REP:
return mkGammaVar(); /* polymorphic */
+ case DELTA_REP:
+ return mkDeltaVar(); /* polymorphic */
default:
printf("Kind: '%c'\n",k);
internal("basicType");
Int what; {
switch (what) {
case RESET : tcMode = EXPRESSION;
-+ daSccs = NIL;
+ daSccs = NIL;
preds = NIL;
pendingBtyvs = NIL;
daSccs = NIL;
mark(predIntegral);
mark(starToStar);
mark(predMonad);
+ mark(typeProgIO);
break;
- case INSTALL : typeChecker(RESET);
- dummyVar = inventVar();
-
- setCurrModule(modulePrelude);
-
- 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(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);
+ 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(modulePrelude);
+
+ 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));
+ 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);
+ /* 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;
+ }
+ break;
+
}
}
projects / ghc-hetmet.git / blobdiff