Commit 4b0d52eb authored by sewardj's avatar sewardj
Browse files

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

Fix some serious errors in the handling of instances in interfaces.
parent 613c0042
......@@ -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:
......
......@@ -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)); }
;
......
......@@ -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:
......
......@@ -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 */
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment