+ * Helpers: conToTag and tagToCon
+ * ------------------------------------------------------------------------*/
+
+/* \ v -> case v of { ...; Ci _ _ -> i; ... } */
+Void implementConToTag(t)
+Tycon t; {
+ if (isNull(tycon(t).conToTag)) {
+ List cs = tycon(t).defn;
+ Name nm = newName(inventText(),NIL);
+ StgVar v = mkStgVar(NIL,NIL);
+ List alts = NIL; /* can't fail */
+
+ assert(isTycon(t) && (tycon(t).what==DATATYPE
+ || tycon(t).what==NEWTYPE));
+ for (; hasCfun(cs); cs=tl(cs)) {
+ Name c = hd(cs);
+ Int num = cfunOf(c) == 0 ? 0 : cfunOf(c)-1;
+ StgVar r = mkStgVar(mkStgCon(nameMkI,singleton(mkInt(num))),
+ NIL);
+ StgExpr tag = mkStgLet(singleton(r),r);
+ List vs = NIL;
+ Int i;
+ for(i=0; i < name(c).arity; ++i) {
+ vs = cons(mkStgVar(NIL,NIL),vs);
+ }
+ 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);
+ tycon(t).conToTag = nm;
+ /* hack to make it print out */
+ stgGlobals = cons(pair(nm,name(nm).stgVar),stgGlobals);
+ }
+}
+
+/* \ v -> case v of { ...; i -> Ci; ... } */
+Void implementTagToCon(t)
+Tycon t; {
+ if (isNull(tycon(t).tagToCon)) {
+ String tyconname;
+ List cs;
+ Name nm;
+ StgVar v1;
+ StgVar v2;
+ Cell txt0;
+ StgVar bind1;
+ StgVar bind2;
+ StgVar bind3;
+ List alts;
+ char etxt[200];
+
+ assert(nameMkA);
+ assert(nameUnpackString);
+ assert(nameError);
+ assert(isTycon(t) && (tycon(t).what==DATATYPE
+ || tycon(t).what==NEWTYPE));
+
+ tyconname = textToStr(tycon(t).text);
+ if (strlen(tyconname) > 100)
+ internal("implementTagToCon: tycon name too long");
+
+ sprintf(etxt,
+ "out-of-range arg for `toEnum' "
+ "in derived `instance Enum %s'",
+ tyconname);
+
+ cs = tycon(t).defn;
+ nm = newName(inventText(),NIL);
+ v1 = mkStgVar(NIL,NIL);
+ v2 = mkStgPrimVar(NIL,mkStgRep(INT_REP),NIL);
+
+ txt0 = mkStr(findText(etxt));
+ bind1 = mkStgVar(mkStgCon(nameMkA,singleton(txt0)),NIL);
+ bind2 = mkStgVar(mkStgApp(nameUnpackString,singleton(bind1)),NIL);
+ bind3 = mkStgVar(mkStgApp(nameError,singleton(bind2)),NIL);
+
+ alts = singleton(
+ mkStgPrimAlt(
+ singleton(
+ mkStgPrimVar(NIL,mkStgRep(INT_REP),NIL)
+ ),
+ makeStgLet ( tripleton(bind1,bind2,bind3), bind3 )
+ )
+ );
+
+ for (; hasCfun(cs); cs=tl(cs)) {
+ Name c = hd(cs);
+ Int num = cfunOf(c) == 0 ? 0 : cfunOf(c)-1;
+ StgVar pat = mkStgPrimVar(mkInt(num),mkStgRep(INT_REP),NIL);
+ assert(name(c).arity==0);
+ 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
+ );
+ tycon(t).tagToCon = nm;
+ /* hack to make it print out */
+ stgGlobals = cons(pair(nm,name(nm).stgVar),stgGlobals);
+ }
+}
+
+
+/* --------------------------------------------------------------------------
+ * Derivation control: