[project @ 1999-11-24 10:38:10 by andy]

[ghc-hetmet.git] / ghc / interpreter / type.c

diff --git a/ghc/interpreter/type.c b/ghc/interpreter/type.c
index 9ec97c5..cd4529f 100644 (file)
--- a/ghc/interpreter/type.c
+++ b/ghc/interpreter/type.c
@@ -9,8 +9,8 @@
  * included in the distribution.
  *
  * $RCSfile: type.c,v $
- * $Revision: 1.10 $
- * $Date: 1999/10/16 02:17:26 $
+ * $Revision: 1.16 $
+ * $Date: 1999/11/23 15:12:06 $
  * ------------------------------------------------------------------------*/
 
 #include "prelude.h"
@@ -68,7 +68,6 @@ 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 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));
@@ -1325,9 +1324,7 @@ Cell e; {                               /* bizarre manner for the benefit  */
 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;
@@ -1748,7 +1745,6 @@ Class c; {                                /* defaults for class c            */
     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;
@@ -1825,7 +1821,6 @@ Class c; {                                /* defaults for class c            */
        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)) {
@@ -1885,9 +1880,29 @@ Inst in; {                              /* member functions for instance in*/
 
     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
@@ -1930,8 +1945,6 @@ Inst in; {                              /* member functions for instance in*/
     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;
     genDefns = cons(inst(in).builder,genDefns);
 }
 
@@ -2378,8 +2391,8 @@ Name s; {                               /* particular selector, s.         */
     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));
@@ -2491,6 +2504,7 @@ 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 )
@@ -2499,6 +2513,7 @@ static Void clearTyVars( void )
     alphaVar = NIL;
     betaVar  = NIL;
     gammaVar = NIL;
+    deltaVar = NIL;
     nextVar  = 0;
 }
 
@@ -2534,6 +2549,14 @@ static Type mkGammaVar( void )
     return gammaVar;
 }
 
+static Type mkDeltaVar( void )
+{
+    if (isNull(deltaVar)) {
+        deltaVar = mkOffset(nextVar++);
+    }
+    return deltaVar;
+}
+
 static Type local basicType(k)
 Char k; {
     switch (k) {
@@ -2551,12 +2574,18 @@ Char 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());
@@ -2567,12 +2596,10 @@ Char k; {
     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:
@@ -2585,6 +2612,8 @@ Char k; {
             return mkBetaVar();   /* polymorphic */
     case GAMMA_REP:
             return mkGammaVar();  /* polymorphic */
+    case DELTA_REP:
+            return mkDeltaVar();  /* polymorphic */
     default:
             printf("Kind: '%c'\n",k);
             internal("basicType");
@@ -2719,6 +2748,7 @@ Int what; {
                        mark(predIntegral);
                        mark(starToStar);
                        mark(predMonad);
+                      mark(typeProgIO);
                        break;
 
         case INSTALL : typeChecker(RESET);