* Hugs version 1.4, December 1997
*
* $RCSfile: interface.c,v $
- * $Revision: 1.45 $
- * $Date: 2000/04/05 09:22:28 $
+ * $Revision: 1.49 $
+ * $Date: 2000/04/07 16:25:19 $
* ------------------------------------------------------------------------*/
#include "hugsbasictypes.h"
* Data declarations
* ------------------------------------------------------------------------*/
+static Type qualifyIfaceType ( Type unqual, List ctx )
+{
+ /* ctx :: [((QConId,VarId))] */
+ /* ctx is a list of (class name, tyvar) pairs.
+ Attach to unqual qualifiers taken from ctx
+ for each tyvar which appears in unqual.
+ */
+ List tyvarsMentioned; /* :: [VarId] */
+ List ctx2 = NIL;
+ Cell kinds = NIL;
+
+ if (isPolyType(unqual)) {
+ kinds = polySigOf(unqual);
+ unqual = monotypeOf(unqual);
+ }
+
+ assert(!isQualType(unqual));
+ tyvarsMentioned = ifTyvarsIn ( unqual );
+ for (; nonNull(ctx); ctx=tl(ctx)) {
+ ZPair ctxElem = hd(ctx); /* :: ((QConId, VarId)) */
+ if (nonNull(varIsMember(textOf(zsnd(ctxElem)),tyvarsMentioned)))
+ ctx2 = cons(ctxElem, ctx2);
+ }
+ if (nonNull(ctx2))
+ unqual = ap(QUAL,pair(reverse(ctx2),unqual));
+ if (nonNull(kinds))
+ unqual = mkPolyType(kinds,unqual);
+ return unqual;
+}
+
+
static Void startGHCDataDecl(line,ctx0,tycon,ktyvars,constrs0)
Int line;
List ctx0; /* [((QConId,VarId))] */
*/
{
Type ty, resTy, selTy, conArgTy;
- List tmp, conArgs, sels, constrs, fields, tyvarsMentioned;
- List ctx, ctx2;
+ List tmp, conArgs, sels, constrs, fields;
Triple constr;
Cell conid;
Pair conArg, ctxElem;
Text conArgNm;
Int conArgStrictness;
+ Int conStrictCompCount;
Text t = textOf(tycon);
# ifdef DEBUG_IFACE
conid = zfst(constr);
fields = zsnd(constr);
- /* Build type of constr and handle any selectors found.
- Also collect up tyvars occurring in the constr's arg
- types, so we can throw away irrelevant parts of the
- context later.
- */
+ /* Build type of constr and handle any selectors found. */
ty = resTy;
- tyvarsMentioned = NIL;
- /* tyvarsMentioned :: [VarId] */
+ conStrictCompCount = 0;
conArgs = reverse(fields);
for (; nonNull(conArgs); conArgs=tl(conArgs)) {
conArg = hd(conArgs); /* (Type,Text) */
conArgTy = zfst3(conArg);
conArgNm = zsnd3(conArg);
conArgStrictness = intOf(zthd3(conArg));
- tyvarsMentioned = dupListOnto(ifTyvarsIn(conArgTy),
- tyvarsMentioned);
- /* Not sure what the deal is with strictness. Do we need
- to notify the symbol table, or not? The Hugs desugarer?
- Currently disabled. */
- /* if (conArgStrictness > 0) conArgTy = bang(conArgTy); */
+ if (conArgStrictness > 0) conStrictCompCount++;
ty = fn(conArgTy,ty);
if (nonNull(conArgNm)) {
/* a field name is mentioned too */
selTy = fn(resTy,conArgTy);
if (whatIs(tycon(tc).kind) != STAR)
selTy = pair(POLYTYPE,pair(tycon(tc).kind, selTy));
+ selTy = qualifyIfaceType ( selTy, ctx0 );
selTy = tvsToOffsets(line,selTy, ktyvars);
sels = cons( zpair(conArgNm,selTy), sels);
}
}
/* Now ty is the constructor's type, not including context.
- Throw away any parts of the context not mentioned in
- tyvarsMentioned, and use it to qualify ty.
+ Throw away any parts of the context not mentioned in ty,
+ and use it to qualify ty.
*/
- ctx2 = NIL;
- for (ctx=ctx0; nonNull(ctx); ctx=tl(ctx)) {
- ctxElem = hd(ctx);
- /* ctxElem :: ((QConId,VarId)) */
- if (nonNull(cellIsMember(textOf(zsnd(ctxElem)),tyvarsMentioned)))
- ctx2 = cons(ctxElem, ctx2);
- }
- if (nonNull(ctx2))
- ty = ap(QUAL,pair(ctx2,ty));
+ ty = qualifyIfaceType ( ty, ctx0 );
/* stick the tycon's kind on, if not simply STAR */
if (whatIs(tycon(tc).kind) != STAR)
ty = tvsToOffsets(line,ty, ktyvars);
/* Finally, stick the constructor's type onto it. */
- hd(constrs) = ztriple(conid,fields,ty);
+ hd(constrs) = z4ble(conid,fields,ty,mkInt(conStrictCompCount));
}
/* Final result is that
- constrs :: [((ConId,[((Type,Text))],Type))]
- lists the constructors and their types
+ constrs :: [((ConId,[((Type,Text))],Type,Int))]
+ lists the constructors, their types and # strict comps
sels :: [((VarId,Type))]
lists the selectors and their types
*/
static List startGHCConstrs ( Int line, List cons, List sels )
{
- /* cons :: [((ConId,[((Type,Text,Int))],Type))] */
- /* sels :: [((VarId,Type))] */
- /* returns [Name] */
+ /* cons :: [((ConId,[((Type,Text,Int))],Type,Int))] */
+ /* sels :: [((VarId,Type))] */
+ /* returns [Name] */
List cs, ss;
Int conNo = length(cons)>1 ? 1 : 0;
for(cs=cons; nonNull(cs); cs=tl(cs), conNo++) {
}
-static Name startGHCConstr ( Int line, Int conNo, ZTriple constr )
+static Name startGHCConstr ( Int line, Int conNo, Z4Ble constr )
{
- /* constr :: ((ConId,[((Type,Text,Int))],Type)) */
+ /* constr :: ((ConId,[((Type,Text,Int))],Type,Int)) */
/* (ADR) ToDo: add rank2 annotation and existential annotation
* these affect how constr can be used.
*/
- Text con = textOf(zfst3(constr));
- Type type = zthd3(constr);
- Int arity = arityFromType(type);
+ Text con = textOf(zsel14(constr));
+ Type type = zsel34(constr);
+ Int arity = arityFromType(type);
+ Int nStrict = intOf(zsel44(constr));
Name n = findName(con); /* Allocate constructor fun name */
if (isNull(n)) {
n = newName(con,NIL);
textToStr(con)
EEND;
}
- name(n).arity = arity; /* Save constructor fun details */
- name(n).line = line;
- name(n).number = cfunNo(conNo);
- name(n).type = type;
+ name(n).arity = arity; /* Save constructor fun details */
+ name(n).line = line;
+ name(n).number = cfunNo(conNo);
+ name(n).type = type;
+ name(n).hasStrict = nStrict > 0;
return n;
}
SymX(chdir) \
SymX(execl) \
Sym(waitpid) \
- SymX(getenv)
+ SymX(getenv) \
+ Sym(chmod)
#define EXTERN_SYMS_cygwin32 \
SymX(GetCurrentProcess) \
t = unZcodeThenFindText(nm2+first_real_char+7);
if (t == findText("PrelGHC")) return (4+NULL); /* kludge */
m = findModule(t);
- if (isNull(m)) goto not_found;
+ if (isNull(m)) goto dire_straits;
a = lookupOTabName ( m, nm );
if (a) return a;
- goto not_found;
+ goto dire_straits;
}
/* if not an RTS name, look in the
relevant module's object symbol table
*/
pp = strchr(nm2+first_real_char, '_');
- if (!pp || !isupper(nm2[first_real_char])) goto not_found;
+ if (!pp || !isupper(nm2[first_real_char])) goto dire_straits;
*pp = 0;
t = unZcodeThenFindText(nm2+first_real_char);
m = findModule(t);
- if (isNull(m)) goto not_found;
+ if (isNull(m)) goto dire_straits;
a = lookupOTabName ( m, nm ); /* RATIONALISE */
if (a) return a;
- not_found:
+ dire_straits:
+ /* make a desperate, last-ditch attempt to find it */
+ a = lookupOTabNameAbsolutelyEverywhere ( nm );
+ if (a) return a;
+
fprintf ( stderr,
"lookupObjName: can't resolve name `%s'\n",
nm );
- assert(4-4);
+ assert(0);
return NULL;
}
projects / ghc-hetmet.git / blobdiff