[project @ 1999-11-29 18:59:23 by sewardj]

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

diff --git a/ghc/interpreter/type.c b/ghc/interpreter/type.c
index 441446b..9c625e9 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.14 $
- * $Date: 1999/11/19 13:54:49 $
+ * $Revision: 1.17 $
+ * $Date: 1999/11/29 18:59:34 $
  * ------------------------------------------------------------------------*/
 
 #include "prelude.h"
@@ -1755,9 +1755,11 @@ Class c; {                               /* defaults for class c            */
     }
 
     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];
        }
@@ -1943,8 +1945,50 @@ Inst in; {                              /* member functions for instance in*/
     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)))));
+       = 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);
 }
 
@@ -2579,7 +2623,7 @@ Char k; {
     case BARR_REP:
             return typePrimByteArray;
     case REF_REP:
-            return ap(typeRef,mkAlphaVar());
+            return ap2(typeRef,mkStateVar(),mkAlphaVar());
     case MUTARR_REP:
             return ap2(typePrimMutableArray,mkStateVar(),mkAlphaVar());     
     case MUTBARR_REP:
@@ -2748,6 +2792,7 @@ Int what; {
                        mark(predIntegral);
                        mark(starToStar);
                        mark(predMonad);
+                      mark(typeProgIO);
                        break;
 
         case INSTALL : typeChecker(RESET);