view release on metacpan or  search on metacpan

hugs98-Nov2003/src/static.c  view on Meta::CPAN

static Bool instsChanged;

static Void local deriveContexts(is)	/* Calc contexts for derived insts */
List is; {
    emptySubstitution();
    mapProc(initDerInst,is);		/* Prepare derived instances	   */

    do {				/* Main calculation of contexts	   */
	instsChanged = FALSE;
	mapProc(calcInstPreds,is);
    } while (instsChanged);

    mapProc(tidyDerInst,is);		/* Tidy up results		   */
}

static Void local initDerInst(in)	/* Prepare instance for calculation*/
Inst in; {				/* of derived instance context	   */
    Cell spcs = inst(in).specifics;
    Int  beta = newKindedVars(inst(in).kinds);
    if (whatIs(spcs)!=DERIVE) {
	internal("initDerInst");
    }
    fst(snd(spcs)) = appendOnto(fst(snd(spcs)),singleton(NIL));
    for (spcs=snd(snd(spcs)); nonNull(spcs); spcs=tl(spcs)) {
	hd(spcs) = ap2(inst(in).c,hd(spcs),mkInt(beta));
    }
    inst(in).numSpecifics = beta;

#if DEBUG_DERIVING
    Printf("initDerInst: ");
    printPred(stdout,inst(in).head);
    Printf("\n");
    printContext(stdout,snd(snd(inst(in).specifics)));
    Printf("\n");
#endif
}

static Void local calcInstPreds(in)	/* Calculate next approximation	   */
Inst in; {				/* of the context for a derived	   */
    List retain = NIL;			/* instance			   */
    List ps     = snd(snd(inst(in).specifics));
    List spcs   = fst(snd(inst(in).specifics));
    Int  beta   = inst(in).numSpecifics;
    Int  its    = 1;
    Int  factor = 1+length(ps);

#if DEBUG_DERIVING
    Printf("calcInstPreds: ");
    printPred(stdout,inst(in).head);
    Printf("\n");
#endif

    while (nonNull(ps)) {
	Cell p = hd(ps);
	ps     = tl(ps);

	if (its++ >= factor*cutoff) {
	    Cell bpi = inst(in).head;
	    ERRMSG(inst(in).line) "\n*** Cannot derive " ETHEN ERRPRED(bpi);
	    ERRTEXT " after %d iterations.", its-1   ETHEN
	    ERRTEXT
		"\n*** This may indicate that the problem is undecidable.  However,\n"
	    ETHEN ERRTEXT
		"*** you may still try to increase the cutoff limit using the -c\n"
	    ETHEN ERRTEXT
		"*** option and then try again.  (The current setting is -c%d)\n",
		cutoff
	    EEND;
	}
	if (isInt(fst(p))) {			/* Delayed substitution?   */
	    List qs = snd(p);
	    for (; nonNull(hd(qs)); qs=tl(qs)) {
		ps = cons(pair(hd(qs),fst(p)),ps);
	    }
	    retain = cons(pair(fst(p),qs),retain);
	}
#if TREX
	else if (isExt(fun(fst(p)))) {		/* Lacks predicate	   */
	    Text   l = extText(fun(fst(p)));
	    Type   t = arg(fst(p));
	    Int    o = intOf(snd(p));
	    Type   h;
	    Tyvar *tyv;

	    deRef(tyv,t,o);
	    h = getDerefHead(t,o);
	    while (isExt(h) && argCount==2 && l!=extText(h)) {
		t = arg(t);
		deRef(tyv,t,o);
		h = getDerefHead(t,o);
	    }
	    if (argCount==0 && isOffset(h)) {
		maybeAddPred(ap(fun(fun(p)),h),o,beta,spcs);
	    } else if (argCount!=0 || h!=typeNoRow) {
		Cell bpi = inst(in).head;
		Cell pi  = copyPred(fun(p),intOf(snd(p)));
		ERRMSG(inst(in).line) "Cannot derive " ETHEN ERRPRED(bpi);
		ERRTEXT " because predicate " ETHEN ERRPRED(pi);
		ERRTEXT " does not hold\n"
		EEND;
	    }
	}
#endif
	else {					/* Class predicate	   */
	    Cell pi  = fst(p);
	    Int  o   = intOf(snd(p));
	    Inst in1 = findInstFor(pi,o);
	    if (nonNull(in1)) {
		List qs  = inst(in1).specifics;
		Int  off = mkInt(typeOff);
		if (whatIs(qs)==DERIVE) {	/* Still being derived	   */
		    for (qs=fst(snd(qs)); nonNull(hd(qs)); qs=tl(qs)) {
			ps = cons(pair(hd(qs),off),ps);
		    }
		    retain = cons(pair(off,qs),retain);
		} else {			/* Previously def'd inst   */
		    for (; nonNull(qs); qs=tl(qs)) {
			ps = cons(pair(hd(qs),off),ps);
		    }
		}