/* --------------------------------------------------------------------------
 * static.c:    Copyright (c) Mark P Jones 1991-1998.   All rights reserved.
 *              See NOTICE for details and conditions of use etc...
 *              Hugs version 1.3b, January 1998
 *
 * Static Analysis for Hugs
 * ------------------------------------------------------------------------*/

#include "prelude.h"
#include "storage.h"
#include "connect.h"
#include "errors.h"

/* --------------------------------------------------------------------------
 * local function prototypes:
 * ------------------------------------------------------------------------*/

static Void  local checkTyconDefn	Args((Tycon));
static Void  local depConstrs		Args((Tycon,List,Cell));
static List  local depStructSels	Args((Tycon,List,List));
static Type  local depTypeExp		Args((Int,List,Type));
static Type  local depTypeVar		Args((Int,List,Text));
static List  local selectCtxt		Args((List,List));
static Void  local checkSynonyms	Args((List));
static List  local visitSyn		Args((List,Tycon,List));
static Void  local checkSubtypes        Args((List));
static List  local visitTycon           Args((List,List,Tycon,List));
static Void  local addAxiom             Args((Tycon,Type));
static Int   local countTycon           Args((Tycon,Type));
static Void  local inferVariances       Args((List));
static Void  local deriveEval		Args((List));
static List  local visitPossEval	Args((Tycon,List,List));
static Void  local checkBanged		Args((Name,Type,List));

static Type  local instantiateSyn	Args((Type,Type));

static List  local typeVarsIn		Args((Cell,List));
static List  local maybeAppendVar	Args((Cell,List));

static List  local offsetTyvarsIn	Args((Type,List));

static Type  local checkSigType		Args((Int,String,Cell,Type));

static Void  local checkClassDefn	Args((Class));
static Void  local depPredExp		Args((Int,List,Cell));
static Void  local checkMems		Args((Cell,List,Cell));
static Void  local addMembers		Args((Class));
static Name  local newMember		Args((Int,Int,Cell,Type));
static Int   local visitClass		Args((Class));
static Int   local inferClassVariance   Args((Class));


static Void  local checkInstDefn        Args((Inst));
static Void  local checkInstSC		Args((Inst));
static Cell  local scEvidFrom		Args((Cell,List,Int));

static List  local classBindings        Args((String,Class,List));
static Int   local memberNumber         Args((Class,Text));
static List  local numInsert            Args((Int,Cell,List));

static Void  local checkDerive		Args((Tycon,List,List,Cell));
static Void  local addDerInst		Args((Int,Class,List,List,Type,Int));
static Void  local deriveContexts	Args((List));
static Void  local expandDComps		Args((Inst));
static List  local superSimp		Args((List));
static Void  local maybeAddPred		Args((Cell,List));
static Cell  local instPred		Args((Cell,Type));
static Void  local calcInstPreds	Args((Inst));

static Void  local addDerivImp		Args((Inst));
static List  local getDiVars		Args((Int));
static Cell  local mkBind		Args((String,List));
static Cell  local mkVarAlts		Args((Int,Cell));

static List  local deriveEq		Args((Tycon));
static Pair  local mkAltEq		Args((Int,List));
static List  local deriveOrd		Args((Tycon));
static Pair  local mkAltOrd		Args((Int,List));
static List  local makeDPats2		Args((Cell,Int));

static List  local deriveIx		Args((Tycon));
static List  local deriveEnum		Args((Tycon));
static Bool  local isEnumType		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 deriveShow		Args((Tycon));
static Cell  local mkAltShow		Args((Int,Cell,Int));
static Cell  local showsPrecRhs		Args((Cell,Cell));

static List  local deriveRead		Args((Tycon));

static List  local deriveBounded	Args((Tycon));
static List  local mkBndBinds		Args((Int,Cell,Int));

static Void  local checkPrimDefn	Args((Triple));
static Void  local addNewPrim		Args((Int,Text,String,Cell));

static Void  local checkDefaultDefns	Args((Void));

static Cell  local checkPat		Args((Int,Cell));
static Cell  local checkMaybeCnkPat	Args((Int,Cell));
static Cell  local checkApPat		Args((Int,Int,Cell));
static Void  local addPatVar		Args((Int,Cell));
#if OBJ
static Cell  local checkAssignPat       Args((Int,Cell));
static Void  local checkNoHiding        Args((Int,Text));
#endif
static Name  local selDefined		Args((Int,Text));
static Name  local conDefined		Args((Int,Text));
static Void  local checkIsCfun		Args((Int,Name));
static Void  local checkCfunArgs	Args((Int,Cell,Int));

static Cell  local bindPat		Args((Int,Cell));
static Void  local bindPats		Args((Int,List));
static List  local bindGens		Args((Int,List));

static List  local extractGens		Args((List));
static List  local extractSigdecls	Args((List));
static List  local extractBindings	Args((List));
static List  local eqnsToBindings	Args((List));
static Void  local notDefined		Args((Int,List,Cell));
static Cell  local findBinding		Args((Text,List));
static Void  local addSigDecl		Args((List,Cell));
static Void  local setType		Args((Int,Cell,Cell,List));

static List  local dependencyAnal	Args((List));
static List  local topDependAnal	Args((List));
static Void  local addDepField		Args((Cell));
static Void  local remDepField		Args((List));
static Void  local remDepField1		Args((Cell));
static Void  local clearScope		Args((Void));
static Void  local withinScope		Args((List));
static Void  local leaveScope		Args((Void));

static Void  local depBinding		Args((Cell));
static Void  local depSelBind		Args((Cell));
static Cell  local depStruct            Args((Int,Cell));
static Void  local depDefaults          Args((Class));
static Void  local depInsts             Args((Inst));
static Void  local depClassBindings     Args((List));
static Void  local depAlt		Args((Cell));
static Void  local depRhs		Args((Cell));
static Void  local depGuard		Args((Cell));
static Cell  local depExpr		Args((Int,Cell));
static Void  local depPair		Args((Int,Cell));
static Void  local depTriple		Args((Int,Cell));
static Void  local depDoComp		Args((Int,Cell,List));
static Void  local depComp		Args((Int,Cell,List));
static Void  local depCaseAlt		Args((Int,Cell));
static Cell  local depVar		Args((Int,Cell));
#if OBJ
static Void  local depTempl             Args((Int,Cell));
#endif
static Void  local depGens		Args((Int,List));

static Int   local sccMin		Args((Int,Int));
static List  local tcscc		Args((List,List));
static List  local bscc			Args((List));

static Void  local addRSsigdecls	Args((Pair));
static Void  local opDefined		Args((List,Cell));
static Void  local allNoPrevDef		Args((Cell));
static Void  local noPrevDef		Args((Int,Cell));
static Void  local checkTypeIn		Args((Pair));

/* --------------------------------------------------------------------------
 * Static analysis of type declarations:
 *
 * Type declarations come in two forms:
 * - data declarations - define new constructed data types
 * - type declarations - define new type synonyms
 *
 * A certain amount of work is carried out as the declarations are
 * read during parsing.  In particular, for each type constructor
 * definition encountered:
 * - check that there is no previous definition of constructor
 * - ensure type constructor not previously used as a class name
 * - make a new entry in the type constructor table
 * - record line number of declaration
 * - Build separate lists of newly defined constructors for later use.
 * ------------------------------------------------------------------------*/

Void tyconDefn(line,lhs,rhs,what,axs)	/* process new type definition	   */
Int  line;				/* definition line number	   */
Cell lhs;				/* left hand side of definition	   */
Cell rhs;				/* right hand side of definition   */
Cell what;				/* SYNONYM/DATATYPE/etc...	   */
List axs; {				/* declared sub/supertypes	   */
    Text t = textOf(getHead(lhs));

    if (nonNull(findTycon(t))) {
	ERRMSG(line) "Repeated definition of type constructor \"%s\"",
		     textToStr(t)
	EEND;
    }
    else if (nonNull(findClass(t))) {
	ERRMSG(line) "\"%s\" used as both class and type constructor",
		     textToStr(t)
	EEND;
    }
    else {
	Tycon nw	 = newTycon(t);
	tyconDefns       = cons(nw,tyconDefns);
	tycon(nw).line   = line;
	tycon(nw).arity  = argCount;
	tycon(nw).what   = what;
	tycon(nw).axioms = axs;
	if (what==RESTRICTSYN) {
	    typeInDefns  = cons(pair(nw,snd(rhs)),typeInDefns);
	    rhs          = fst(rhs);
	}
	tycon(nw).defn   = pair(lhs,rhs);
    }
}

Void setTypeIns(bs)			/* set local synonyms for given	   */
List bs; {				/* binding group		   */
    List cvs = typeInDefns;
    for (; nonNull(cvs); cvs=tl(cvs)) {
	Tycon c  = fst(hd(cvs));
	List  vs = snd(hd(cvs));
	for (tycon(c).what = RESTRICTSYN; nonNull(vs); vs=tl(vs)) {
	    if (nonNull(findBinding(textOf(hd(vs)),bs))) {
		tycon(c).what = SYNONYM;
		break;
	    }
	}
    }
}

Void clearTypeIns() {			/* clear list of local synonyms	   */
    for (; nonNull(typeInDefns); typeInDefns=tl(typeInDefns))
	tycon(fst(hd(typeInDefns))).what = RESTRICTSYN;
}

/* --------------------------------------------------------------------------
 * Further analysis of Type declarations:
 *
 * In order to allow the definition of mutually recursive families of
 * data types, the static analysis of the right hand sides of type
 * declarations cannot be performed until all of the type declarations
 * have been read.
 *
 * Once parsing is complete, we carry out the following:
 *
 * - check format of lhs, extracting list of bound vars and ensuring that
 *   there are no repeated variables and no Skolem variables.
 * - run dependency analysis on rhs to check that only bound type vars
 *   appear in type and that all constructors are defined.
 *   Replace type variables by offsets, constructors by Tycons.
 * - use list of dependents to sort into strongly connected components.
 * - ensure that there is not more than one synonym in each group.
 * - kind-check each group of type definitions.
 *
 * - check that there are no previous definitions for constructor
 *   functions in data type definitions.
 * - install synonym expansions and constructor definitions.
 * ------------------------------------------------------------------------*/

static List tcDeps = NIL;		/* list of dependent tycons/classes*/
static Bool acceptWildcards = FALSE;    /* Accept wildcards in type-exprs? */

static Void local checkTyconDefn(d)	/* validate type constructor defn  */
Tycon d; {
    Cell lhs    = fst(tycon(d).defn);
    Cell rhs    = snd(tycon(d).defn);
    Int  line   = tycon(d).line;
    List tyvars = getArgs(lhs);
    List temp;
					/* check for repeated tyvars on lhs*/
    for (temp=tyvars; nonNull(temp); temp=tl(temp))
	if (nonNull(varIsMember(textOf(hd(temp)),tl(temp)))) {
	    ERRMSG(line) "Repeated type variable \"%s\" on left hand side",
			 textToStr(textOf(hd(temp)))
	    EEND;
	}

    tcDeps = NIL;			/* find dependents		   */

    switch (whatIs(tycon(d).what)) {
        case PRIMTYPE    : internal("checkTyconDefn");
        
	case RESTRICTSYN :
	case SYNONYM	 : rhs = depTypeExp(line,tyvars,rhs);
			   if (cellIsMember(d,tcDeps)) {
			       ERRMSG(line) "Recursive type synonym \"%s\"",
					    textToStr(tycon(d).text)
			       EEND;
			   }
			   break;

	case DATATYPE	 :
	case NEWTYPE	 : depConstrs(d,tyvars,rhs);
			   rhs = fst(rhs);
			   break;

	case STRUCTTYPE  : if (nonNull(extractBindings(rhs))) {
			       ERRMSG(line) 
			           "Bindings not permitted in struct definition"
			       EEND;
			   }
			   rhs = extractSigdecls(rhs);
			   rhs = depStructSels(d,tyvars,rhs);
			   break;

	default		 : internal("checkTyconDefn");
			   break;
    }

    tycon(d).defn = rhs;
    tycon(d).kind = tcDeps;
    tcDeps	  = NIL;

    tycon(d).variance = NIL;
}

static Void local depConstrs(t,tyvars,cd)
Tycon t;				/* Define constructor functions and*/
List  tyvars;				/* do dependency analysis for data */
Cell  cd; {				/* definitions (w or w/o deriving) */
    Int  line      = tycon(t).line;
    Int  conNo     = 1;
    Type lhs	   = satTycon(t);
    List cs	   = fst(cd);
    List derivs    = snd(cd);
    List compTypes = NIL;
    List axs       = tycon(t).axioms;
    Int  i;

    if (tycon(t).what==NEWTYPE)		/* slight semantic diff: now only  */
	conNo = 0;			/* newtype cons are failure-free   */

    for (; nonNull(axs); axs=tl(axs)) {	/* for each subtype:		   */
        List sig = typeVarsIn(hd(axs),dupList(tyvars));
        Type sub = depTypeExp(line,sig,hd(axs));

	if (nonNull(sig)) {		/* Add quantifiers to type	   */
	    List ts = sig;
	    for (; nonNull(ts); ts=tl(ts))
		hd(ts) = NIL;
	    sub = mkPolyType(sig,sub);
	}

        hd(axs) = sub;
    }
        
    for (; nonNull(cs); cs=tl(cs)) {	/* For each constructor function:  */
	Cell con   = hd(cs);
	List sig   = typeVarsIn(con,dupList(tyvars));
	List scs   = NIL;		/* strict components		   */
	Type type  = lhs;		/* constructor function type	   */
	Int  arity = 0;			/* arity of constructor function   */
	Name n;				/* name for constructor function   */

	Cell c = con;
	Int  compNo;
	for (; isAp(c); c=fun(c))
	    arity++;
	for (compNo=arity, c=con; isAp(c); c=fun(c)) {
	    Type t = arg(c);
	    if (whatIs(t)==BANG) {
		scs = cons(mkInt(compNo),scs);
		t   = arg(t);
	    }
	    compNo--;
	    arg(c) = depTypeExp(line,sig,t);
	}

	while (isAp(con)) {		/* Calculate type of constructor   */
	    Type t   = fun(con);
	    fun(con) = typeArrow;
	    if (nonNull(derivs))	/* and build list of components	   */
		compTypes = cons(arg(con),compTypes);
	    type     = ap(con,type);
	    con      = t;
	}

	if (nonNull(sig)) {		/* Add quantifiers to type	   */
	    List ts = sig;
	    for (; nonNull(ts); ts=tl(ts))
		hd(ts) = NIL;
	    type = mkPolyType(sig,type);
	}

	n = findName(textOf(con));	/* Allocate constructor fun name   */
	if (isNull(n))
	    n = newName(textOf(con));
	else if (name(n).defn!=PREDEFINED) {
	    ERRMSG(line) "Repeated definition for constructor function \"%s\"",
			 textToStr(name(n).text)
	    EEND;
	}
	name(n).arity  = arity;		/* Save constructor fun details	   */
	name(n).line   = line;
	name(n).number = cfunNo(conNo++);
	name(n).type   = type;
	if (tycon(t).what==NEWTYPE)
	    name(n).defn = nameId;
	else
	    implementCfun(n,scs);

	hd(cs) = n;
    }

    if (nonNull(derivs)) {		/* Generate derived instances	   */
	map3Proc(checkDerive,t,NIL,compTypes,derivs);
    }
}

