* included in the distribution.
*
* $RCSfile: derive.c,v $
- * $Revision: 1.9 $
- * $Date: 1999/11/12 17:32:38 $
+ * $Revision: 1.15 $
+ * $Date: 2000/04/27 16:35:29 $
* ------------------------------------------------------------------------*/
-#include "prelude.h"
+#include "hugsbasictypes.h"
#include "storage.h"
-#include "backend.h"
#include "connect.h"
#include "errors.h"
+
+#include "Rts.h" /* to make StgPtr visible in Assembler.h */
#include "Assembler.h"
-#include "link.h"
List cfunSfuns; /* List of (Cfun,[SelectorVar]) */
* local function prototypes:
* ------------------------------------------------------------------------*/
-static List local getDiVars Args((Int));
-static Cell local mkBind Args((String,List));
-static Cell local mkVarAlts Args((Int,Cell));
-static List local makeDPats2 Args((Cell,Int));
-static Bool local isEnumType Args((Tycon));
-static Pair local mkAltEq Args((Int,List));
-static Pair local mkAltOrd Args((Int,List));
-static Cell local prodRange Args((Int,List,Cell,Cell,Cell));
-static Cell local prodIndex Args((Int,List,Cell,Cell,Cell));
-static Cell local prodInRange Args((Int,List,Cell,Cell,Cell));
-static List local mkIxBinds Args((Int,Cell,Int));
-static Cell local mkAltShow Args((Int,Cell,Int));
-static Cell local showsPrecRhs Args((Cell,Cell,Int));
-static Cell local mkReadCon Args((Name,Cell,Cell));
-static Cell local mkReadPrefix Args((Cell));
-static Cell local mkReadInfix Args((Cell));
-static Cell local mkReadTuple Args((Cell));
-static Cell local mkReadRecord Args((Cell,List));
-static List local mkBndBinds Args((Int,Cell,Int));
+static List local getDiVars ( Int );
+static Cell local mkBind ( String,List );
+static Cell local mkVarAlts ( Int,Cell );
+static List local makeDPats2 ( Cell,Int );
+static Bool local isEnumType ( Tycon );
+static Pair local mkAltEq ( Int,List );
+static Pair local mkAltOrd ( Int,List );
+static Cell local prodRange ( Int,List,Cell,Cell,Cell );
+static Cell local prodIndex ( Int,List,Cell,Cell,Cell );
+static Cell local prodInRange ( Int,List,Cell,Cell,Cell );
+static List local mkIxBinds ( Int,Cell,Int );
+static Cell local mkAltShow ( Int,Cell,Int );
+static Cell local showsPrecRhs ( Cell,Cell,Int );
+static Cell local mkReadCon ( Name,Cell,Cell );
+static Cell local mkReadPrefix ( Cell );
+static Cell local mkReadInfix ( Cell );
+static Cell local mkReadTuple ( Cell );
+static Cell local mkReadRecord ( Cell,List );
+static List local mkBndBinds ( Int,Cell,Int );
/* --------------------------------------------------------------------------
* constructors in the datatype definition.
* ------------------------------------------------------------------------*/
-static Pair local mkAltEq Args((Int,List));
+static Pair local mkAltEq ( Int,List );
List deriveEq(t) /* generate binding for derived == */
Type t; { /* for some TUPLE or DATATYPE t */
}
-static Pair local mkAltOrd Args((Int,List));
+static Pair local mkAltOrd ( Int,List );
List deriveOrd(t) /* make binding for derived compare*/
Type t; { /* for some TUPLE or DATATYPE t */
implementTagToCon(t);
return cons(mkBind("toEnum", mkVarAlts(l,tycon(t).tagToCon)),
cons(mkBind("fromEnum", mkVarAlts(l,tycon(t).conToTag)),
- cons(mkBind("enumFrom", singleton(pair(singleton(x),
- pair(mkInt(l),
- ap2(nameFromTo,x,last))))),
- /* default instance of enumFromTo is good */
- cons(mkBind("enumFromThen",singleton(pair(doubleton(x,y),
- pair(mkInt(l),
- ap3(nameFromThenTo,x,y,
- ap(COND,triple(ap2(nameLe,x,y),
- last,first))))))),
- /* default instance of enumFromThenTo is good */
- NIL))));
+ NIL));
}
-static List local mkIxBindsEnum Args((Tycon));
-static List local mkIxBinds Args((Int,Cell,Int));
-static Cell local prodRange Args((Int,List,Cell,Cell,Cell));
-static Cell local prodIndex Args((Int,List,Cell,Cell,Cell));
-static Cell local prodInRange Args((Int,List,Cell,Cell,Cell));
+static List local mkIxBindsEnum ( Tycon );
+static List local mkIxBinds ( Int,Cell,Int );
+static Cell local prodRange ( Int,List,Cell,Cell,Cell );
+static Cell local prodIndex ( Int,List,Cell,Cell,Cell );
+static Cell local prodInRange ( Int,List,Cell,Cell,Cell );
List deriveIx(t) /* Construct definition of indexing */
Tycon t; {
alts = cons(mkStgCaseAlt(c,vs,tag),alts);
}
- name(nm).line = tycon(t).line;
- name(nm).type = conToTagType(t);
- name(nm).arity = 1;
- name(nm).stgVar = mkStgVar(mkStgLambda(singleton(v),mkStgCase(v,alts)),
- NIL);
+ name(nm).line = tycon(t).line;
+ name(nm).type = conToTagType(t);
+ name(nm).arity = 1;
+ name(nm).closure = mkStgVar(mkStgLambda(singleton(v),mkStgCase(v,alts)),
+ NIL);
tycon(t).conToTag = nm;
- /* hack to make it print out */
- stgGlobals = cons(pair(nm,name(nm).stgVar),stgGlobals);
+ addToCodeList ( currentModule, nm );
}
}
alts = cons(mkStgPrimAlt(singleton(pat),c),alts);
}
- name(nm).line = tycon(t).line;
- name(nm).type = tagToConType(t);
- name(nm).arity = 1;
- name(nm).stgVar = mkStgVar(
- mkStgLambda(
- singleton(v1),
- mkStgCase(
- v1,
- singleton(
- mkStgCaseAlt(
- nameMkI,
- singleton(v2),
- mkStgPrimCase(v2,alts))))),
- NIL
- );
+ name(nm).line = tycon(t).line;
+ name(nm).type = tagToConType(t);
+ name(nm).arity = 1;
+ name(nm).closure = mkStgVar(
+ mkStgLambda(
+ singleton(v1),
+ mkStgCase(
+ v1,
+ singleton(
+ mkStgCaseAlt(
+ nameMkI,
+ singleton(v2),
+ mkStgPrimCase(v2,alts))))),
+ NIL
+ );
tycon(t).tagToCon = nm;
- /* hack to make it print out */
- stgGlobals = cons(pair(nm,name(nm).stgVar),stgGlobals);
+ addToCodeList ( currentModule, nm );
}
}
Void deriveControl(what)
Int what; {
switch (what) {
- case INSTALL :
- /* deliberate fall through */
+ case PREPREL :
case RESET :
diVars = NIL;
diNum = 0;
mark(diVars);
mark(cfunSfuns);
break;
+
+ case POSTPREL: break;
}
}