From 4b0d52ebd7397842d75bab41871bcde1ab6cb9cb Mon Sep 17 00:00:00 2001
From: sewardj <unknown>
Date: Wed, 5 Jan 2000 13:53:37 +0000
Subject: [PATCH] [project @ 2000-01-05 13:53:36 by sewardj] Fix some serious
errors in the handling of instances in interfaces.
---
ghc/interpreter/interface.c | 71 +++++++++++++++++++++++++------------
ghc/interpreter/parser.y | 24 ++++++-------
ghc/interpreter/storage.c | 6 ++--
ghc/interpreter/storage.h | 11 +++---
4 files changed, 69 insertions(+), 43 deletions(-)
diff --git a/ghc/interpreter/interface.c b/ghc/interpreter/interface.c
index 321ec98aec2a..6d07a34e13c3 100644
--- 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 694dd169ba56..9258670c5799 100644
--- 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 f4380ed23937..44d464d52f65 100644
--- 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 b56b965eb262..16d852355dcc 100644
--- 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 */
--
GitLab