[project @ 2000-01-05 13:53:36 by sewardj]

Fix some serious errors in the handling of instances in interfaces.

diff --git a/ghc/interpreter/interface.c b/ghc/interpreter/interface.c
index 321ec98..6d07a34 100644 (file)
--- a/ghc/interpreter/interface.c
+++ b/ghc/interpreter/interface.c
@@ -7,8 +7,8 @@
  * Hugs version 1.4, December 1997
  *
  * $RCSfile: interface.c,v $
- * $Revision: 1.14 $
- * $Date: 1999/12/20 16:55:26 $
+ * $Revision: 1.15 $
+ * $Date: 2000/01/05 13:53:36 $
  * ------------------------------------------------------------------------*/
 
 #include "prelude.h"
@@ -1794,39 +1794,55 @@ static Void finishGHCClass ( Tycon cls_tyc )
  * Instances
  * ------------------------------------------------------------------------*/
 
-Inst startGHCInstance (line,ctxt0,cls,var)
+Inst startGHCInstance (line,ktyvars,cls,var)
 Int   line;
-List  ctxt0;  /* [((QConId, VarId))] */
-Type  cls;    /* Type  */
-VarId var; {  /* VarId */
-    List tmp, tvs, ks;
+List  ktyvars; /* [((VarId,Kind))] */
+Type  cls;     /* Type  */
+VarId var; {   /* VarId */
+    List tmp, tvs, ks, spec;
+
+    List xs1, xs2;
+    Kind k;
+
     Inst in = newInst();
 #   ifdef DEBUG_IFACE
     printf ( "begin startGHCInstance\n" );
 #   endif
 
-    /* Make tvs into a list of tyvars with bogus kinds. */
-    tvs = ifTyvarsIn(cls);
-    /* tvs :: [VarId] */
+    tvs = ifTyvarsIn(cls);  /* :: [VarId] */
+    /* tvs :: [VarId].
+       The order of tvs is important for tvsToOffsets.
+       tvs should be a permutation of ktyvars.  Fish the tyvar kinds
+       out of ktyvars and attach them to tvs.
+    */
+    for (xs1=tvs; nonNull(xs1); xs1=tl(xs1)) {
+       k = NIL;
+       for (xs2=ktyvars; nonNull(xs2); xs2=tl(xs2))
+          if (textOf(hd(xs1)) == textOf(zfst(hd(xs2))))
+             k = zsnd(hd(xs2));
+       if (isNull(k)) internal("startGHCInstance: finding kinds");
+       hd(xs1) = zpair(hd(xs1),k);
+    }
 
-    ks = NIL;
-    for (tmp = tvs; nonNull(tmp); tmp=tl(tmp)) {
-       hd(tmp) = zpair(hd(tmp),STAR);
-       ks = cons(STAR,ks);
+    cls = tvsToOffsets(line,cls,tvs);
+    spec = NIL;
+    while (isAp(cls)) {
+       spec = cons(fun(cls),spec);
+       cls  = arg(cls);
     }
-    /* tvs :: [((VarId,STAR))] */
+    spec = reverse(spec);
+
     inst(in).line         = line;
     inst(in).implements   = NIL;
-    inst(in).kinds        = ks;
-    inst(in).specifics    = tvsToOffsets(line,ctxt0,tvs);
-    inst(in).numSpecifics = length(ctxt0);
-    inst(in).head         = tvsToOffsets(line,cls,tvs);
+    inst(in).kinds        = simpleKind(length(tvs)); /* do this right */
+    inst(in).specifics    = spec;
+    inst(in).numSpecifics = length(spec);
+    inst(in).head         = cls;
 
     /* Figure out the name of the class being instanced, and store it
        at inst(in).c.  finishGHCInstance will resolve it to a real Class. */
     { 
        Cell cl = inst(in).head;
-       while (isAp(cl)) cl = arg(cl);
        assert(whatIs(cl)==DICTAP);
        cl = unap(DICTAP,cl);       
        cl = fst(cl);
@@ -2024,8 +2040,19 @@ static Type conidcellsToTycons ( Int line, Type type )
       case QUAL:
          return pair(QUAL,pair(conidcellsToTycons(line,fst(snd(type))),
                                conidcellsToTycons(line,snd(snd(type)))));
-      case DICTAP: /* bogus?? */
-         return ap(DICTAP, conidcellsToTycons(line, snd(type)));
+      case DICTAP: /* :: ap(DICTAP, pair(Class,[Type]))
+                      Not sure if this is really the right place to
+                      convert it to the form Hugs wants, but will do so anyway.
+                    */
+         /* return ap(DICTAP, conidcellsToTycons(line, snd(type))); */
+       {
+           Class cl   = fst(unap(DICTAP,type));
+           List  args = snd(unap(DICTAP,type));
+           if (length(args) != 1) 
+              internal("conidcellsToTycons: DICTAP: multiparam ap");
+           return
+              conidcellsToTycons(line,pair(cl,hd(args)));
+        }
       case UNBOXEDTUP:
          return ap(UNBOXEDTUP, conidcellsToTycons(line, snd(type)));
       case BANG:

diff --git a/ghc/interpreter/parser.y b/ghc/interpreter/parser.y
index 694dd16..9258670 100644 (file)
--- a/ghc/interpreter/parser.y
+++ b/ghc/interpreter/parser.y
@@ -12,8 +12,8 @@
  * included in the distribution.
  *
  * $RCSfile: parser.y,v $
- * $Revision: 1.19 $
- * $Date: 1999/12/16 16:34:42 $
+ * $Revision: 1.20 $
+ * $Date: 2000/01/05 13:53:36 $
  * ------------------------------------------------------------------------*/
 
 %{
@@ -223,19 +223,17 @@ ifQTCName : ifTCName                    { $$ = gc1($1); }
 
 
 /*- Interface contexts ------------------------------------*/
-ifCtxInst /* __forall [a b] {M.C1 a, M.C2 b} =>  */
-          /* :: [(QConId, VarId)]                */
-          : ALL ifForall ifCtxDecl      {$$=gc3($3);}
-          | ALL ifForall IMPLIES        {$$=gc3(NIL);}
+ifCtxInst /* __forall [a b] =>     :: [((VarId,Kind))] */
+          : ALL ifForall IMPLIES        {$$=gc3($2);}
           |                             {$$=gc0(NIL);}
           ;
 ifInstHd /* { Class aType }    :: (ConId, Type) */
-          : '{' ifQCon ifAType '}'       {$$=gc4(ap(DICTAP,
-                                                 zpair($2,singleton($3))));}
+          : '{' ifQCon ifAType '}'      {$$=gc4(ap(DICTAP,
+                                                zpair($2,singleton($3))));}
           ;
 
 ifInstHdL /* { C a1 } -> { C2 a2 } -> ... -> { Cn an } :: Type */
-          : ifInstHd ARROW ifInstHdL    {$$=gc3(fn($1,$3));}
+          : ifInstHd ARROW ifInstHdL    {$$=gc3(ap($1,$3));}
           | ifInstHd                    {$$=gc1($1);}
           ;
 
@@ -332,7 +330,7 @@ ifType    : ALL ifForall ifCtxDeclT IMPLIES ifType
           | ifBType ARROW ifType        { $$ = gc3(fn($1,$3)); }
           | ifBType                     { $$ = gc1($1); }
           ;                                    
-ifForall  /* [(VarId,Kind)] */
+ifForall  /* [((VarId,Kind))] */
           : '[' ifKindedTyvarL ']'      { $$ = gc3($2); }
           ;
 
@@ -355,7 +353,7 @@ ifBType   : ifAType                     { $$ = gc1($1);        }
 ifAType   : ifQTCName                   { $$ = gc1($1); }
           | ifTyvar                     { $$ = gc1($1); }
           | '(' ')'                     { $$ = gc2(typeUnit); }
-          | '(' ifTypeL2 ')'            { $$ = gc3(buildTuple($2)); }
+          | '(' ifTypeL2 ')'            { $$ = gc3(buildTuple(reverse($2))); }
           | '[' ifType ']'              { $$ = gc3(ap(mkCon(tycon(typeList).text),
                                                       $2));}
           | '{' ifQTCName ifATypes '}'  { $$ = gc4(ap(DICTAP,
@@ -376,11 +374,11 @@ ifUsage   : '-'                         { $$ = gc1(NIL); }
 
 
 /*- Interface kinds ---------------------------------------*/
-ifKindedTyvarL /* [(VarId,Kind)] */
+ifKindedTyvarL /* [((VarId,Kind))] */
           :                              { $$ = gc0(NIL);         }
           | ifKindedTyvar ifKindedTyvarL { $$ = gc2(cons($1,$2)); }
           ;
-ifKindedTyvar /* (VarId,Kind) */
+ifKindedTyvar /* ((VarId,Kind)) */
           : ifTyvar                     { $$ = gc1(zpair($1,STAR)); }
           | ifTyvar COCO ifAKind        { $$ = gc3(zpair($1,$3));   }
           ; 

diff --git a/ghc/interpreter/storage.c b/ghc/interpreter/storage.c
index f4380ed..44d464d 100644 (file)
--- a/ghc/interpreter/storage.c
+++ b/ghc/interpreter/storage.c
@@ -9,8 +9,8 @@
  * included in the distribution.
  *
  * $RCSfile: storage.c,v $
- * $Revision: 1.28 $
- * $Date: 1999/12/20 16:55:27 $
+ * $Revision: 1.29 $
+ * $Date: 2000/01/05 13:53:37 $
  * ------------------------------------------------------------------------*/
 
 #include "prelude.h"
@@ -312,7 +312,7 @@ Text unZcodeThenFindText ( String s )
             if (*s != 'T') goto parse_error;
             s++;
             p[n++] = '(';
-            while (i > 0) { p[n++] = ','; i--; };
+            while (i >= 0) { p[n++] = ','; i--; };
             p[n++] = ')';
             break;
          default: 

diff --git a/ghc/interpreter/storage.h b/ghc/interpreter/storage.h
index b56b965..16d8523 100644 (file)
--- a/ghc/interpreter/storage.h
+++ b/ghc/interpreter/storage.h
@@ -10,8 +10,8 @@
  * included in the distribution.
  *
  * $RCSfile: storage.h,v $
- * $Revision: 1.23 $
- * $Date: 1999/12/20 16:55:28 $
+ * $Revision: 1.24 $
+ * $Date: 2000/01/05 13:53:37 $
  * ------------------------------------------------------------------------*/
 
 /* --------------------------------------------------------------------------
@@ -343,10 +343,11 @@ extern  Ptr             cptrOf          Args((Cell));
 #define I_FIXDECL    113  /* snd :: ((NIL|Int, Associativity, ConVarId))   
                                     fixity, associativity, name            */
 
-#define I_INSTANCE   114 /* snd :: ((Line, [((QConId,VarId))], 
-                                    Type, VarId, Inst))
+#define I_INSTANCE   114 /* snd :: ((Line, 
+                                     [((VarId,Kind))], 
+                                     Type, VarId, Inst))
                    lineno, 
-                   forall-y bit (eg __forall [a b] {M.C1 a, M.C2 b} =>),
+                   forall-y bit (eg __forall [a b] =>),
                    other bit, eg { C a1 } -> { C2 a2 } -> ... -> { Cn an },
                    name of dictionary builder,
                    (after startGHCInstance) the instance table location    */