static List local depStructSels(tc,tyvars,sd)
Tycon tc;				/* Define struct selectors and     */
List  tyvars;				/* do dependency analysis for      */
List  sd; {				/* struct definitions              */
    Int  line  = tycon(tc).line;
    Int  selNo = 1;
    Type lhs   = satTycon(tc);
    List sels  = NIL;
    List axs   = tycon(tc).axioms;
    Int  i;

    for (; nonNull(axs); axs=tl(axs)) {	/* for each supertype:		   */
        List sig = typeVarsIn(hd(axs),dupList(tyvars));
        Type sup = depTypeExp(line,sig,hd(axs));

	if (nonNull(sig)) {		/* Add quantifiers to supertype	   */
	    List ts = sig;
	    for (; nonNull(ts); ts=tl(ts))
		hd(ts) = NIL;
	    sup = mkPolyType(sig,sup);
	}
        
        hd(axs) = sup;
    }
        
    for (; nonNull(sd); sd=tl(sd)) {	/* For each selector definition:   */
        Int  line  = intOf(fst3(hd(sd)));
	List vs    = snd3(hd(sd));
	Type t     = thd3(hd(sd));
        List sig   = typeVarsIn(t,dupList(tyvars));
	
	if (whatIs(t) == QUAL) {
	    ERRMSG(line) "Qualified type not allowed in selector definition"
	    EEND;
	}
	t = depTypeExp(line,sig,t);
	
	for (; nonNull(vs); vs=tl(vs)) {
	    List sig1    = dupList(sig);
	    Type seltype = ap(ap(typeArrow,lhs),t);/* actual function type*/
	    Text txt     = mkStructSel(textOf(hd(vs)));
	    Name n       = findName(txt); /* Allocate selector fun name   */

	    if (isNull(n))
	        n = newName(txt);
	    else if (name(n).defn!=PREDEFINED) {
	        ERRMSG(line) "Repeated definition for struct selector \"%s\"",
		 	     textToStr(textOf(hd(vs)))
	        EEND;
	    }

	    if (nonNull(sig1)) {	/* Add quantifiers to type	   */
	        List ts = sig1;
	        for (; nonNull(ts); ts=tl(ts))
		    hd(ts) = NIL;
	        seltype = mkPolyType(sig1,seltype);
	    }

	    name(n).arity  = 0;		/* ... will be treated as nullary  */
	    name(n).line   = line;      /*     by back end                 */
	    name(n).number = cfunNo(selNo++);
	    name(n).type   = seltype;
	    name(n).defn   = n;		/* no special implementation       */

	    sels = cons(n,sels);
	}
    }
    return sels;
}

static Type local depTypeExp(line,tyvars,type)
Int  line;
List tyvars;
Type type; {
    switch (whatIs(type)) {
	case AP		: fst(type) = depTypeExp(line,tyvars,fst(type));
			  snd(type) = depTypeExp(line,tyvars,snd(type));
			  break;

	case VARIDCELL	: return depTypeVar(line,tyvars,textOf(type));

	case CONIDCELL	: {   Tycon tc = findTycon(textOf(type));
			      if (isNull(tc)) {
				  ERRMSG(line)
				      "Undefined type constructor \"%s\"",
				      textToStr(textOf(type))
				  EEND;
			      }
			      if (cellIsMember(tc,tyconDefns) &&
				  !cellIsMember(tc,tcDeps))
				  tcDeps = cons(tc,tcDeps);
			      return tc;
			  }

	case TYCON	:
	case TUPLE	: break;
	
	case WILDCARD   : if (!acceptWildcards) {
	                      ERRMSG(line)
	                          "Wildcard types not allowed in this context"
	                      EEND;
	                  }
	                  break;

	default		: internal("depTypeExp");
    }
    return type;
}

static Type local depTypeVar(line,tyvars,tv)
Int  line;
List tyvars;
Text tv; {
    Int offset = 0;

    for (; nonNull(tyvars) && tv!=textOf(hd(tyvars)); offset++)
	tyvars = tl(tyvars);
    if (isNull(tyvars)) {
	ERRMSG(line) "Undefined type variable \"%s\"", textToStr(tv)
	EEND;
    }
    return mkOffset(offset);
}
 
static List local selectCtxt(ctxt,vs)	/* calculate subset of context	   */
List ctxt;
List vs; {
    if (isNull(vs))
	return NIL;
    else {
	List ps = NIL;
	for (; nonNull(ctxt); ctxt=tl(ctxt)) {
	    List us = offsetTyvarsIn(hd(ctxt),NIL);
	    for (; nonNull(us) && cellIsMember(hd(us),vs); us=tl(us))
		;
	    if (isNull(us))
		ps = cons(hd(ctxt),ps);
	}
	return rev(ps);
    }
}

static Void local checkSynonyms(ts)	/* Check for mutually recursive	   */
List ts; {				/* synonyms			   */
    List syns = NIL;
    for (; nonNull(ts); ts=tl(ts)) {	/* build list of all synonyms	   */
	Tycon t = hd(ts);
	switch (whatIs(tycon(t).what)) {
	    case SYNONYM     :
	    case RESTRICTSYN : syns = cons(t,syns);
			       break;
	}
    }
    while (nonNull(syns))		/* then visit each synonym	   */
	syns = visitSyn(NIL,hd(syns),syns);
}

static List local visitSyn(path,t,syns)	/* visit synonym definition to look*/
List  path;				/* for cycles			   */
Tycon t;
List  syns; {
    if (cellIsMember(t,path)) {		/* every elt in path depends on t  */
	ERRMSG(tycon(t).line)
	    "Type synonyms \"%s\" and \"%s\" are mutually recursive",
	    textToStr(tycon(t).text), textToStr(tycon(hd(path)).text)
	EEND;
    }
    else {
	List ds    = tycon(t).kind;
        List path1 = NIL;
	for (; nonNull(ds); ds=tl(ds))
	    if (cellIsMember(hd(ds),syns)) {
		if (isNull(path1))
		    path1 = cons(t,path);
		syns = visitSyn(path1,hd(ds),syns);
	    }
    }
    tycon(t).defn = fullExpand(tycon(t).defn);
    return removeCell(t,syns);
}

static Void local checkSubtypes(ts)
List ts; {
    List ds = NIL;
    List ss = NIL;
    for (; nonNull(ts); ts=tl(ts)) {
        Tycon t = hd(ts);
        switch (whatIs(tycon(t).what)) {
            case DATATYPE   : ds = cons(t,ds);
            		      break;
            case STRUCTTYPE : ss = cons(t,ss);
            		      break;
        }
    }
    while (nonNull(ds))
        ds = visitTycon(NIL,NIL,hd(ds),ds);
    while (nonNull(ss))
        ss = visitTycon(NIL,NIL,hd(ss),ss);
}

static List local visitTycon(path,axpath,t,ts)
List  path;
List  axpath;
Tycon t;
List  ts; {
    if (cellIsMember(t,path)) {
        ERRMSG(tycon(t).line) "Subtype relation is cyclic" ETHEN
        for (; nonNull(path); path=tl(path),axpath=tl(axpath)) {
            Tycon h = hd(path);
	    ERRTEXT "\n*** " ETHEN ERRAXIOM(hd(path),hd(axpath))
	    if (hd(path)==t)
	        break;
	}
	ERRTEXT "\n"
        EEND;
    }
    else {
        List axs   = tycon(t).axioms;
        List path1 = NIL;
        tycon(t).axioms = NIL;
        for (; nonNull(axs); axs=tl(axs)) {
            Type h;
            List axs1;
            
            hd(axs) = fullExpand(hd(axs));
            h = getHead(monoType(hd(axs)));
            if (!isTycon(h) || tycon(h).what != tycon(t).what) {
                ERRMSG(tycon(t).line) "Illegal %stype\n*** ", dir(t) ETHEN
                ERRAXIOM(t,hd(axs)) 
                ERRTEXT "\n"
                EEND;
            }
            if (cellIsMember(h,ts)) {
                if (isNull(path1))
                    path1 = cons(t,path);
                ts = visitTycon(path1,cons(hd(axs),axpath),h,ts);
            }
            for (axs1=tycon(h).axioms; nonNull(axs1); axs1=tl(axs1))
                addAxiom(t,connectAxioms(t,hd(axs),hd(axs1)));
            addAxiom(t,hd(axs));
        }
        tycon(t).axioms = rev(tycon(t).axioms);
    }
    return removeCell(t,ts);
}

static Void local addAxiom(t,ax)		/* add ax to t's list of axioms   */
Tycon t;					/* if not already present	  */
Type  ax; {
    Type h      = getHead(monoType(ax));
    Type ax1    = findAxiom(t,h);
    
    if (isNull(ax1)) {
        Int axm = monoType(ax);
        Int nt = countTycon(t,axm);
	if (nt > 0 || countTycon(h,axm) > 1) {
            ERRMSG(tycon(t).line) 
                "Illegal use of \"%s\" in %stype argument",
                textToStr(tycon(nt > 0 ? t : h).text), dir(t) ETHEN
            ERRTEXT "\n*** " ETHEN ERRAXIOM(t,ax)
            ERRTEXT "\n"
            EEND;
        }
	tycon(t).axioms = cons(ax,tycon(t).axioms);
    }
    else if (!equalSchemes(ax1,ax)) {
	ERRMSG(tycon(t).line) "Ambiguous %stypes", dir(t) ETHEN
	ERRTEXT "\n*** " ETHEN ERRAXIOM(t,ax1)
	ERRTEXT "\n*** " ETHEN ERRAXIOM(t,ax)
	ERRTEXT "\n"
	EEND;
    }
}

static Int local countTycon(tc,t)
Tycon tc;
Type  t; {
    switch (whatIs(t)) {
        case TYCON : return (t==tc ? 1 : 0);
	case AP    : return countTycon(tc,fun(t)) + countTycon(tc,arg(t));
	default	   : return 0;
    }
}

static Void local inferVariances(tcs)	/* Infer variance for tycons      */
List tcs; {
    Bool changed;
    List tcs1;
    
    mapProc(initVariance,tcs);
    typeChecker(RESET);
    do {
	changed = FALSE;
	for (tcs1=tcs; nonNull(tcs1); tcs1=tl(tcs1))
	    if (updateVariance(hd(tcs1)))
	        changed = TRUE;
    } while (changed);
    typeChecker(RESET);
}

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 STRUCTTYPE  :
	    case PRIMTYPE    :
	    case DATATYPE    : addEvalInst(tycon(t).line,t,tycon(t).arity,NIL);
			       break;
	    case NEWTYPE     :
	    case RESTRICTSYN : ts = cons(t,ts);
			       break;
	}
    }
    while (nonNull(ts))			/* ... then visit each in turn	   */
	ts = visitPossEval(hd(ts),tl(ts),NIL);

    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 (; nonNull(cs); cs=tl(cs)) {
		Name c = hd(cs);
		if (isPair(name(c).defn)) {
		    Type t    = name(c).type;
		    List scs  = fst(name(c).defn);
		    List ctxt = NIL;
		    Int  n    = 1;
		    if (isPolyType(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,arg(fun(t)),ctxt);
		    }
		}
	    }
	}
    }
}

static List local visitPossEval(t,ts,ps)/* Test to see if we can add an	   */
Tycon t;				/* Eval instance for t		   */
List  ts;				/* [RESTRICTSYN | NEWTYPE]	   */
List  ps; {				/* [Tycons already being visited]  */
    Type ty = tycon(t).defn;		/* Find the `deciding type' ...	   */
    if (whatIs(tycon(t).what)==NEWTYPE) {
	ty = name(hd(tycon(t).defn)).type;
	if (isPolyType(ty))
	    ty = monoTypeOf(ty);
	if (whatIs(ty)==QUAL)
	    ty = snd(snd(ty));
	ty = arg(fun(ty));
    }

    for (;;) {				/* Scrutinize it ...		   */
	Type h = getHead(ty);		/* Find the constructor in the	   */
	if (isSynonym(h))		/* head position of the type	   */
	    h = getHead(ty=fullExpand(ty));
	if (isOffset(h)) {		/* Variable in head position	   */
	    if (argCount==0)		/* ... without any arguments	   */
		addEvalInst(tycon(t).line,
			    t,
			    tycon(t).arity,
			    singleton(ap(classEval,h)));
	    return ts;			/* ... with args, so no instance   */
	}
	else {				/* Tycon or tuple in head position */
	    Int  a = argCount;
	    Inst in;

	    if (h==t || cellIsMember(h,ps)) {	/* ... already visited?	   */
		addEvalInst(tycon(t).line,t,tycon(t).arity,NIL);
		return ts;
	    }

	    if (cellIsMember(h,ts))		/* ... still to be visited */
		ts = visitPossEval(h,removeCell(h,ts),cons(t,ps));

	    if (nonNull(in=findInst(classEval,h))) {
		if (nonNull(inst(in).specifics)) {
		    Int n = offsetOf(arg(hd(inst(in).specifics)));
		    while (++n < a)
			ty = fun(ty);
		    ty = arg(ty);	/* If there was a context, then we */
		    continue;		/* need to go round the loop again */
		}
		addEvalInst(tycon(t).line,t,tycon(t).arity,NIL);
	    }
	    return ts;
	}
    }
}

static Void local checkBanged(c,ty,ps)	/* Check that banged component of c */
Name c;					/* with type ty is an instance of   */
Type ty;				/* Eval under the predicates in ps. */
List ps; {
    Type ty1 = ty;			/* Save orig type, in case of err. */
    for (;;) {
	Type h = getHead(ty);		/* Find the constructor in the	   */
	if (isSynonym(h))		/* head position of the type	   */
	    h = getHead(ty=fullExpand(ty));
	if (isOffset(h)) {		/* Variable in head position	   */
	    if (argCount==0 && nonNull(scEvidFrom(pair(classEval,h),ps,0)))
		return;
	    break;
	}
	else {				/* Tycon or tuple in head position */
	    Int  a  = argCount;
	    Inst in = findInst(classEval,h);
	    if (nonNull(in)) {
		if (nonNull(inst(in).specifics)) {
		    Int n = offsetOf(arg(hd(inst(in).specifics)));
		    while (++n < a)
			ty = fun(ty);
		    ty = arg(ty);	/* If there was a context, then we */
		    continue;		/* need to go round the loop again */
		}
		return;			/* No context, so nothing to prove */
	    }
	    break;
	}
    }
    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(ap(classEval,ty1));
    ERRTEXT "\n"
    EEND;
}

/* --------------------------------------------------------------------------
 * Expanding out all type synonyms in a type expression:
 * ------------------------------------------------------------------------*/

Type fullExpand(t)			/* find full expansion of type exp */
Type t; {				/* assuming that all relevant      */
    Cell h = t;				/* synonym defns of lower rank have*/
    Int  n = 0;				/* already been fully expanded	   */
    List args;
    for (args=NIL; isAp(h); h=fun(h), n++)
	args = cons(fullExpand(arg(h)),args);
    t = applyToArgs(h,args);
    if (isSynonym(h) && n>=tycon(h).arity)
	if (n==tycon(h).arity)
	    t = instantiateSyn(tycon(h).defn,t);
	else {
	    Type p = t;
	    while (--n > tycon(h).arity)
		p = fun(p);
	    fun(p) = instantiateSyn(tycon(h).defn,fun(p));
	}
    return t;
}

static Type local instantiateSyn(t,env)	/* instantiate type according using*/
Type t;					/* env to determine appropriate    */
Type env; {				/* values for OFFSET type vars	   */
    switch (whatIs(t)) {
	case AP      : return ap(instantiateSyn(fun(t),env),
				 instantiateSyn(arg(t),env));

	case OFFSET  : return nthArg(offsetOf(t),env);

	default	     : return t;
    }
}

/* --------------------------------------------------------------------------
 * Calculate set of variables appearing in a given type expression (possibly
 * qualified) as a list of distinct values.  The order in which variables
 * appear in the list is the same as the order in which those variables
 * occur in the type expression when read from left to right.
 * ------------------------------------------------------------------------*/

static List local typeVarsIn(type,vs)  /* calculate list of type variables */
Cell type;			       /* used in type expression, reading */
List vs; {			       /* from left to right		   */
    switch (whatIs(type)) {
	case AP        : return typeVarsIn(snd(type),
					   typeVarsIn(fst(type),
						      vs));
	case VARIDCELL :
	case VAROPCELL : return maybeAppendVar(type,vs);

	case QUAL      : {   List qs = fst(snd(type));
			     vs = typeVarsIn(snd(snd(type)),vs);
			     for (; nonNull(qs); qs=tl(qs))
				 vs = typeVarsIn(hd(qs),vs);
			     return vs;
			 }

	case BANG      : return typeVarsIn(snd(type),vs);
    }
    return vs;
}

static List local maybeAppendVar(v,vs) /* append variable to list if not   */
Cell v; 			       /* already included		   */
List vs; {
    Text t = textOf(v);
    List p = NIL;
    List c = vs;

    while (nonNull(c)) {
	if (textOf(hd(c))==t)
	    return vs;
	p = c;
	c = tl(c);
    }

    if (nonNull(p))
	tl(p) = cons(v,NIL);
    else
	vs    = cons(v,NIL);

    return vs;
}

/* --------------------------------------------------------------------------
 * Check for ambiguous types:
 * A type  Preds => type  is ambiguous if not (TV(P) `subset` TV(type))
 * ------------------------------------------------------------------------*/

static List local offsetTyvarsIn(t,vs)	/* add list of offset tyvars in t  */
Type t;					/* to list vs			   */
List vs; {
    switch (whatIs(t)) {
	case AP	    : return offsetTyvarsIn(fun(t),offsetTyvarsIn(arg(t),vs));

	case OFFSET : if (cellIsMember(t,vs))
			  return vs;
		      else
			  return cons(t,vs);

	case QUAL   : return offsetTyvarsIn(snd(t),vs);

	default	    : return vs;
    }
}

Bool isAmbiguous(type)			/* Determine whether type is	   */
Type type; {				/* ambiguous 			   */
    if (isPolyType(type))
	type = monoTypeOf(type);
    if (whatIs(type)==QUAL) {		/* only qualified types can be	   */
	List tvps = offsetTyvarsIn(fst(snd(type)),NIL);	/* ambiguous	   */
	List tvts = offsetTyvarsIn(snd(snd(type)),NIL);
	while (nonNull(tvps) && cellIsMember(hd(tvps),tvts))
	    tvps = tl(tvps);
	return nonNull(tvps);
    }
    return FALSE;
}

Void ambigError(line,where,e,type)	/* produce error message for	   */
Int    line;				/* ambiguity			   */
String where;
Cell   e;
Type   type; {
    ERRMSG(line) "Ambiguous type signature in %s", where ETHEN
    ERRTEXT "\n*** ambiguous type : " ETHEN ERRTYPE(type);
    ERRTEXT "\n*** assigned to    : " ETHEN ERREXPR(e);
    ERRTEXT "\n"
    EEND;
}

/* --------------------------------------------------------------------------
 * Type expressions appearing in type signature declarations and expressions
 * also require static checking, but unlike type expressions in type decls,
 * they may introduce arbitrary new type variables.  The static analysis
 * required here is:
 *   - ensure that each type constructor is defined and used with the
 *     correct number of arguments.
 *   - replace type variables by offsets, constructor names by Tycons.
 *   - ensure that type is well-kinded.
 * ------------------------------------------------------------------------*/

static Type local checkSigType(line,where,e,type)
Int    line;			       /* check validity of type expression*/
String where;			       /* in explicit type signature	   */
Cell   e;
Type   type; {
    List tyvars = typeVarsIn(type,NIL);
    Int  n      = length(tyvars);

    if (whatIs(type)==QUAL) {
	map2Proc(depPredExp,line,tyvars,fst(snd(type)));
	acceptWildcards = TRUE;
	snd(snd(type)) = depTypeExp(line,tyvars,snd(snd(type)));
	acceptWildcards = FALSE;

	if (isAmbiguous(type))
	    ambigError(line,where,e,type);
    }
    else {
        acceptWildcards = TRUE;
	type = depTypeExp(line,tyvars,type);
	acceptWildcards = FALSE;
    }

    if (n>0)
	if (n>=NUM_OFFSETS) {
	    ERRMSG(line) "Too many type variables in %s\n", where
	    EEND;
	}
	else {
	    List sig = dupList(tyvars);
	    List ts  = sig;
	    for (; nonNull(ts); ts=tl(ts))
		hd(ts) = NIL;
	    type = mkPolyType(sig,type);
	}

    kindSigType(line,type);		/* check that type is well-kinded  */
    return type;
}

/* --------------------------------------------------------------------------
 * Static analysis of class declarations:
 *
 * Performed in a similar manner to that used for type declarations.
 *
 * The first part of the static analysis is performed as the declarations
 * are read during parsing.  The parser ensures that:
 * - the class header and all superclass predicates are of the form
 *   ``Class var''
 *
 * The classDefn() function:
 * - ensures that there is no previous definition for class
 * - checks that class name has not previously been used as a type constr.
 * - make new entry in class table
 * - record line number of declaration
 * - build list of classes defined in current script for use in later
 *   stages of static analysis.
 * ------------------------------------------------------------------------*/

Void classDefn(line,head,ms)	       /* process new class definition	   */
Int  line;			       /* definition line number	   */
Cell head;			       /* class header :: ([Supers],Class) */
List ms; {			       /* class definition body		   */
    Text ct = textOf(fun(snd(head)));

    if (nonNull(findClass(ct))) {
	ERRMSG(line) "Repeated definition of class \"%s\"",
		     textToStr(ct)
	EEND;
    }
    else if (nonNull(findTycon(ct))) {
	ERRMSG(line) "\"%s\" used as both class and type constructor",
		     textToStr(ct)
	EEND;
    }
    else {
	Class nw	   = newClass(ct);
	cclass(nw).line    = line;
	cclass(nw).supers  = head;
	cclass(nw).members = ms;
	cclass(nw).level   = 0;
	classDefns	   = cons(nw,classDefns);
    }
}

/* --------------------------------------------------------------------------
 * Further analysis of class declarations:
 *
 * Full static analysis of class definitions must be postponed until the
 * complete script has been read and all static analysis on type definitions
 * has been completed.
 *
 * Once this has been achieved, we carry out the following checks on each
 * class definition:
 * - check superclass declarations, replace by list of classes
 * - split body of class into members and declarations
 * - make new name entry for each member function
 * - record member function number (eventually an offset into dictionary!)
 * - no member function has a previous definition ...
 * - no member function is mentioned more than once in the list of members
 * - each member function type is valid, replace vars by offsets
 * - qualify each member function type by class header
 * - only bindings for members appear in defaults
 * - only function bindings appear in defaults
 * - check that extended class hierarchy does not contain any cycles
 * ------------------------------------------------------------------------*/

static Void local checkClassDefn(c)    /* validate class definition	   */
Class c; {
    Cell head          = snd(cclass(c).supers);
    List tyvars        = singleton(arg(head));

    cclass(c).supers   = fst(cclass(c).supers);			/* supercl.*/
    tcDeps	       = NIL;
    map2Proc(depPredExp,cclass(c).line,tyvars,cclass(c).supers);
    cclass(c).numSupers= length(cclass(c).supers);
    mapOver(fst,cclass(c).supers);

    cclass(c).defaults = extractBindings(cclass(c).members);	/* defaults*/
    cclass(c).members  = extractSigdecls(cclass(c).members);
    fun(head)	       = c;
    arg(head)	       = mkOffset(0);
    map2Proc(checkMems,head,tyvars,cclass(c).members);
    cclass(c).sig      = tcDeps;
    tcDeps             = NIL;
}

static Void local depPredExp(line,tyvars,pred)
Int  line;
List tyvars;
Cell pred; {
    Class c = findClass(textOf(fun(pred)));
    if (isNull(c)) {
	ERRMSG(line) "Undefined class \"%s\"", textToStr(textOf(fun(pred)))
	EEND;
    }
    fun(pred) = c;
    arg(pred) = depTypeExp(line,tyvars,arg(pred));
    if (cellIsMember(c,classDefns) && !cellIsMember(c,tcDeps))
	tcDeps = cons(c,tcDeps);
}

static Void local checkMems(h,tyvars,m)	/* check member function details   */
Cell h;
List tyvars;
Cell m; {
    Int  line = intOf(fst3(m));
    List vs   = snd3(m);
    Type t    = thd3(m);

    tyvars    = typeVarsIn(t,tyvars);
    if (whatIs(t)==QUAL) {		/* overloaded member signatures?  */
	List qs = fst(snd(t));
	for (; nonNull(qs); qs=tl(qs)) {
	    depPredExp(line,tyvars,hd(qs));
	    if (arg(hd(qs))==mkOffset(0)) {
		ERRMSG(line) "Illegal constraints on class variable \"%s\"",
			     textToStr(textOf(hd(tyvars)))
		ETHEN ERRTEXT " in type of member function \"%s\"",
			    textToStr(textOf(hd(vs)))
		EEND;
	    }
	}
    }
    else
	t = ap(QUAL,pair(NIL,t));

    fst(snd(t)) = cons(h,fst(snd(t)));		/* Add main predicate	   */
    snd(snd(t)) = depTypeExp(line,tyvars,snd(snd(t)));

    if (isNull(tl(tyvars)))			
	t = mkPolyType(singleton(NIL),t);
    else {
	List sig   = NIL;
	List tvs   = tyvars;
	for (; nonNull(tvs); tvs=tl(tvs))
	    sig = ap(NIL,sig);
	t          = mkPolyType(rev(sig),t);
	tl(tyvars) = NIL;			/* delete extra type vars  */
    }

    if (isAmbiguous(t))
	ambigError(line,"class declaration",hd(vs),t);

    thd3(m)    = t;				/* save type		   */
}

static Void local addMembers(c)		/* Add definitions of member funs  */
Class c; {
    Int  mno   = 1;			/* member function number	   */
    List mfuns = NIL;			/* list of member functions	   */
    List ms    = cclass(c).members;

    for (; nonNull(ms); ms=tl(ms)) {	/* cycle through each sigdecl	   */
	Int  line = intOf(fst3(hd(ms)));
	List vs   = rev(snd3(hd(ms)));
	Type t    = thd3(hd(ms));
	for (; nonNull(vs); vs=tl(vs))
	    mfuns = cons(newMember(line,mno++,hd(vs),t),mfuns);
    }
    cclass(c).members    = rev(mfuns);	/* save list of members		   */
    cclass(c).numMembers = length(cclass(c).members);
    cclass(c).defaults   = classBindings("class",c,cclass(c).defaults);
}

static Name local newMember(l,no,v,t)	/* Make definition for member fn   */
Int  l;
Int  no;
Cell v;
Type t; {
    Name m = findName(textOf(v));

    if (isNull(m))
	m = newName(textOf(v));
    else if (name(m).defn!=PREDEFINED) {
	ERRMSG(l) "Repeated definition for member function \"%s\"",
		  textToStr(name(m).text)
	EEND;
    }

    name(m).line   = l;
    name(m).arity  = 1;
    name(m).number = mfunNo(no);
    name(m).type   = t;
    name(m).defn   = NIL;
    return m;
}

static Int local visitClass(c)		/* visit class defn to check that  */
Class c; {				/* class hierarchy is acyclic	   */
    if (cclass(c).level < 0) {		/* already visiting this class?	   */
	ERRMSG(cclass(c).line) "Class hierarchy for \"%s\" is not acyclic",
			       textToStr(cclass(c).text)
	EEND;
    }
    else if (cclass(c).level == 0) {	/* visiting class for first time   */
	List scs = cclass(c).supers;
	Int  lev = 0;
	cclass(c).level = (-1);
	for (; nonNull(scs); scs=tl(scs)) {
	    Int l = visitClass(hd(scs));
	    if (l>lev) lev=l;
	}
	cclass(c).level = 1+lev;	/* level = 1 + max level of supers */
    }
    return cclass(c).level;
}

static Int local inferClassVariance(c)
Class c; {
    if (!cclass(c).variance) {
        String str = textToStr(cclass(c).text);
        Int z = 0;
        List cs = cclass(c).supers;
        List ms = cclass(c).members;
        
        for (; nonNull(cs); cs=tl(cs))
            z |= inferClassVariance(hd(cs));
        for (; nonNull(ms); ms=tl(ms))
            z |= getVarianceAt(name(hd(ms)).type,0);
        cclass(c).variance = z;
    }
    return cclass(c).variance;
}

/* --------------------------------------------------------------------------
 * Static analysis of instance declarations:
 *
 * The first part of the static analysis is performed as the declarations
 * are read during parsing:
 * - make new entry in instance table
 * - record line number of declaration
 * - build list of instances defined in current script for use in later
 *   stages of static analysis.
 * ------------------------------------------------------------------------*/

Void instDefn(line,head,ms)	       /* process new instance definition  */
Int  line;			       /* definition line number	   */
Cell head;			       /* inst header :: (context,Class)   */
List ms; {			       /* instance members		   */
    Inst nw             = newInst();
    inst(nw).line       = line;
    inst(nw).specifics  = head;
    inst(nw).implements = ms;
    instDefns           = cons(nw,instDefns);
}

/* --------------------------------------------------------------------------
 * Further static analysis of instance declarations:
 *
 * Makes the following checks:
 * - Class part of header has form C (T a1 ... an) where C is a known
 *   class, and T is a known datatype constructor (or restricted synonym),
 *   and there is no previous C-T instance, and (T a1 ... an) has a kind
 *   appropriate for the class C.
 * - Each element of context is a valid class expression, with type vars
 *   drawn from a1, ..., an.
 * - All bindings are function bindings
 * - All bindings define member functions for class C
 * - Arrange bindings into appropriate order for member list
 * - No top level type signature declarations
 * ------------------------------------------------------------------------*/

static Void local checkInstDefn(in)    /* validate instance declaration    */
Inst in; {
    Int  line   = inst(in).line;
    Cell head   = snd(inst(in).specifics);
    List tyvars = getArgs(arg(head));
    Cell tmp;

    for (tmp=tyvars; nonNull(tmp); tmp=tl(tmp))	/* check for repeated var  */
	if (nonNull(varIsMember(textOf(hd(tmp)),tl(tmp)))) {
	    ERRMSG(line) "Repeated type variable \"%s\" in instance predicate",
			 textToStr(textOf(hd(tmp)))
	    EEND;
	}
    depPredExp(line,tyvars,head);
    if (fun(head)==classEval) {
	ERRMSG(line) "Instances of class \"%s\" are generated automatically",
		     textToStr(cclass(fun(head)).text)
	EEND;
    }
    inst(in).specifics = fst(inst(in).specifics);
    map2Proc(depPredExp,line,tyvars,inst(in).specifics);
    inst(in).numSpecifics = length(inst(in).specifics);

    tmp = getHead(arg(head));
    if (!isTycon(tmp) && !isTuple(tmp)) {
	ERRMSG(line) "Simple type required in instance declaration"
	EEND;
    }
    if (isSynonym(tmp)) {
	ERRMSG(line) "Type synonym \"%s\" not permitted in instance of \"%s\"",
		     textToStr(tycon(tmp).text),
		     textToStr(cclass(fun(head)).text)
	EEND;
    }

    inst(in).c     = fun(head);
    inst(in).t     = tmp;
    inst(in).arity = argCount;
    kindInst(in,head);

    if (nonNull(findInst(inst(in).c,inst(in).t))) {
	ERRMSG(line) "Repeated instance declaration for "
	ETHEN ERRPRED(head);
	ERRTEXT "\n"
	EEND;
    }
    cclass(inst(in).c).instances
	= appendOnto(cclass(inst(in).c).instances,singleton(in));
    

    if (nonNull(extractSigdecls(inst(in).implements))) {
        ERRMSG(line) "Type signature decls not permitted in instance decl"
        EEND;
    }
    inst(in).implements = classBindings("instance",
					inst(in).c,
					extractBindings(inst(in).implements));
}

