* included in the distribution.
*
* $RCSfile: compiler.c,v $
- * $Revision: 1.25 $
- * $Date: 2000/03/24 14:32:03 $
+ * $Revision: 1.26 $
+ * $Date: 2000/04/06 14:23:55 $
* ------------------------------------------------------------------------*/
#include "hugsbasictypes.h"
}
case DICTVAR : /* shouldn't really occur */
- assert(0); /* so let's test for it then! ADR */
+ //assert(0); /* so let's test for it then! ADR */
case VARIDCELL :
case VAROPCELL : return addEqn(pat,expr,lds);
/* intentional fall-thru */
case TUPLE : { List ps = getArgs(pat);
+ /* get rid of leading dictionaries in args */
+ if (isName(c) && isCfun(c)) {
+ Int i = numQualifiers(name(c).type);
+ for (; i > 0; i--) ps = tl(ps);
+ }
+
if (nonNull(ps)) {
Cell nv, sel;
Int i;
-
if (isVar(expr) || isName(expr))
nv = expr;
else {
* included in the distribution.
*
* $RCSfile: storage.c,v $
- * $Revision: 1.64 $
- * $Date: 2000/04/06 00:01:27 $
+ * $Revision: 1.65 $
+ * $Date: 2000/04/06 14:23:55 $
* ------------------------------------------------------------------------*/
#include "hugsbasictypes.h"
newTab[i].inUse = FALSE; \
newTab[i].nextFree = i-1+TAB_BASE_ADDR; \
} \
- if (debugStorageExtra) \
+ if (0 && debugStorageExtra) \
fprintf(stderr, "Expanding " #type_name \
"table to size %d\n", newSz ); \
newTab[tab_size].nextFree = TAB_BASE_ADDR-1; \
return xs;
}
+Int numQualifiers ( Type t )
+{
+ if (isPolyType(t)) t = monotypeOf(t);
+ if (isQualType(t))
+ return length ( fst(snd(t)) ); else
+ return 0;
+}
+
+
/* Purely for debugging. */
void locateSymbolByName ( Text t )
{
everybody(GCDONE);
#if defined(DEBUG_STORAGE) || defined(DEBUG_STORAGE_EXTRA)
- fprintf(stderr, "\n--- GC recovered %d\n",recovered );
+ /* fprintf(stderr, "\n--- GC recovered %d\n",recovered ); */
#endif
/* can only return if freeList is nonempty on return. */
* included in the distribution.
*
* $RCSfile: storage.h,v $
- * $Revision: 1.40 $
- * $Date: 2000/04/05 16:57:18 $
+ * $Revision: 1.41 $
+ * $Date: 2000/04/06 14:23:55 $
* ------------------------------------------------------------------------*/
#define DEBUG_STORAGE /* a moderate level of sanity checking */
extern struct strTycon* tabTycon;
extern Int tabTyconSz;
-extern Tycon newTycon ( Text );
-extern Tycon findTycon ( Text );
-extern Tycon addTycon ( Tycon );
+extern Tycon newTycon ( Text );
+extern Tycon findTycon ( Text );
+extern Tycon addTycon ( Tycon );
extern Tycon findQualTycon ( Cell );
-extern Tycon addPrimTycon ( Text,Kind,Int,Cell,Cell );
+extern Tycon addPrimTycon ( Text,Kind,Int,Cell,Cell );
#define isSynonym(h) (isTycon(h) && tycon(h).what==SYNONYM)
#define isQualType(t) (isPair(t) && fst(t)==QUAL)
extern Tycon findQualTyconWithoutConsultingExportList ( QualId q );
+extern Int numQualifiers ( Type );
+
+
/* --------------------------------------------------------------------------
* Globally defined name values:
* ------------------------------------------------------------------------*/
* included in the distribution.
*
* $RCSfile: translate.c,v $
- * $Revision: 1.31 $
- * $Date: 2000/04/05 10:25:09 $
+ * $Revision: 1.32 $
+ * $Date: 2000/04/06 14:23:55 $
* ------------------------------------------------------------------------*/
#include "hugsbasictypes.h"
Void implementCfun(c,scs) /* Build implementation for constr */
Name c; /* fun c. scs lists integers (1..)*/
List scs; { /* in incr order of strict fields. */
- Int a = name(c).arity;
+ Int a = name(c).arity; /* arity, not incl dictionaries */
+ Int ad = numQualifiers(name(c).type); /* the number of dictionaries */
+ Type t = name(c).type;
- if (a > 0) {
+ /* a+ad is total arity for this fn */
+ if (a+ad > 0) {
StgVar vcurr, e1, v, vsi;
List args = makeArgs(a);
+ List argsd = makeArgs(ad);
StgVar v0 = mkStgVar(mkStgCon(c,args),NIL);
List binds = singleton(v0);
}
binds = rev(binds);
e1 = mkStgLet(binds,vcurr);
- v = mkStgVar(mkStgLambda(args,e1),NIL);
+ v = mkStgVar(mkStgLambda(dupOnto(argsd,args),e1),NIL);
name(c).stgVar = v;
} else {
StgVar v = mkStgVar(mkStgCon(c,NIL),NIL);
* included in the distribution.
*
* $RCSfile: type.c,v $
- * $Revision: 1.33 $
- * $Date: 2000/04/06 00:01:27 $
+ * $Revision: 1.34 $
+ * $Date: 2000/04/06 14:23:55 $
* ------------------------------------------------------------------------*/
#include "hugsbasictypes.h"
for (; nonNull(predsAre); predsAre=tl(predsAre)) {
evs = cons(assumeEvid(hd(predsAre),typeOff),evs);
}
- if (!isName(h) || !isCfun(h)) {
+ /* we now _always_ do this: if (!isName(h) || !isCfun(h)) */ {
h = applyToArgs(h,rev(evs));
}
}