-#if EVAL_INSTANCES
-/* --------------------------------------------------------------------------
- * The following code is used in calculating contexts for the automatically
- * derived Eval instances for newtype and restricted type synonyms. This is
- * ugly code, resulting from an ugly feature in the language, and I hope that
- * the feature, and hence the code, will be removed in the not too distant
- * future.
- * ------------------------------------------------------------------------*/
-
-static Void local deriveEval(tcs) /* Derive instances of Eval */
-List tcs; {
- List ts1 = tcs;
- List ts = NIL;
- for (; nonNull(ts1); ts1=tl(ts1)) { /* Build list of rsyns and newtypes*/
- Tycon t = hd(ts1); /* and derive instances for data */
- switch (whatIs(tycon(t).what)) {
- case DATATYPE : addEvalInst(tycon(t).line,t,tycon(t).arity,NIL);
- break;
- case NEWTYPE :
- case RESTRICTSYN : ts = cons(t,ts);
- break;
- }
- }
- emptySubstitution(); /* then derive other instances */
- while (nonNull(ts)) {
- ts = calcEvalContexts(hd(ts),tl(ts),NIL);
- }
- emptySubstitution();
-
- for (; nonNull(tcs); tcs=tl(tcs)) { /* Check any banged components */
- Tycon t = hd(tcs);
- if (whatIs(tycon(t).what)==DATATYPE) {
- List cs = tycon(t).defn;
- for (; hasCfun(cs); cs=tl(cs)) {
- Name c = hd(cs);
- if (isPair(name(c).defn)) {
- Type t = name(c).type;
- List scs = fst(name(c).defn);
- Kinds ks = NIL;
- List ctxt = NIL;
- Int n = 1;
- if (isPolyType(t)) {
- ks = polySigOf(t);
- t = monotypeOf(t);
- }
- if (whatIs(t)==QUAL) {
- ctxt = fst(snd(t));
- t = snd(snd(t));
- }
- for (; nonNull(scs); scs=tl(scs)) {
- Int i = intOf(hd(scs));
- for (; n<i; n++) {
- t = arg(t);
- }
- checkBanged(c,ks,ctxt,arg(fun(t)));
- }
- }
- }
- }
- }
-}
-
-static List local calcEvalContexts(tc,ts,ps)
-Tycon tc; /* Worker code for deriveEval */
-List ts; /* ts = not visited, ps = visiting */
-List ps; {
- Cell ctxt = NIL;
- Int o = newKindedVars(tycon(tc).kind);
- Type t = tycon(tc).defn;
- Int i;
-
- if (whatIs(tycon(tc).what)==NEWTYPE) {
- t = name(hd(t)).type;
- if (isPolyType(t)) {
- t = monotypeOf(t);
- }
- if (whatIs(t)==QUAL) {
- t = snd(snd(t));
- }
- if (whatIs(t)==EXIST) { /* No instance if existentials used*/
- return ts;
- }
- if (whatIs(t)==RANK2) { /* No instance if arg is poly/qual */
- return ts;
- }
- t = arg(fun(t));
- }
-
- clearMarks(); /* Make sure generics are marked */
- for (i=0; i<tycon(tc).arity; i++) { /* in the correct order. */
- copyTyvar(o+i);
- }
-
- for (;;) {
- Type h = getDerefHead(t,o);
- if (isSynonym(h) && argCount>=tycon(h).arity) {
- expandSyn(h,argCount,&t,&o);
- } else if (isOffset(h)) { /* Stop if var at head */
- ctxt = singleton(ap(classEval,copyType(t,o)));
- break;
- } else if (isTuple(h) /* Check for tuples ... */
- || h==tc /* ... direct recursion */
- || cellIsMember(h,ps) /* ... mutual recursion */
- || tycon(h).what==DATATYPE) {/* ... or datatype. */
- break; /* => empty context */
- } else {
- Cell pi = ap(classEval,t);
- Inst in;
-
- if (cellIsMember(h,ts)) { /* Not yet visited? */
- ts = calcEvalContexts(h,removeCell(h,ts),cons(h,ts));
- }
-<<<<<<<<<<<<<< variant A
->>>>>>>>>>>>>> variant B
-
-======= end of combination
- if (nonNull(in=findInstFor(pi,o))) {/* Look for Eval instance */
- List qs = inst(in).specifics;
- Int o1 = typeOff;
- if (isNull(qs)) { /* No context there */
- break; /* => empty context here */
- }
- if (isNull(tl(qs)) && classEval==fun(hd(qs))) {
- t = arg(hd(qs));
- o = o1;
- continue;
- }
- }
- return ts; /* No instance, so give up */
- }
- }
- addEvalInst(tycon(tc).line,tc,tycon(tc).arity,ctxt);
- return ts;
-}
-
-static Void local checkBanged(c,ks,ps,ty)
-Name c; /* Check that banged component of c */
-Kinds ks; /* with type ty is an instance of */
-List ps; /* Eval under the predicates in ps. */
-Type ty; { /* (All types using ks) */
- Cell pi = ap(classEval,ty);
- if (isNull(provePred(ks,ps,pi))) {
- ERRMSG(name(c).line) "Illegal datatype strictness annotation:" ETHEN
- ERRTEXT "\n*** Constructor : " ETHEN ERREXPR(c);
- ERRTEXT "\n*** Context : " ETHEN ERRCONTEXT(ps);
- ERRTEXT "\n*** Required : " ETHEN ERRPRED(pi);
- ERRTEXT "\n"
- EEND;
- }
-}
-#endif
-