/* --------------------------------------------------------------------------
 * Verifying superclass constraints:
 *
 * Unlike Gofer, the Haskell report requires strict static checks on
 * instance declarations to ensure that superclass hierarchies can be
 * constructed.  The restrictions are outlined on Pages 41--42 of the
 * Haskell 1.3 report.  The effect of these rules is that, for each
 * pair of declarations:
 *
 *    class C a => D a where ...
 *    instance ps => D (T a1 ... an) where ...
 *
 * there must also be an instance:
 *
 *    instance ps1 => C (T a1 ... an) where ...
 *
 * such that ps1 is always implied by ps.  Since Haskell and Hugs restrict
 * these two contexts to predicates of the form Class var, this is equivalent
 * to requiring that each pi' in ps1 is a subclass (not necessarily proper)
 * of some pi in ps.
 * ------------------------------------------------------------------------*/

static Void local checkInstSC(in)	/* check superclass constraints for*/
Inst in; {				/* a given instance, in		   */
    Class c   = inst(in).c;
    List  scs = cclass(c).supers;
    List  ps  = inst(in).specifics;
    Int   n   = dictSpecificsStart(c);

    for (inst(in).superBuild=NIL; nonNull(scs); scs=tl(scs)) {
	Class sc   = hd(scs);
	Inst  scin = findInst(sc,inst(in).t);
	List  ps1  = NIL;

	if (isNull(scin)) {				/* condition 1	   */
	    Cell cpi  = makeInstPred(in);
	    Cell scpi = ap(sc,arg(cpi));
	    ERRMSG(inst(in).line) "Definition of "   ETHEN ERRPRED(cpi);
	    ERRTEXT " requires superclass instance " ETHEN ERRPRED(scpi);
	    ERRTEXT "\n"
	    EEND;
	}

	for (ps1=inst(scin).specifics; nonNull(ps1); ps1=tl(ps1)) {
	    Cell e = scEvidFrom(hd(ps1),ps,n);		/* condition 2	   */
	    if (nonNull(e))
		scin = ap(scin,e);
	    else {
		Cell cpi  = makeInstPred(in);
		Cell scpi = ap(sc,arg(cpi));
		ERRMSG(inst(in).line) "Cannot build superclass instance "
					     ETHEN ERRPRED(scpi);
		ERRTEXT " of "		     ETHEN ERRPRED(cpi);
		ERRTEXT ":\n*** Context  : " ETHEN ERRCONTEXT(ps);
		ERRTEXT "\n*** Required : "  ETHEN ERRPRED(hd(ps1));
		ERRTEXT "\n"
		EEND;
	    }
	}
	inst(in).superBuild = cons(scin,inst(in).superBuild);
    }
    inst(in).superBuild = rev(inst(in).superBuild);
}

static Cell local scEvidFrom(pi,ps,n)	/* Calculate evidence for pred	   */
Cell pi;				/* pi from ps using superclass	   */
List ps;				/* entailment			   */
Int  n; {
    for (; nonNull(ps); ps=tl(ps), n++)
	if (arg(pi)==arg(hd(ps))) {
	    Cell e = superEvid(mkOffset(n),fun(hd(ps)),fun(pi));
	    if (nonNull(e))
		return e;
	}
    return NIL;
}

/* --------------------------------------------------------------------------
 * Process class and instance declaration binding groups:
 * ------------------------------------------------------------------------*/

static List local classBindings(where,c,bs)
String where;                          /* check validity of bindings bs for*/
Class  c;                              /* class c (or an instance of c)    */
List   bs; {                           /* sort into approp. member order   */
    List nbs = NIL;

    for (; nonNull(bs); bs=tl(bs)) {
	Cell b  = hd(bs);
	Name nm = newName(inventText());   /* pick name for implementation */
	Int  mno;

	if (!isVar(fst(b))) {          /* only allows function bindings    */
	    ERRMSG(rhsLine(snd(snd(snd(b)))))
	       "Pattern binding illegal in %s declaration", where
	    EEND;
	}

	if ((mno=memberNumber(c,textOf(fst(b))))==0) {
	    ERRMSG(rhsLine(snd(hd(snd(snd(b))))))
		"No member \"%s\" in class \"%s\"",
		textToStr(textOf(fst(b))), textToStr(cclass(c).text)
	    EEND;
	}

	name(nm).defn = snd(snd(b));   /* save definition of implementation*/
	nbs           = numInsert(mno-1,nm,nbs);
    }
    return nbs;
}

static Int local memberNumber(c,t)     /* return number of member function */
Class c;                               /* with name t in class c           */
Text  t; {                             /* return 0 if not a member         */
    List ms = cclass(c).members;
    for (; nonNull(ms); ms=tl(ms))
	if (t==name(hd(ms)).text)
	    return mfunOf(hd(ms));
    return 0;
}

static List local numInsert(n,x,xs)    /* insert x at nth position in xs,  */
Int  n;                                /* filling gaps with NIL            */
Cell x;
List xs; {
    List start = isNull(xs) ? cons(NIL,NIL) : xs;

    for (xs=start; 0<n--; xs=tl(xs))
	if (isNull(tl(xs)))
	    tl(xs) = cons(NIL,NIL);
    hd(xs) = x;
    return start;
}

/* --------------------------------------------------------------------------
 * Process derived instance requests:
 * ------------------------------------------------------------------------*/

static List derivedInsts;		/* list of derived instances	   */
static Bool instsChanged;

static Void local checkDerive(t,p,ts,ct)/* verify derived instance request */
Tycon t;				/* for tycon t, with explicit	   */
List  p;				/* context p, component types ts   */
List  ts;				/* and named class ct		   */
Cell  ct; {
    Int   line = tycon(t).line;
    Class c    = findClass(textOf(ct));
    if (nonNull(tycon(t).axioms) && c!=classEq) {
	ERRMSG(line) "Extended types only support derived instances of class \"Eq\""
	EEND;
    }
    if (isNull(c)) {
	ERRMSG(line) "Unknown class \"%s\" in derived instance",
		     textToStr(textOf(ct))
	EEND;
    }
    addDerInst(line,c,p,dupList(ts),t,tycon(t).arity);
}

static Void local addDerInst(line,c,p,cts,t,a)
Int   line;				/* add a derived instance	  */
Class c;
List  p, cts;
Type  t;
Int   a; {
    Inst in;

    if (nonNull(findInst(c,t))) {
	ERRMSG(line) "Duplicate derived instance for class \"%s\"",
		     textToStr(cclass(c).text)
	EEND;
    }

    p = appendOnto(dupList(p),singleton(NIL));	/* set initial values for  */
#define applyClass(t) ap(c,t)			/* derived instance calc.  */
    mapOver(applyClass,cts);
#undef  applyClass

    in		        = newInst();
    inst(in).c          = c;
    inst(in).t          = t;
    inst(in).arity      = a;
    inst(in).line       = line;
    inst(in).specifics  = ap(DERIVE,pair(p,cts));
    inst(in).implements = NIL;
    cclass(c).instances = appendOnto(cclass(c).instances,singleton(in));
    derivedInsts        = cons(in,derivedInsts);
}

Void addTupInst(c,n)			/* Request derived instance of c   */
Class c;				/* for mkTuple(n) constructor	   */
Int   n; {
    Int  m              = n;
    List cts            = NIL;
    while (0<m--)
	cts = cons(mkOffset(m),cts);
    addDerInst(0,c,NIL,cts,mkTuple(n),n);
}

Void addEvalInst(line,t,arity,ctxt)	/* Add dummy instance for Eval	   */
Int  line;
Cell t;
Int  arity;
List ctxt; {
    if (nonNull(findInst(classEval,t)))
	internal("addEvalInst");
    else {
	Inst in		      = newInst();
	inst(in).c	      = classEval;
	inst(in).t	      = t;
	inst(in).arity	      = arity;
	inst(in).line	      = line;
	inst(in).specifics    = ctxt;
	inst(in).numSpecifics = length(ctxt);
	cclass(classEval).instances
		     = appendOnto(cclass(classEval).instances,singleton(in));
    }
}

static Void local deriveContexts(is)	/* Calculate contexts for derived  */
List is; {				/* instances			   */

    mapProc(addDerivImp,is);		/* First, add implementations and  */
    mapProc(expandDComps,is);		/* expand syns in component types  */

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

    for (; nonNull(is); is=tl(is)) {	/* Extract and simplify results	   */
	inst(hd(is)).specifics
	    = superSimp(initSeg(fst(snd(inst(hd(is)).specifics))));
	inst(hd(is)).numSpecifics = length(inst(hd(is)).specifics);
    }
}

static Void local expandDComps(in)	/* Expand away synonyms appearing  */
Inst in; {				/* in the component types	   */
    List cts = snd(snd(inst(in).specifics));
    for (; nonNull(cts); cts=tl(cts))
	snd(hd(cts)) = fullExpand(snd(hd(cts)));
}

static List local superSimp(ps)		/* Simplify preds in ps using super*/
List ps; {				/* class hierarchy ...		   */
    Int n = length(ps);

    while (0<n--)
	if (nonNull(scEvidFrom(hd(ps),tl(ps),0)))
	    ps = tl(ps);
	else {
	    Cell tmp = tl(ps);
	    tl(ps)   = NIL;
	    ps       = appendOnto(tmp,ps);
	}
    return ps;
}

static Void local maybeAddPred(pi,ps)	/* Add predicate pi to the list ps,*/
Cell pi;				/* setting the instsChanged flag if*/
List ps; {				/* pi is not already a member.	   */
    Class c = fun(pi);
    Cell  v = arg(pi);
    for (; nonNull(ps); ps=tl(ps))
	if (isNull(hd(ps))) {		/* reached the `dummy' end of list?*/
	    hd(ps)       = pi;
	    tl(ps)       = pair(NIL,NIL);
	    instsChanged = TRUE;
	    return;
	}
	else if (fun(hd(ps))==c && arg(hd(ps))==v)
	    return;
}

static Cell local instPred(pi,t)	/* Create instance of Hask pred pi */
Cell pi;				/* under the simple substitution   */
Type t; {				/* represented by t		   */
    return ap(fun(pi),nthArg(offsetOf(arg(pi)),t));
}

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));

    while (nonNull(ps)) {
	Cell pi = hd(ps);
	ps      = tl(ps);
	if (isClass(fun(pi))) {			/* Class type		   */
	    if (isOffset(arg(pi)))		/* Class variable	   */
		maybeAddPred(pi,spcs);
	    else {				/* Class (T t1 ... tn)	   */
		Class c   = fun(pi);
		Cell  t   = getHead(arg(pi));
		Inst  in1 = findInst(c,t);

		if (isNull(in1)) {		/* No suitable instance	   */
		    Cell bpi = makeInstPred(in);
		    ERRMSG(inst(in).line) "An instance of " ETHEN ERRPRED(pi);
		    ERRTEXT " is required to derive "      ETHEN ERRPRED(bpi);
		    ERRTEXT "\n"
		    EEND;
		}				/* previously defined inst */
		else if (whatIs(inst(in1).specifics)!=DERIVE) {
		    List qs = inst(in1).specifics;
		    for (; nonNull(qs); qs=tl(qs))
			ps = cons(instPred(hd(qs),arg(pi)),ps);
		}
		else {				/* still being derived	   */
		    List qs = fst(snd(inst(in1).specifics));
		    for (; nonNull(hd(qs)); qs=tl(qs))
			ps = cons(instPred(hd(qs),arg(pi)),ps);
		    retain = cons(pair(arg(pi),qs),retain);
		    instsChanged = TRUE;
		}
	    }
	}
	else {					/* Application of a subst  */
	    List qs = snd(pi);			/* to a list of predicates,*/
	    if (nonNull(hd(qs)))		/* given by a variable	   */
		instsChanged = TRUE;
	    for (; nonNull(hd(qs)); qs=tl(qs))
		ps = cons(instPred(hd(qs),fst(pi)),ps);
	    retain = cons(pair(fst(pi),qs),retain);
	}
    }

    snd(snd(inst(in).specifics)) = retain;
}

/* --------------------------------------------------------------------------
 * Generate code for derived instances:
 * ------------------------------------------------------------------------*/

static Void local addDerivImp(in)
Inst in; {
    List imp = NIL;
    if (inst(in).c==classEq)
	imp = deriveEq(inst(in).t);
    else if (inst(in).c==classOrd)
	imp = deriveOrd(inst(in).t);
    else if (inst(in).c==classEnum)
	imp = deriveEnum(inst(in).t);
    else if (inst(in).c==classIx)
	imp = deriveIx(inst(in).t);
    else if (inst(in).c==classShow)
	imp = deriveShow(inst(in).t);
    else if (inst(in).c==classRead)
	imp = deriveRead(inst(in).t);
    else if (inst(in).c==classBounded)
	imp = deriveBounded(inst(in).t);
    else {
	ERRMSG(inst(in).line) "Cannot derive instances of class \"%s\"",
			      textToStr(cclass(inst(in).c).text)
	EEND;
    }

    inst(in).implements = classBindings("derived instance",
					inst(in).c,
					imp);
}

static List diVars = NIL;		/* Acts as a cache of invented vars*/
static Int  diNum  = 0;

static List local getDiVars(n)		/* get list of at least n vars for */
Int n; {				/* derived instance generation	   */
    for (; diNum<n; diNum++)
	diVars = cons(inventVar(),diVars);
    return diVars;
}

static Cell local mkBind(s,alts)	/* make a binding for a variable   */
String s;
List   alts; {
    return pair(mkVar(findText(s)),pair(NIL,alts));
}

static Cell local mkVarAlts(line,r)	/* make alts for binding a var to  */
Int  line;				/* a simple expression		   */
Cell r; {
    return singleton(pair(NIL,pair(mkInt(line),r)));
}

/* --------------------------------------------------------------------------
 * Given a datatype:   data T a b = A a b | B Int | C  deriving (Eq, Ord)
 * The derived definitions of equality and ordering are given by:
 *
 *   A a b == A x y  =  a==x && b==y
 *   B a   == B x    =  a==x
 *   C     == C      =  True
 *   _     == _      =  False
 *
 *   compare (A a b) (A x y) =  primCompAux a x (compare b y)
 *   compare (B a)   (B x)   =  compare a x
 *   compare C       C       =  EQ
 *   compare a       x       =  cmpConstr a x
 *
 * In each case, the last line is only needed if there are multiple
 * constructors in the datatype definition.
 * ------------------------------------------------------------------------*/

#define ap2(f,x,y) ap(ap(f,x),y)

static List local deriveEq(t)		/* generate binding for derived == */
Type t; {				/* for some TUPLE or DATATYPE t	   */
    List alts = NIL;
    if (isTycon(t)) {			/* deal with type constrs	   */
        List ts = cons(t,tycon(t).axioms);
        for (; nonNull(ts); ts=tl(ts)) {
	    Tycon h = getHead(monoType(hd(ts)));
	    List cs = tycon(h).defn;
	    for (; nonNull(cs); cs=tl(cs))
	        alts = cons(mkAltEq(tycon(t).line,
				    makeDPats2(hd(cs),name(hd(cs)).arity)),
			    alts);
	}
	if (tycon(t).what!=NEWTYPE)
	    alts = cons(pair(cons(WILDCARD,cons(WILDCARD,NIL)),
			     pair(mkInt(tycon(t).line),nameFalse)),alts);
	alts = rev(alts);
    }
    else				/* special case for tuples	   */
	alts = singleton(mkAltEq(0,makeDPats2(t,tupleOf(t))));

    return singleton(mkBind("==",alts));
}

static Pair local mkAltEq(line,pats)	/* make alt for an equation for == */
Int  line;				/* using patterns in pats for lhs  */
List pats; {				/* arguments			   */
    Cell p = hd(pats);
    Cell q = hd(tl(pats));
    Cell e = nameTrue;

    if (isAp(p)) {
	e = ap2(nameEq,arg(p),arg(q));
	for (p=fun(p), q=fun(q); isAp(p); p=fun(p), q=fun(q))
	    e = ap2(nameAnd,ap2(nameEq,arg(p),arg(q)),e);
    }
    return pair(pats,pair(mkInt(line),e));
}

static List local deriveOrd(t)		/* make binding for derived compare*/
Type t; {				/* for some TUPLE or DATATYPE t	   */
    List alts = NIL;
    if (isEnumType(t))			/* special case for enumerations   */
	alts = mkVarAlts(tycon(t).line,nameConCmp);
    else if (isTycon(t)) {		/* deal with type constrs	   */
	List cs = tycon(t).defn;
	for (; nonNull(cs); cs=tl(cs))
	    alts = cons(mkAltOrd(tycon(t).line,
				 makeDPats2(hd(cs),name(hd(cs)).arity)),
			alts);
	if (cfunOf(hd(tycon(t).defn))!=0) {
	    Cell u = inventVar();
	    Cell w = inventVar();
	    alts   = cons(pair(cons(u,singleton(w)),
			       pair(mkInt(tycon(t).line),
				    ap2(nameConCmp,u,w))),alts);
	}
	alts = rev(alts);
    }
    else				/* special case for tuples	   */
	alts = singleton(mkAltOrd(0,makeDPats2(t,tupleOf(t))));

    return singleton(mkBind("compare",alts));
}

static Pair local mkAltOrd(line,pats)	/* make alt for eqn for compare	   */
Int  line;				/* using patterns in pats for lhs  */
List pats; {				/* arguments			   */
    Cell p = hd(pats);
    Cell q = hd(tl(pats));
    Cell e = nameEQ;

    if (isAp(p)) {
	e = ap2(nameCompare,arg(p),arg(q));
	for (p=fun(p), q=fun(q); isAp(p); p=fun(p), q=fun(q))
	    e = ap(ap2(nameCompAux,arg(p),arg(q)),e);
    }

    return pair(pats,pair(mkInt(line),e));
}

static List local makeDPats2(h,n)	/* generate pattern list	   */
Cell h;					/* by putting two new patterns with*/
Int  n; {				/* head h and new var components   */
    List us = getDiVars(2*n);
    List vs = NIL;
    Cell p;
    Int  i;

    for (i=0, p=h; i<n; ++i) {		/* make first version of pattern   */
	p  = ap(p,hd(us));
	us = tl(us);
    }
    vs = cons(p,vs);

    for (i=0, p=h; i<n; ++i) {		/* make second version of pattern  */
	p  = ap(p,hd(us));
	us = tl(us);
    }
    return cons(p,vs);
}

/* --------------------------------------------------------------------------
 * Deriving Ix and Enum:
 * ------------------------------------------------------------------------*/

static List local deriveEnum(t)	/* Construct definition of enumeration	   */
Tycon t; {
    Int l = tycon(t).line;

    if (!isEnumType(t)) {
	ERRMSG(l) "Can only derive instances of Enum for enumeration types"
	EEND;
    }

    return cons(mkBind("toEnum",mkVarAlts(l,ap(nameEnToEn,hd(tycon(t).defn)))),
	    cons(mkBind("fromEnum",mkVarAlts(l,nameEnFrEn)),
	     cons(mkBind("enumFrom",mkVarAlts(l,nameEnFrom)),
	      cons(mkBind("enumFromTo",mkVarAlts(l,nameEnFrTo)),
	       cons(mkBind("enumFromThen",mkVarAlts(l,nameEnFrTh)),NIL)))));
}

static List local deriveIx(t)	/* Construct definition of indexing	   */
Tycon t; {
    if (isEnumType(t))		/* Definitions for enumerations		   */
	return cons(mkBind("range",mkVarAlts(tycon(t).line,nameEnRange)),
		cons(mkBind("index",mkVarAlts(tycon(t).line,nameEnIndex)),
		 cons(mkBind("inRange",mkVarAlts(tycon(t).line,nameEnInRng)),
		  NIL)));
    else if (isTuple(t))	/* Definitions for product types	   */
	return mkIxBinds(0,t,tupleOf(t));
    else if (isTycon(t) && cfunOf(hd(tycon(t).defn))==0)
	return mkIxBinds(tycon(t).line,
			 hd(tycon(t).defn),
			 name(hd(tycon(t).defn)).arity);

    ERRMSG(tycon(t).line)
	"Can only derive instances of Ix for enumeration or product types"
    EEND;
    return NIL;/* NOTREACHED*/
}

static Bool local isEnumType(t)	/* Determine whether t is an enumeration   */
Tycon t; {			/* type (i.e. all constructors arity == 0) */
    if (isTycon(t) && (tycon(t).what==DATATYPE || tycon(t).what==NEWTYPE)) {
	List cs = tycon(t).defn;
	for (; nonNull(cs); cs=tl(cs))
	    if (name(hd(cs)).arity!=0)
		return FALSE;
	addCfunTable(t);
	return TRUE;
    }
    return FALSE;
}

static List local mkIxBinds(line,h,n)	/* build bindings for derived Ix on*/
Int  line;				/* a product type		   */
Cell h;
Int  n; {
    List vs   = getDiVars(3*n);
    Cell ls   = h;
    Cell us   = h;
    Cell is   = h;
    Cell pr   = NIL;
    Cell pats = NIL;
    Int  i;

    for (i=0; i<n; ++i, vs=tl(vs)) {	/* build three patterns for values */
	ls = ap(ls,hd(vs));		/* of the datatype concerned	   */
	us = ap(us,hd(vs=tl(vs)));
	is = ap(is,hd(vs=tl(vs)));
    }
    pr   = ap2(mkTuple(2),ls,us);	/* Build (ls,us)		   */
    pats = cons(pr,cons(is,NIL));	/* Build [(ls,us),is]		   */

    return cons(prodRange(line,singleton(pr),ls,us,is),
		cons(prodIndex(line,pats,ls,us,is),
		     cons(prodInRange(line,pats,ls,us,is),NIL)));
}

static Cell local prodRange(line,pats,ls,us,is)
Int  line;				/* Make definition of range for a  */
List pats;				/* product type			   */
Cell ls, us, is; {
    /* range :: (a,a) -> [a]
     * range (X a b c, X p q r)
     *   = [ X x y z | x <- range (a,p), y <- range (b,q), z <- range (c,r) ]
     */
    Cell is1 = is;
    List e   = NIL;
    for (; isAp(ls); ls=fun(ls), us=fun(us), is=fun(is))
	e = cons(ap(FROMQUAL,pair(arg(is),
				  ap(nameRange,ap2(mkTuple(2),
						   arg(ls),
						   arg(us))))),e);
    e = ap(COMP,pair(is1,e));
    e = singleton(pair(pats,pair(mkInt(line),e)));
    return mkBind("range",e);
}

static Cell local prodIndex(line,pats,ls,us,is)
Int  line;				/* Make definition of index for a  */
List pats;				/* product type			   */
Cell ls, us, is; {
    /* index :: (a,a) -> a -> Bool
     * index (X a b c, X p q r) (X x y z)
     *  = index (c,r) z + rangeSize (c,r) * (
     *     index (b,q) y + rangeSize (b,q) * (
     *      index (a,x) x))
     */
    List xs = NIL;
    Cell e  = NIL;
    for (; isAp(ls); ls=fun(ls), us=fun(us), is=fun(is))
	xs = cons(ap2(nameIndex,ap2(mkTuple(2),arg(ls),arg(us)),arg(is)),xs);
    for (e=hd(xs); nonNull(xs=tl(xs));) {
	Cell x = hd(xs);
	e = ap2(namePlus,x,ap2(nameMult,ap(nameRangeSize,arg(fun(x))),e));
    }
    e = singleton(pair(pats,pair(mkInt(line),e)));
    return mkBind("index",e);
}

static Cell local prodInRange(line,pats,ls,us,is)
Int  line;				/* Make definition of inRange for a*/
List pats;				/* product type			   */
Cell ls, us, is; {
    /* inRange :: (a,a) -> a -> Bool
     * inRange (X a b c, X p q r) (X x y z)
     *          = inRange (a,p) x && inRange (b,q) y && inRange (c,r) z
     */
    Cell e = ap2(nameInRange,ap2(mkTuple(2),arg(ls),arg(us)),arg(is));
    while (ls=fun(ls), us=fun(us), is=fun(is), isAp(ls))
	e = ap2(nameAnd,
		ap2(nameInRange,ap2(mkTuple(2),arg(ls),arg(us)),arg(is)),
		e);
    e = singleton(pair(pats,pair(mkInt(line),e)));
    return mkBind("inRange",e);
}

/* --------------------------------------------------------------------------
 * Deriving Show:
 * ------------------------------------------------------------------------*/

static List local deriveShow(t)	/* Construct definition of text conversion */
Tycon t; {
    List alts = NIL;
    if (isTycon(t)) {			/* deal with type constrs	   */
	List cs = tycon(t).defn;
	for (; nonNull(cs); cs=tl(cs))
	    alts = cons(mkAltShow(tycon(t).line,hd(cs),name(hd(cs)).arity),
			alts);
	alts = rev(alts);
    }
    else				/* special case for tuples	   */
	alts = singleton(mkAltShow(0,t,tupleOf(t)));

    return singleton(mkBind("showsPrec",alts));
}

static Cell local mkAltShow(line,h,a)	/* make alt for showsPrec eqn	   */
Int  line;
Cell h;
Int  a; {
    List vs   = getDiVars(a+1);
    Cell d    = hd(vs);
    Cell pat  = h;
    List pats = NIL;
    while (vs=tl(vs), 0<a--)
	pat = ap(pat,hd(vs));
    pats = cons(d,cons(pat,NIL));
    return pair(pats,pair(mkInt(line),showsPrecRhs(d,pat)));
}

#define shows0   ap(nameShowsPrec,mkInt(0))
#define shows10  ap(nameShowsPrec,mkInt(10))
#define showsOP  ap(nameComp,consChar('('))
#define showsOB  ap(nameComp,consChar('{'))
#define showsCM  ap(nameComp,consChar(','))
#define showsSP  ap(nameComp,consChar(' '))
#define showsBQ  ap(nameComp,consChar('`'))
#define showsCP  consChar(')')
#define showsCB  consChar('}')

static Cell local showsPrecRhs(d,pat)	/* build a rhs for showsPrec for a */
Cell d, pat; {				/* given pattern, pat		   */
    Cell h   = getHead(pat);

    if (isTuple(h)) {
	/* To display a tuple:
	 *    showsPrec d (a,b,c,d) = showChar '(' . showsPrec 0 a .
	 *			      showChar ',' . showsPrec 0 b .
	 *			      showChar ',' . showsPrec 0 c .
	 *			      showChar ',' . showsPrec 0 d .
	 *			      showChar ')'
	 */
	Int  i   = tupleOf(h);
	Cell rhs = showsCP;
	for (; i>1; --i) {
            rhs = ap(showsCM,ap2(nameComp,ap(shows0,arg(pat)),rhs));
	    pat = fun(pat);
	}
	return ap(showsOP,ap2(nameComp,ap(shows0,arg(pat)),rhs));
    }

    if (name(h).arity==0)
	/* To display a nullary constructor:
	 *    showsPrec d Foo = showString "Foo"
	 */
	return ap(nameApp,mkStr(name(h).text));
    else {
	Syntax s = syntaxOf(name(h).text);
	if (name(h).arity==2 && assocOf(s)!=APPLIC) {
	    /* For a binary constructor with prec p:
	     * showsPrec d (a :* b) = showParen (d > p)
	     *				(showsPrec lp a . showChar ' ' .
	     *				 showsString s  . showChar ' ' .
	     *				 showsPrec rp b)
	     */
	    Int  p   = precOf(s);
	    Int  lp  = (assocOf(s)==LEFT_ASS)  ? p : (p+1);
	    Int  rp  = (assocOf(s)==RIGHT_ASS) ? p : (p+1);
	    Cell rhs = ap(showsSP,ap2(nameShowsPrec,mkInt(rp),arg(pat)));
	    if (defaultSyntax(name(h).text)==APPLIC)
		rhs = ap(showsBQ,
			 ap2(nameComp,
			     ap(nameApp,mkStr(name(h).text)),
			     ap(showsBQ,rhs)));
	    else
		rhs = ap2(nameComp,ap(nameApp,mkStr(name(h).text)),rhs);

	    rhs = ap2(nameComp,
		      ap2(nameShowsPrec,mkInt(lp),arg(fun(pat))),
		      ap(showsSP,rhs));
	    rhs = ap2(nameShowParen,ap2(nameLe,mkInt(p+1),d),rhs);
	    return rhs;
	}
	else {
	    /* To display a non-nullary constructor with applicative syntax:
	     *    showsPrec d (Foo x y) = showParen (d>=10)
	     *				   (showString "Foo" .
	     *				    showChar ' ' . showsPrec 10 x .
	     *				    showChar ' ' . showsPrec 10 y)
	     */
	    Cell rhs = ap(showsSP,ap(shows10,arg(pat)));
	    for (pat=fun(pat); isAp(pat); pat=fun(pat))
		rhs = ap(showsSP,ap2(nameComp,ap(shows10,arg(pat)),rhs));
	    rhs = ap2(nameComp,ap(nameApp,mkStr(name(h).text)),rhs);
	    rhs = ap2(nameShowParen,ap2(nameLe,mkInt(10),d),rhs);
	    return rhs;
	}
    }
}
#undef  shows10
#undef  shows0
#undef  showsOP
#undef  showsOB
#undef  showsCM
#undef  showsSP
#undef  showsBQ
#undef  showsCP
#undef  showsCB

/* --------------------------------------------------------------------------
 * Deriving Read:
 * ------------------------------------------------------------------------*/

static List local deriveRead(t)	/* construct definition of text reader	   */
Tycon t; {
    return NIL;			/* NOT YET IMPLEMENTED			   */
}

/* --------------------------------------------------------------------------
 * Deriving Bounded:
 * ------------------------------------------------------------------------*/

static List local deriveBounded(t)/* construct definition of bounds	   */
Tycon t; {
    if (isEnumType(t)) {
	Cell last  = tycon(t).defn;
	Cell first = hd(last);
	while (nonNull(tl(last)))
	    last = tl(last);
	return cons(mkBind("minBound",mkVarAlts(tycon(t).line,first)),
		cons(mkBind("maxBound",mkVarAlts(tycon(t).line,hd(last))),
		 NIL));
    }
    else if (isTuple(t))	/* Definitions for product types	   */
	return mkBndBinds(0,t,tupleOf(t));
    else if (isTycon(t) && cfunOf(hd(tycon(t).defn))==0)
	return mkBndBinds(tycon(t).line,
			  hd(tycon(t).defn),
			  name(hd(tycon(t).defn)).arity);

    ERRMSG(tycon(t).line)
     "Can only derive instances of Bounded for enumeration and product types"
    EEND;
    return NIL;
}

static List local mkBndBinds(line,h,n)	/* build bindings for derived	   */
Int  line;				/* Bounded on a product type	   */
Cell h;
Int  n; {
    Cell minB = h;
    Cell maxB = h;
    while (n-- > 0) {
	minB = ap(minB,nameMinBnd);
	maxB = ap(maxB,nameMaxBnd);
    }
    return cons(mkBind("minBound",mkVarAlts(line,minB)),
	    cons(mkBind("maxBound",mkVarAlts(line,maxB)),
	     NIL));
}

/* --------------------------------------------------------------------------
 * Primitive definitions are usually only included in the first script
 * file read - the prelude.  A primitive definition associates a variable
 * name with a string (which identifies a built-in primitive) and a type.
 * ------------------------------------------------------------------------*/

Void primDefn(line,prims,type)		/* Handle primitive definitions	   */
Cell line;
List prims;
Cell type; {
    primDefns = cons(triple(line,prims,type),primDefns);
}

static Void local checkPrimDefn(p)	/* Check primitive definition	   */
Triple p; {
    Int  line  = intOf(fst3(p));
    List prims = snd3(p);
    Type type  = thd3(p);
    type = checkSigType(line,"primitive definition",fst(hd(prims)),type);
    for (; nonNull(prims); prims=tl(prims)) {
	Cell   p    = hd(prims);
	Bool   same = isVar(p);
	Text   pt   = textOf(same ? p : fst(p));
	String pr   = textToStr(textOf(same ? p : snd(p)));
	addNewPrim(line,pt,pr,type);
    }
}

static Void local addNewPrim(l,vn,s,t)	/* make binding of variable vn to  */
Int    l;				/* primitive function referred	   */
Text   vn;				/* to by s, with given type t	   */
String s;
Cell   t;{
    Name n = findName(vn);

    if (isNull(n))
	n = newName(vn);
    else if (name(n).defn!=PREDEFINED) {
	ERRMSG(l) "Redeclaration of primitive \"%s\"", textToStr(vn)
	EEND;
    }

    addPrim(l,n,s,t);
}

/* --------------------------------------------------------------------------
 * Default definitions; only one default definition is permitted in a
 * given script file.  If no default is supplied, then a standard system
 * default will be used where necessary.
 * ------------------------------------------------------------------------*/

Void defaultDefn(line,defs)		/* Handle default types definition */
Int  line;
List defs; {
    if (defaultLine!=0) {
        ERRMSG(line) "Multiple default declarations are not permitted in" ETHEN
        ERRTEXT     "a single script file.\n"
	EEND;
    }
    defaultDefns = defs;
    defaultLine  = line;
}

static Void local checkDefaultDefns() {	/* check that default types are	   */
    List  ds = NIL;			/* well-kinded instances of Num	   */

    if (defaultLine!=0) {
	map2Over(depTypeExp,defaultLine,NIL,defaultDefns);
	kindDefaults(defaultLine,defaultDefns);
	mapOver(fullExpand,defaultDefns);
    }
    else
	defaultDefns = stdDefaults;

    if (isNull(classNum))
	classNum = findClass(findText("Num"));

    for (ds=defaultDefns; nonNull(ds); ds=tl(ds))
	if (!mtInst(classNum,hd(ds))) {
	    ERRMSG(defaultLine)
		"Default types must be instances of the Num class"
	    EEND;
	}
}

/* --------------------------------------------------------------------------
 * Static analysis of patterns:
 *
 * Patterns are parsed as ordinary (atomic) expressions.  Static analysis
 * makes the following checks:
 *  - Patterns are well formed (according to pattern syntax), including the
 *    special case of (n+k) patterns.
 *  - All constructor functions have been defined and are used with the
 *    correct number of arguments.
 *  - No variable name is used more than once in a pattern.
 *
 * The list of pattern variables occuring in each pattern is accumulated in
 * a global list `patVars', which must be initialised to NIL at appropriate
 * points before using these routines to check for valid patterns.  This
 * mechanism enables the pattern checking routine to be mapped over a list
 * of patterns, ensuring that no variable occurs more than once in the
 * complete pattern list (as is required on the lhs of a function defn).
 * ------------------------------------------------------------------------*/

static List patVars;		       /* list of vars bound in pattern    */

#if OBJ
static Bool statePat;
static Bool stateInScope;
static Bool withinTemplate;
static List stateVars;
static Bool checkingStruct;
#endif


static Cell local checkPat(line,p)     /* Check valid pattern syntax	   */
Int  line;
Cell p; {
    switch (whatIs(p)) {
	case VARIDCELL :
	case VAROPCELL : 
#if OBJ
			 if (statePat) {
			     if (!varIsMember(textOf(p),stateVars)) {
			 	 ERRMSG(line) "Undefined state variable \"%s\"",
			 	              textToStr(textOf(p))
			 	 EEND;
			     }
			 }
			 else
#endif
			 addPatVar(line,p);
			 break;

	case AP        : return checkMaybeCnkPat(line,p);

	case NAME      :
	case CONIDCELL :
	case CONOPCELL : return checkApPat(line,0,p);

#if BIGNUMS
	case ZERONUM   :
	case POSNUM    :
	case NEGNUM    :
#endif
	case WILDCARD  :
	case STRCELL   :
	case CHARCELL  :
	case INTCELL   : break;

	case ASPAT     : addPatVar(line,fst(snd(p)));
			 snd(snd(p)) = checkPat(line,snd(snd(p)));
			 break;

	case LAZYPAT   : snd(p) = checkPat(line,snd(p));
			 break;

	case FINLIST   : map1Over(checkPat,line,snd(p));
			 break;

	default        : ERRMSG(line) "Illegal pattern syntax"
			 EEND;
    }
    return p;
}

static Cell local checkMaybeCnkPat(l,p)/* Check applicative pattern with   */
Int  l;				       /* the possibility of n+k pattern   */
Cell p; {
#if NPLUSK
    Cell h = getHead(p);

    if (argCount==2 && isVar(h) && textOf(h)==textPlus) {	/* n+k	   */
	Cell v = arg(fun(p));
	if (!isInt(arg(p))) {
		ERRMSG(l) "Second argument in (n+k) pattern must be an integer"
		EEND;
	}
	if (intOf(arg(p))<=0) {
		ERRMSG(l) "Integer k in (n+k) pattern must be > 0"
		EEND;
	}
	fst(fun(p))	 = ADDPAT;
	intValOf(fun(p)) = intOf(arg(p));
	arg(p)		 = checkPat(l,v);
	return p;
    }
#endif
    return checkApPat(l,0,p);
}

static Cell local checkApPat(line,args,p)
Int  line;			       /* check validity of application    */
Int  args;			       /* of constructor to arguments	   */
Cell p; {
    switch (whatIs(p)) {
	case AP        : fun(p) = checkApPat(line,args+1,fun(p));
			 arg(p) = checkPat(line,arg(p));
			 break;

	case TUPLE     : if (tupleOf(p)!=args) {
			     ERRMSG(line) "Illegal tuple pattern"
			     EEND;
			 }
			 break;

	case CONIDCELL :
	case CONOPCELL : p = conDefined(line,textOf(p));
			 checkCfunArgs(line,p,args);
			 break;

	case NAME      : checkIsCfun(line,p);
			 checkCfunArgs(line,p,args);
			 break;

	default        : ERRMSG(line) "Illegal pattern syntax"
			 EEND;
    }
    return p;
}

static Void local addPatVar(line,v)    /* add variable v to list of vars   */
Int  line;			       /* in current pattern, checking for */
Cell v; {			       /* repeated variables.		   */
     Text t = textOf(v);
     List p = NIL;
     List n = patVars;
String var = textToStr(t);

#if OBJ
    checkNoHiding(line,t);
#endif
     for (; nonNull(n); p=n, n=tl(n))
	 if (textOf(hd(n))==t) {
	     ERRMSG(line) "Repeated variable \"%s\" in pattern",
			  textToStr(t)
	     EEND;
	 }

     if (isNull(p))
	 patVars = cons(v,NIL);
     else
	 tl(p)	 = cons(v,NIL);
}

#if OBJ
static Cell local checkAssignPat(l,p)
Int  l;
Cell p; {
    Cell pat   = p;
    Cell h     = getHead(pat);
    Int  bangs = 0;
    
    while (argCount==2 && isVar(h) && textOf(h)==textBang) {
        arg(pat) = depExpr(l,arg(pat));
        pat      = arg(fun(pat));
        h        = getHead(pat);
        bangs++;
    }

    statePat = TRUE;
    pat      = checkPat(l,pat);
    statePat = FALSE;
    
    if (bangs) {
        Name n = findName(textBang);
        Name u = findName(findText("//"));
        if (isNull(n) || isNull(u)) {
            ERRMSG(l) "Array update syntax requires operators \"!\" and \"//\" in scope"
            EEND;
        }
        if (!isVar(pat)) {
	    ERRMSG(l) "Illegal array update syntax"
	    EEND;
	}
    }
    return p;
}

static Void local checkNoHiding(line,t)
Int  line;
Text t; {
     if (checkingStruct)
         return;
     if (varIsMember(t,stateVars)) {
         ERRMSG(line) "Illegal hiding of state variable \"%s\"",
         	      textToStr(t)
         EEND;
     }
     if (t==textSelf) {
         ERRMSG(line) "Illegal use of variable name \"self\""
         EEND;
     }
}
#endif

static Name local selDefined(line,t)   /* check that t is the name of a    */
Int line;			       /* previously defined selector      */
Text t; {			       /* function			   */
    Name n = findName(mkStructSel(t));
    if (isNull(n)) {
        ERRMSG(line) "Undefined selector function \"%s\"", textToStr(t)
        EEND;
    }
    return n;
}

static Name local conDefined(line,t)   /* check that t is the name of a    */
Int line;			       /* previously defined constructor   */
Text t; {			       /* function.			   */
    Cell c=findName(t);
    if (isNull(c)) {
	ERRMSG(line) "Undefined constructor function \"%s\"", textToStr(t)
	EEND;
    }
    checkIsCfun(line,c);
    return c;
}

static Void local checkIsCfun(line,c)  /* Check that c is a constructor fn */
Int  line;
Name c; {
    if (!isCfun(c)) {
	ERRMSG(line) "\"%s\" is not a constructor function",
		     textToStr(name(c).text)
	EEND;
    }
}

static Void local checkCfunArgs(line,c,args)
Int  line;			       /* Check constructor applied with   */
Cell c; 			       /* correct number of arguments	   */
Int  args; {
    if (name(c).arity!=args) {
	ERRMSG(line) "Constructor function \"%s\" needs %d args in pattern",
		     textToStr(name(c).text), name(c).arity
	EEND;
    }
}

/* --------------------------------------------------------------------------
 * Maintaining lists of bound variables and local definitions, for
 * dependency and scope analysis.
 * ------------------------------------------------------------------------*/

static List bounds;		       /* list of lists of bound vars	   */
static List bindings;		       /* list of lists of binds in scope  */
static List depends;		       /* list of lists of dependents	   */

#define saveBvars()	 hd(bounds)    /* list of bvars in current scope   */
#define restoreBvars(bs) hd(bounds)=bs /* restore list of bound variables  */

static Cell local bindPat(line,p)      /* add new bound vars for pattern   */
Int  line;
Cell p; {
    patVars    = NIL;
    p	       = checkPat(line,p);
    hd(bounds) = revOnto(patVars,hd(bounds));
    return p;
}

static Void local bindPats(line,ps)    /* add new bound vars for patterns  */
Int  line;
List ps; {
    patVars    = NIL;
    map1Over(checkPat,line,ps);
    hd(bounds) = revOnto(patVars,hd(bounds));
}

static List local bindGens(line,gs)    /* add new bound vars for patterns  */
Int  line;			       /* in list of generators            */
List gs; {
    patVars    = NIL;
    for (; nonNull(gs); gs = tl(gs))
        checkPat(line,fst(hd(gs)));
    hd(bounds) = revOnto(dupList(patVars),hd(bounds));
    return patVars;
}

/* --------------------------------------------------------------------------
 * Before processing value and type signature declarations, all data and
 * type definitions have been processed so that:
 * - all valid type constructors (with their arities) are known.
 * - all valid constructor functions (with their arities and types) are
 *   known.
 *
 * The result of parsing a list of value declarations is a list of Eqns:
 *	 Eqn ::= (SIGDECL,(Line,[Var],type))  |  (Expr,Rhs)
 * The ordering of the equations in this list is the reverse of the original
 * ordering in the script parsed.  This is a consequence of the structure of
 * the parser ... but also turns out to be most convenient for the static
 * analysis.
 *
 * As the first stage of the static analysis of value declarations, each
 * list of Eqns is converted to a list of Bindings.  As part of this
 * process:
 * - The ordering of the list of Bindings produced is the same as in the
 *   original script.
 * - When a variable (function) is defined over a number of lines, all
 *   of the definitions should appear together and each should give the
 *   same arity to the variable being defined.
 * - No variable can have more than one definition.
 * - For pattern bindings:
 *   - Each lhs is a valid pattern/function lhs, all constructor functions
 *     have been defined and are used with the correct number of arguments.
 *   - Each lhs contains no repeated pattern variables.
 *   - Each equation defines at least one variable (e.g. True = False is
 *     not allowed).
 * - Types appearing in type signatures are well formed:
 *    - Type constructors used are defined and used with correct number
 *	of arguments.
 *    - type variables are replaced by offsets, type constructor names
 *	by Tycons.
 * - Every variable named in a type signature declaration is defined by
 *   one or more equations elsewhere in the script.
 * - No variable has more than one type declaration.
 *
 * ------------------------------------------------------------------------*/

#define bindingType(b) fst(snd(b))     /* type (or types) for binding	   */
#define fbindAlts(b)   snd(snd(b))     /* alternatives for function binding*/

static List local extractGens(es)      /* extract the generators from list */
List es; {                             /* of "equations" (template only)   */
    List gens  = NIL;	 	       /* :: [(Pat,Exp)]	           */

    for(; nonNull(es); es=tl(es))
	if (fst(hd(es))==FROMQUAL)		     /* generator?         */
	    gens = cons(snd(hd(es)),gens);           /* discard tag        */

    return gens;
}

static List local extractSigdecls(es)  /* extract the SIGDECLS from list   */
List es; {			       /* of equations			   */
    List sigDecls  = NIL;	       /* :: [(Line,[Var],Type)]	   */

    for(; nonNull(es); es=tl(es))
	if (fst(hd(es))==SIGDECL)		     /* type-declaration?  */
	    sigDecls = cons(snd(hd(es)),sigDecls);   /* discard tag        */

    return sigDecls;
}

static List local extractBindings(es)  /* extract untyped bindings from    */
List es; {			       /* given list of equations	   */
    Cell lastVar   = NIL;	       /* = var def'd in last eqn (if any) */
    Int  lastArity = 0; 	       /* = number of args in last defn    */
    List bs	   = NIL;	       /* :: [Binding]			   */

    for(; nonNull(es); es=tl(es)) {
	Cell e = hd(es);

	if (fst(e)==FROMQUAL) {			     /* generator?         */
	    /* skip */				     /* (in template only) */
	} else if (fst(e)!=SIGDECL) {
	    Int  line	 = rhsLine(snd(e));
	    Cell lhsHead = getHead(fst(e));

	    switch (whatIs(lhsHead)) {
		case VARIDCELL :
		case VAROPCELL : {		      /* function-binding? */
		    Cell newAlt = pair(getArgs(fst(e)), snd(e));
		    if (nonNull(lastVar) && textOf(lhsHead)==textOf(lastVar)) {
			if (argCount!=lastArity) {
			    ERRMSG(line)
				"Equations give different arities for \"%s\"",
				textToStr(textOf(lhsHead))
			    EEND;
			}
			fbindAlts(hd(bs)) = cons(newAlt,fbindAlts(hd(bs)));
		    }
		    else {
			lastVar   = lhsHead;
			lastArity = argCount;
			notDefined(line,bs,lhsHead);
#if OBJ
			checkNoHiding(line,textOf(lhsHead));
#endif
			bs	  = cons(pair(lhsHead,
					      pair(NIL,
						   singleton(newAlt))),
					 bs);
		    }
		}
		break;

		case CONOPCELL :
		case CONIDCELL :
		case FINLIST   :
		case TUPLE     :
		case NAME      :
		case ASPAT     : lastVar = NIL;       /* pattern-binding?  */
				 patVars = NIL;
				 fst(e)  = checkPat(line,fst(e));
				 if (isNull(patVars)) {
				     ERRMSG(line)
				       "No variables defined in lhs pattern"
				     EEND;
				 }
				 map2Proc(notDefined,line,bs,patVars);
				 bs = cons(pair(patVars,pair(NIL,e)),bs);
				 break;

		default        : ERRMSG(line) "Improper left hand side"
				 EEND;
	    }
	}
    }
    return bs;
}

static List local eqnsToBindings(es)   /* Convert list of equations to list*/
List es; {			       /* of typed bindings		   */
    List bs = extractBindings(es);
    map1Proc(addSigDecl,bs,extractSigdecls(es));
    return bs;
}

static Void local notDefined(line,bs,v)/* check if name already defined in */
Int  line;			       /* list of bindings		   */
List bs;
Cell v; {
    if (nonNull(findBinding(textOf(v),bs))) {
	ERRMSG(line) "\"%s\" multiply defined", textToStr(textOf(v))
	EEND;
    }
}

static Cell local findBinding(t,bs)    /* look for binding for variable t  */
Text t; 			       /* in list of bindings bs	   */
List bs; {
    for (; nonNull(bs); bs=tl(bs))
	if (isVar(fst(hd(bs)))) {		      /* function-binding? */
	    if (textOf(fst(hd(bs)))==t)
		return hd(bs);
	}
	else if (nonNull(varIsMember(t,fst(hd(bs))))) /* pattern-binding?  */
	    return hd(bs);
    return NIL;
}

static Void local addSigDecl(bs,sigDecl)/* add type information to bindings*/
List bs;			       /* :: [Binding]			   */
Cell sigDecl; { 		       /* :: (Line,[Var],Type)		   */
    Int  line = intOf(fst3(sigDecl));
    Cell vs   = snd3(sigDecl);
    Cell type = checkSigType(line,"type declaration",hd(vs),thd3(sigDecl));

    map3Proc(setType,line,type,bs,vs);
}

static Void local setType(line,type,bs,v)
Int  line;			       /* Set type of variable		   */
Cell type;
Cell v;
List bs; {
    Text t = textOf(v);
    Cell b = findBinding(t,bs);

    if (isNull(b)) {
	ERRMSG(line) "Type declaration for variable \"%s\" with no body",
		     textToStr(t)
	EEND;
    }

    if (isVar(fst(b))) {			      /* function-binding? */
	if (isNull(bindingType(b))) {
	    bindingType(b) = type;
	    return;
	}
    }
    else {					      /* pattern-binding?  */
	List vs = fst(b);
	List ts = bindingType(b);

	if (isNull(ts))
	    bindingType(b) = ts = copy(length(vs),NIL);

	while (nonNull(vs) && t!=textOf(hd(vs))) {
	    vs = tl(vs);
	    ts = tl(ts);
	}

	if (nonNull(vs) && isNull(hd(ts))) {
	    hd(ts) = type;
	    return;
	}
    }

    ERRMSG(line) "Repeated type declaration for \"%s\"", textToStr(t)
    EEND;
}

/* --------------------------------------------------------------------------
 * To facilitate dependency analysis, lists of bindings are temporarily
 * augmented with an additional field, which is used in two ways:
 * - to build the `adjacency lists' for the dependency graph. Represented by
 *   a list of pointers to other bindings in the same list of bindings.
 * - to hold strictly positive integer values (depth first search numbers) of
 *   elements `on the stack' during the strongly connected components search
 *   algorithm, or a special value mkInt(0), once the binding has been added
 *   to a particular strongly connected component.
 *
 * Using this extra field, the type of each list of declarations during
 * dependency analysis is [Binding'] where:
 *
 *    Binding' ::= (Var, (Dep, (Type, [Alt])))	      -- function binding
 *		|  ([Var], (Dep, (Type, (Pat,Rhs))))  -- pattern binding
 *
 * ------------------------------------------------------------------------*/

#define depVal(d) (fst(snd(d)))        /* Access to dependency information */

static List local dependencyAnal(bs)   /* Separate lists of bindings into  */
List bs; {			       /* mutually recursive groups in	   */
				       /* order of dependency		   */

    mapProc(addDepField,bs);	       /* add extra field for dependents   */
    mapProc(depBinding,bs);	       /* find dependents of each binding  */
    bs = bscc(bs);		       /* sort to strongly connected comps */
    mapProc(remDepField,bs);	       /* remove dependency info field	   */
    return bs;
}

static List local topDependAnal(bs)    /* Like dependencyAnal(), but at    */
List bs; {			       /* top level, reporting on progress */
    List xs;
    Int  i = 0;

    setGoal("Dependency analysis",(Target)(length(bs)));
    mapProc(addDepField,bs);	       /* add extra field for dependents   */
    for (xs=bs; nonNull(xs); xs=tl(xs)) {
	depBinding(hd(xs));
	soFar((Target)(i++));
    }
    bs = bscc(bs);		       /* sort to strongly connected comps */
    mapProc(remDepField,bs);	       /* remove dependency info field	   */
    done();
    return bs;
}

static Void local addDepField(b)       /* add extra field to binding to    */
Cell b; {			       /* hold list of dependents	   */
    snd(b) = pair(NIL,snd(b));
}

static Void local remDepField(bs)      /* remove dependency field from	   */
List bs; {			       /* list of bindings		   */
    mapProc(remDepField1,bs);
}

static Void local remDepField1(b)      /* remove dependency field from	   */
Cell b; {			       /* single binding		   */
    snd(b) = snd(snd(b));
}

static Void local clearScope() {       /* initialise dependency scoping    */
    bounds   = NIL;
    bindings = NIL;
    depends  = NIL;
}

static Void local withinScope(bs)      /* enter scope of bindings bs	   */
List bs; {
    bounds   = cons(NIL,bounds);
    bindings = cons(bs,bindings);
    depends  = cons(NIL,depends);
}

static Void local leaveScope() {       /* leave scope of last withinScope  */
    bounds   = tl(bounds);
    bindings = tl(bindings);
    depends  = tl(depends);
}

/* --------------------------------------------------------------------------
 * As a side effect of the dependency analysis we also make the following
 * checks:
 * - Each lhs is a valid pattern/function lhs, all constructor functions
 *   have been defined and are used with the correct number of arguments.
 * - No lhs contains repeated pattern variables.
 * - Expressions used on the rhs of an eqn should be well formed.  This
 *   includes:
 *   - Checking for valid patterns (including repeated vars) in lambda,
 *     case, and list comprehension expressions.
 *   - Recursively checking local lists of equations.
 * - No free (i.e. unbound) variables are used in the declaration list.
 * ------------------------------------------------------------------------*/

static Void local depBinding(b)        /* find dependents of binding	   */
Cell b; {
    Cell defpart = snd(snd(snd(b)));   /* definition part of binding	   */

    hd(depends) = NIL;

    if (isVar(fst(b))) {	       /* function-binding?		   */
	mapProc(depAlt,defpart);
    }
    else {			       /* pattern-binding?		   */
	depRhs(snd(defpart));
    }

    depVal(b) = hd(depends);
}

static Void local depSelBind(b)	       /* find dependants of selector bind */
Cell b; {
    Cell alts = snd(snd(b));
    if (!isVar(fst(b))) {              /* only allow function bindings     */
        ERRMSG(rhsLine(snd(hd(alts))))
           "Pattern binding not permitted in struct expression"
        EEND;
    }
    fst(b) = selDefined(rhsLine(snd(hd(alts))),textOf(fst(b)));
    mapProc(depAlt,snd(snd(b)));
}

static Cell local depStruct(l,e)
Int l;
Cell e; {
    Int line = intOf(fst(snd(e)));
    Cell padding = hd(snd(snd(e)));

    if (isCon(padding))
        snd(snd(e)) = tl(snd(snd(e)));
    else
        padding = NIL;

    if (nonNull(extractSigdecls(snd(snd(e))))) {
        ERRMSG(line) 
            "Type signatures not permitted in struct value"
	EEND;
    }

#if OBJ
    checkingStruct = TRUE;
#endif
    snd(snd(e)) = extractBindings(snd(snd(e)));
#if OBJ
    checkingStruct = FALSE;
#endif
    mapProc(depSelBind,snd(snd(e)));

    if (padding) {
        Tycon t = findTycon(textOf(padding));
        List missing = NIL;
        List ts;
        
        if (isNull(t) || tycon(t).what != STRUCTTYPE) {
            ERRMSG(line)
                "Struct padding \"%s\" is not a struct type", 
                textToStr(textOf(padding))
            EEND;
        }
        
        for (ts=cons(t,tycon(t).axioms); nonNull(ts); ts=tl(ts)) {
            Tycon h = getHead(monoType(hd(ts)));
	    List ss = tycon(h).defn;

            for (; nonNull(ss); ss=tl(ss)) {
                List eqns = snd(snd(e));
                for (; nonNull(eqns); eqns=tl(eqns)) 
                    if (fst(hd(eqns)) == hd(ss))
                        break;
                if (isNull(eqns)) {
                    Cell selvar = depVar(line,mkVar(unStructSel(hd(ss))));
                
                    missing = 
                        cons(pair(hd(ss),
                                  pair(NIL,
                                       singleton(pair(NIL,
                                                      pair(mkInt(line),
                                                           selvar))))),
                             missing);
                }
            }
        }
        snd(snd(e)) = appendOnto(snd(snd(e)),missing);
        
        if (isNull(snd(snd(e)))) {
            Type sig = t;
            Int n = tycon(t).arity;
            
            for (; n>0; n--)
                sig = ap(sig,WILDCARD);
                
            return ap(ESIGN,pair(e,sig));
        }
    }
    return e;
}

static Void local depDefaults(c)       /* dependency analysis on defaults  */
Class c; {                             /* from class definition            */
    depClassBindings(cclass(c).defaults);
}

static Void local depInsts(in)         /* dependency analysis on instance  */
Inst in; {                             /* bindings                         */
    depClassBindings(inst(in).implements);
}

static Void local depClassBindings(bs) /* dependency analysis on list of   */
List bs; {                             /* bindings, possibly containing    */
    for (; nonNull(bs); bs=tl(bs))     /* NIL bindings ...                 */
        if (nonNull(hd(bs)))           /* No need to add extra field for   */
	    mapProc(depAlt,name(hd(bs)).defn); /* dependency information.. */
}

static Void local depAlt(a)	       /* find dependents of alternative   */
Cell a; {
    List origBvars = saveBvars();      /* save list of bound variables	   */
    bindPats(rhsLine(snd(a)),fst(a));  /* add new bound vars for patterns  */
    depRhs(snd(a));		       /* find dependents of rhs	   */
    restoreBvars(origBvars);	       /* restore original list of bvars   */
}

static Void local depRhs(r)	       /* find dependents of rhs	   */
Cell r; {
    switch (whatIs(r)) {
	case GUARDED : mapProc(depGuard,snd(r));
		       break;

	case LETREC  : fst(snd(r)) = eqnsToBindings(fst(snd(r)));
		       withinScope(fst(snd(r)));
		       fst(snd(r)) = dependencyAnal(fst(snd(r)));
		       hd(depends) = fst(snd(r));
		       depRhs(snd(snd(r)));
		       leaveScope();
		       break;

	default      : snd(r) = depExpr(intOf(fst(r)),snd(r));
		       break;
    }
}

static Void local depGuard(g)	       /* find dependents of single guarded*/
Cell g; {			       /* expression			   */
    depPair(intOf(fst(g)),snd(g));
}

static Cell local depExpr(line,e)      /* find dependents of expression    */
Int  line;
Cell e; {
    switch (whatIs(e)) {

	case VARIDCELL	:
	case VAROPCELL	: return depVar(line,e);

	case CONIDCELL	:
	case CONOPCELL	: return conDefined(line,textOf(e));

	case AP 	: depPair(line,e);
			  break;

#if BIGNUMS
	case ZERONUM	:
	case POSNUM	:
	case NEGNUM	:
#endif
	case NAME	:
	case TUPLE	:
	case STRCELL	:
	case CHARCELL	:
	case FLOATCELL  :
	case INTCELL	: break;

	case COND	: depTriple(line,snd(e));
			  break;

	case FINLIST	: map1Over(depExpr,line,snd(e));
			  break;

	case LETREC	: fst(snd(e)) = eqnsToBindings(fst(snd(e)));
			  withinScope(fst(snd(e)));
			  fst(snd(e)) = dependencyAnal(fst(snd(e)));
			  hd(depends) = fst(snd(e));
			  snd(snd(e)) = depExpr(line,snd(snd(e)));
			  leaveScope();
			  break;

	case LAMBDA	: depAlt(snd(e));
			  break;

#if OBJ
        case HNDLEXP    : map1Proc(depCaseAlt,line,fst(snd(e)));
        		  snd(snd(e)) = depExpr(line,snd(snd(e)));
			  break;
        
	case TEMPLEXP   : depTempl(line,e);
			  break;	
	case ACTEXP     : 
	case REQEXP     : if (!withinTemplate) {
			      ERRMSG(line) 
				 "%s syntax not allowed outside a template",
				 fst(e)==ACTEXP ? "action" : "request"
			      EEND;
			  }
			  snd(e) = depExpr(line,snd(e));
			  break;
#endif
	case DOCOMP	: depDoComp(line,snd(e),snd(snd(e)));
			  break;
			  
	case COMP	: depComp(line,snd(e),snd(snd(e)));
			  break;

#if LAZY_ST
	case RUNST	: snd(e) = depExpr(line,snd(e));
			  break;
#endif

	case ESIGN	: fst(snd(e)) = depExpr(line,fst(snd(e)));
			  snd(snd(e)) = checkSigType(line,
						     "expression",
						     fst(snd(e)),
						     snd(snd(e)));
			  break;

	case CASE	: fst(snd(e)) = depExpr(line,fst(snd(e)));
			  map1Proc(depCaseAlt,line,snd(snd(e)));
			  break;

	case ASPAT	: ERRMSG(line) "Illegal `@' in expression"
			  EEND;

	case LAZYPAT	: ERRMSG(line) "Illegal `~' in expression"
			  EEND;

	case WILDCARD	: ERRMSG(line) "Illegal `_' in expression"
			  EEND;

	case STRUCTVAL	: e = depStruct(line,e);
	                  break;
			  
	case SELECTION	: if (isVar(snd(e)))        /* selector section? */
			      return selDefined(line,textOf(snd(e)));
			  else
			      return ap(selDefined(line,textOf(snd(snd(e)))),
			                depExpr(line,fst(snd(e))));

	default 	: printf("(%d)\n",e); internal("in depExpr");
   }
   return e;
}

static Void local depPair(line,e)	/* find dependents of pair of exprs*/
Int  line;
Cell e; {
    fst(e) = depExpr(line,fst(e));
    snd(e) = depExpr(line,snd(e));
}

static Void local depTriple(line,e)	/* find dependents of triple exprs */
Int  line;
Cell e; {
    fst3(e) = depExpr(line,fst3(e));
    snd3(e) = depExpr(line,snd3(e));
    thd3(e) = depExpr(line,thd3(e));
}

static Void local depDoComp(l,e,qs)
Int  l;
Cell e;
List qs; {
#if OBJ
    Bool oldStateInScope = stateInScope;
    stateInScope = TRUE;
#endif
    depComp(l,e,qs);
#if OBJ
    stateInScope = oldStateInScope;
#endif
}

static Void local depComp(l,e,qs)	/* find dependents of comprehension*/
Int  l;
Cell e;
List qs; {
    if (isNull(qs))
	fst(e) = depExpr(l,fst(e));
    else {
	Cell q   = hd(qs);
	List qs1 = tl(qs);
	switch (whatIs(q)) {
	    case FROMQUAL   : {   List origBvars = saveBvars();
				  snd(snd(q))    = depExpr(l,snd(snd(q)));
				  fst(snd(q))    = bindPat(l,fst(snd(q)));
				  depComp(l,e,qs1);
				  restoreBvars(origBvars);
			      }
			      break;

	    case QWHERE     : snd(q)      = eqnsToBindings(snd(q));
			      withinScope(snd(q));
			      snd(q)      = dependencyAnal(snd(q));
			      hd(depends) = snd(q);
			      depComp(l,e,qs1);
			      leaveScope();
			      break;

	    case DOQUAL	    : /* fall-thru */
	    case BOOLQUAL   : snd(q) = depExpr(l,snd(q));
			      depComp(l,e,qs1);
			      break;
#if OBJ
	    case ASSIGNQ    : {   Int l       = intOf(fst(snd(snd(q))));
	    		          fst(snd(q)) = checkAssignPat(l,fst(snd(q)));
	    		          snd(snd(snd(q))) = depExpr(l,snd(snd(snd(q))));
	    		      }
	    		      depComp(l,e,qs1);
	    		      break;

	    case WHILEDO    : fst(snd(q)) = depExpr(l,fst(snd(q)));
	    		      snd(snd(q)) = depExpr(l,snd(snd(q)));
	    		      depComp(l,e,qs1);
	    		      break;
	    		      
	    case FORALLDO   : {   List origBvars = saveBvars();
	    			  snd3(snd(q)) = depExpr(l,snd3(snd(q)));
	    			  fst3(snd(q)) = bindPat(l,fst3(snd(q)));
	    			  thd3(snd(q)) = depExpr(l,thd3(snd(q)));
	    			  restoreBvars(origBvars);
	    			  depComp(l,e,qs1);
	    		      }
	                      break;
	                      
	    case FIXDO      : {   List origBvars = saveBvars();
	    			  List fixvars = bindGens(l,snd(q));
	    			  depGens(l,snd(q));
	    			  depComp(l,e,qs1);
	    			  restoreBvars(origBvars);
	    			  snd(q) = pair(fixvars,snd(q));
	    		      }
	    		      break;
#endif
	}
    }
}

static Void local depGens(line,gs)
Int line;
List gs; {
    for (; nonNull(gs); gs = tl(gs))
        snd(hd(gs)) = depExpr(line,snd(hd(gs)));
}

static Void local depCaseAlt(line,a)	/* find dependents of case altern. */
Int  line;
Cell a; {
    List origBvars = saveBvars();	/* save list of bound variables	   */
    fst(a) = bindPat(line,fst(a));	/* add new bound vars for patterns */
    depRhs(snd(a));			/* find dependents of rhs	   */
    restoreBvars(origBvars);		/* restore original list of bvars  */
}

static Cell local depVar(line,e)	/* register occurrence of variable */
Int line;
Cell e; {
    List bounds1   = bounds;
    List bindings1 = bindings;
    List depends1  = depends;
    Text t	   = textOf(e);
    Cell n;

#if OBJ
    if (stateInScope && (n=varIsMember(t,stateVars)))
        return n;
#endif
    
    while (nonNull(bindings1)) {
	n = varIsMember(t,hd(bounds1));   /* look for t in bound variables */
	if (nonNull(n))
	    return n;

	n = findBinding(t,hd(bindings1)); /* look for t in var bindings    */
	if (nonNull(n)) {
	   if (!cellIsMember(n,hd(depends1)))
	       hd(depends1) = cons(n,hd(depends1));
	   return (isVar(fst(n)) ? fst(n) : e);
	}

	bounds1   = tl(bounds1);
	bindings1 = tl(bindings1);
	depends1  = tl(depends1);
    }

    if (isNull(n=findName(t))) {	       /* check global definitions */
	ERRMSG(line) "Undefined variable \"%s\"", textToStr(t)
	EEND;
    }

    return n;
}

#if OBJ
static Void local depTempl(line,e)
Int  line;
Cell e; {
    List gs = snd(fst(snd(e))) = extractGens(fst(fst(snd(e))));
    List bs = fst(fst(snd(e))) = eqnsToBindings(fst(fst(snd(e))));
    List oldBvars          = saveBvars();
    List oldStateVars      = stateVars;
    Bool oldStateInScope   = stateInScope;
    Bool oldWithinTemplate = withinTemplate;
    stateVars      = NIL;
    stateInScope   = FALSE;
    withinTemplate = TRUE;
    
    for (; nonNull(bs); bs=tl(bs)) {
        Cell b = hd(bs);
        if (isVar(fst(b))) {	/* function binding? turn into pattern binding */
            List alts = snd(snd(b));
            Int  l    = rhsLine(snd(hd(alts)));
            if (nonNull(tl(alts))) {
                ERRMSG(l)
                    "Repeated definition of state variable \"%s\"",
                    textToStr(textOf(fst(hd(bs))))
                EEND;
            }
            if (nonNull(fst(hd(alts)))) {
                ERRMSG(l)
                    "Function binding not allowed in state declaration"
                EEND;
            }
            stateVars   = cons(fst(b),stateVars);
            snd(snd(b)) = pair(fst(b),snd(hd(alts)));
            fst(snd(b)) = isNull(fst(snd(b))) ? NIL 
            					: singleton(fst(snd(b)));
            fst(b)      = singleton(fst(b));
        }
        else {			/* pattern binding */
            List vs = fst(hd(bs));
            for (; nonNull(vs); vs=tl(vs))
                stateVars = cons(hd(vs),stateVars);
        }
    }
    hd(bounds) = cons(varSelf,hd(bounds));
    snd(fst(snd(e))) = pair(bindGens(line,gs),gs);
    
    for (bs=fst(fst(snd(e))); nonNull(bs); bs=tl(bs))
        depRhs(snd(snd(snd(hd(bs)))));
    depGens(line,gs);
      
    fst(snd(snd(e))) = depExpr(line,fst(snd(snd(e))));
    map1Proc(depCaseAlt,line,snd(snd(snd(e))));
    
    restoreBvars(oldBvars);
    stateVars      = oldStateVars;
    stateInScope   = oldStateInScope;
    withinTemplate = oldWithinTemplate;
}
#endif

/* --------------------------------------------------------------------------
 * Several parts of this program require an algorithm for sorting a list
 * of values (with some added dependency information) into a list of strongly
 * connected components in which each value appears before its dependents.
 *
 * Each of these algorithms is obtained by parameterising a standard
 * algorithm in "scc.c" as shown below.
 * ------------------------------------------------------------------------*/

#define visited(d) (isInt(DEPENDS(d)))	/* binding already visited ?	   */

static Cell daSccs = NIL;
static Int  daCount;

static Int local sccMin(x,y)	       /* calculate minimum of x,y (unless */
Int x,y; {			       /* y is zero)			   */
    return (x<=y || y==0) ? x : y;
}

#define  SCC2		 tcscc		/* make scc algorithm for Tycons   */
#define  LOWLINK	 tclowlink
#define  DEPENDS(c)      (isTycon(c) ? tycon(c).kind : cclass(c).sig)
#define  SETDEPENDS(c,v) if(isTycon(c)) tycon(c).kind=v; else cclass(c).sig=v
#include "scc.c"
#undef   SETDEPENDS
#undef	 DEPENDS
#undef 	 LOWLINK
#undef	 SCC2

#define  SCC		 bscc		/* make scc algorithm for Bindings */
#define  LOWLINK	 blowlink
#define  DEPENDS(t)	 depVal(t)
#define  SETDEPENDS(c,v) depVal(c)=v
#include "scc.c"
#undef   SETDEPENDS
#undef	 DEPENDS
#undef 	 LOWLINK
#undef	 SCC

/* --------------------------------------------------------------------------
 * Main static analysis:
 * ------------------------------------------------------------------------*/

Void checkExp() {			/* Top level static check on Expr  */
    staticAnalysis(RESET);
    clearScope();			/* Analyse expression in the scope */
    withinScope(NIL);			/* of no local bindings		   */
    inputExpr = depExpr(0,inputExpr);
    leaveScope();
    staticAnalysis(RESET);
}

Void checkDefns() {			/* Top level static analysis	   */
    staticAnalysis(RESET);

    linkPreludeTC();			/* Get prelude tycons and classes  */
    mapProc(checkTyconDefn,tyconDefns);	/* validate tycon definitions	   */
    checkSynonyms(tyconDefns);		/* check synonym definitions	   */
    mapProc(checkClassDefn,classDefns);	/* process class definitions	   */
    mapProc(kindTCGroup,tcscc(tyconDefns,classDefns)); /* attach kinds	   */
    checkSubtypes(tyconDefns);		/* close and check subtyping theory*/
    inferVariances(tyconDefns);		/* infer variance for tycons       */
    deriveEval(tyconDefns);		/* derive instances of Eval	   */
    tyconDefns = NIL;
    mapProc(addMembers,classDefns);	/* add definitions for member funs */
    mapProc(visitClass,classDefns);	/* check class hierarchy	   */
    mapProc(inferClassVariance,classDefns); /* infer variance for class var*/

    mapProc(checkPrimDefn,primDefns);	/* check primitive declarations	   */
    primDefns = NIL;

    instDefns = rev(instDefns);		/* process instance definitions	   */
    mapProc(checkInstDefn,instDefns);

    linkPreludeCM();			/* Get prelude cfuns and mfuns	   */
    deriveContexts(derivedInsts);	/* check derived instances	   */
    instDefns = appendOnto(instDefns,derivedInsts);
    mapProc(checkInstSC,instDefns);
    checkDefaultDefns();		/* validate default definitions	   */

    mapProc(addRSsigdecls,typeInDefns);	/* add sigdecls for RESTRICTSYN	   */
    valDefns = eqnsToBindings(valDefns);/* translate value equations	   */
    map1Proc(opDefined,valDefns,opDefns);/*check all declared ops bound	   */
    mapProc(allNoPrevDef,valDefns);	/* check against previous defns	   */

    mapProc(checkTypeIn,typeInDefns);	/* check restricted synonym defns  */

    clearScope();
    withinScope(valDefns);
    valDefns = topDependAnal(valDefns); /* top level dependency ordering   */
    mapProc(depDefaults,classDefns);    /* dep. analysis on class defaults */
    mapProc(depInsts,instDefns);        /* dep. analysis on inst defns	   */
    leaveScope();

    evalDefaults = defaultDefns;	/* Set defaults for evaluator	   */

    staticAnalysis(RESET);
}

static Void local addRSsigdecls(pr)	/* add sigdecls from TYPE ... IN ..*/
Pair pr; {
    List vs = snd(pr);			/* get list of variables	   */
    for (; nonNull(vs); vs=tl(vs)) {
	if (fst(hd(vs))==SIGDECL) {	/* find a sigdecl		   */
	    valDefns = cons(hd(vs),valDefns);	/* add to valDefns	   */
	    hd(vs)   = hd(snd3(snd(hd(vs))));	/* and replace with var	   */
	}
    }
}

static Void local opDefined(bs,op)	 /* check that op bound in bs	   */
List bs;				 /* (or in current module for	   */
Cell op; {				 /* constructor functions etc...)  */
    Name n;

    if (isNull(findBinding(textOf(op),bs))
           && (isNull(n=findName(textOf(op))) || !nameThisModule(n))) {
	ERRMSG(0) "No top level definition for operator symbol \"%s\"",
		  textToStr(textOf(op))
	EEND;
    }
}

static Void local allNoPrevDef(b)	 /* ensure no previous bindings for*/
Cell b; {				 /* variables in new binding	   */
    if (isVar(fst(b)))
	noPrevDef(rhsLine(snd(hd(snd(snd(b))))),fst(b));
    else {
	Int line = rhsLine(snd(snd(snd(b))));
	map1Proc(noPrevDef,line,fst(b));
    }
}

static Void local noPrevDef(line,v)	 /* ensure no previous binding for */
Int  line;				 /* new variable		   */
Cell v; {
    Name n = findName(textOf(v));

    if (isNull(n)) {
	n            = newName(textOf(v));
	name(n).defn = PREDEFINED;
    }
    else if (name(n).defn!=PREDEFINED) {
	ERRMSG(line) "Attempt to redefine variable \"%s\"",
		     textToStr(name(n).text)
	EEND;
    }
    name(n).line = line;
}

static Void local checkTypeIn(cvs)	/* Check that vars in restricted   */
Pair cvs; {				/* synonym are defined, and replace*/
    Tycon c  = fst(cvs);		/* vars with names		   */
    List  vs = snd(cvs);

    for (; nonNull(vs); vs=tl(vs))
	if (isNull(findName(textOf(hd(vs))))) {
	    ERRMSG(tycon(c).line)
		"No top level binding of \"%s\" for restricted synonym \"%s\"",
		textToStr(textOf(hd(vs))), textToStr(tycon(c).text)
	    EEND;
	}
}

/* --------------------------------------------------------------------------
 * Static Analysis control:
 * ------------------------------------------------------------------------*/

Void staticAnalysis(what)
Int what; {
    switch (what) {
	case INSTALL :
	case RESET   : daSccs	       = NIL;
		       patVars	       = NIL;
		       bounds	       = NIL;
		       bindings	       = NIL;
		       depends         = NIL;
		       tcDeps	       = NIL;
		       derivedInsts    = NIL;
		       diVars	       = NIL;
		       diNum	       = 0;
		       acceptWildcards = FALSE;
#if OBJ
		       statePat        = FALSE;
		       stateInScope    = FALSE;
		       withinTemplate  = FALSE;
		       stateVars       = NIL;
		       checkingStruct  = FALSE;
#endif
		       break;

	case MARK    : mark(daSccs);
		       mark(patVars);
		       mark(bounds);
		       mark(bindings);
		       mark(depends);
		       mark(tcDeps);
		       mark(derivedInsts);
		       mark(diVars);
#if OBJ
		       mark(stateVars);
#endif
		       break;
    }
}

/*-------------------------------------------------------------------------*/