/* -------------------------------------------------------------------------- * Static Analysis for Hugs * * The Hugs 98 system is Copyright (c) Mark P Jones, Alastair Reid, the * Yale Haskell Group, and the OGI School of Science & Engineering at OHSU, * 1994-2003, All rights reserved.  It is distributed as free software under * the license in the file "License", which is included in the distribution. * * $RCSfile: static.c,v $ * $Revision: 1.180 $ * $Date: 2006/08/30 18:46:22 $ * ------------------------------------------------------------------------*/ #include "prelude.h"#include "storage.h"#include "connect.h"#include "machdep.h"#include "errors.h"#include "output.h"#include "subst.h"#include "module.h"#include "opts.h"#include "goal.h" /* -------------------------------------------------------------------------- * local function prototypes: * ------------------------------------------------------------------------*/ static Void   local kindError		Args((Int,Constr,Constr,String,Kind,Int));static Void   local checkQualImport	Args((Pair));static Void   local checkUnqualImport	Args((Triple)); static Void   local checkTyconDefn	Args((Tycon));static Void   local depConstrs		Args((Tycon,List,Cell));static Int    local userArity		Args((Name));static List   local addSels		Args((Int,Name,List,List));static List   local selectCtxt		Args((List,List));static Void   local checkSynonyms	Args((List));static List   local visitSyn		Args((List,Tycon,List));static Type   local fullerExpand	Args((Type));static Type   local instantiateNewtype	Args((Name,Type));static Type   local instantiateSyn	Args((Type,Type)); static Void   local checkClassDefn	Args((Class));static Void   local checkClassDefn2	Args((Class));static Void local checkClassDefn2_      Args((List));static Cell   local depPredExp		Args((Int,List,Cell));static Void   local checkMems		Args((Class,List,Cell));static Void   local checkMems2		Args((Class,Cell));static Void   local addMembers		Args((Class));static Name   local newMember		Args((Int,Int,Cell,Type,Class));static Name   local newDSel		Args((Class,Int));static Text   local generateText	Args((String,Class));static Int    local visitClass		Args((Class)); static List   local classBindings	Args((String,Class,List));static Name   local memberName		Args((Class,Text));static List   local numInsert		Args((Int,Cell,List)); static List   local typeVarsIn		Args((Cell,List,List,List));static List   local maybeAppendVar	Args((Cell,List)); static Type   local checkSigType	Args((Int,String,Cell,Type));static Void   local checkOptQuantVars	Args((Int,List,List));static Type   local depTopType		Args((Int,List,Type));static Type   local depCompType		Args((Int,List,Type));static Type   local depTypeExp		Args((Int,List,Type));static Type   local depTypeVar		Args((Int,List,Text));static List   local checkQuantVars	Args((Int,List,List,Cell));static List   local offsetTyvarsIn	Args((Type,List));static List   local otvars		Args((Cell,List));static Bool   local osubset		Args((List,List));static Void   local kindConstr		Args((Int,Int,Int,Constr));static Kind   local kindAtom		Args((Int,Constr));static Void   local kindPred		Args((Int,Int,Int,Cell));static Void   local kindType		Args((Int,String,Type));static Void   local fixKinds		Args((Void)); static Void   local kindTCGroup		Args((List));static Void   local initTCKind		Args((Cell));static Void   local kindTC		Args((Cell));static Void   local genTC		Args((Cell)); static Void   local checkInstDefn	Args((Inst));static Void   local insertInst		Args((Inst));static Bool   local instCompare		Args((Inst,Inst));static Name   local newInstImp		Args((Inst));static Void   local kindInst		Args((Inst,Int));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 initDerInst		Args((Inst));static Void   local calcInstPreds	Args((Inst));static List   local calcFunDeps		Args((List));static Void   local maybeAddPred	Args((Cell,Int,Int,List));static Cell   local copyAdj		Args((Cell,Int,Int));static Void   local tidyDerInst		Args((Inst));static List   local inheritFundeps      Args((Class,Cell,Int));static Void   local extendFundeps       Args((Class)); static List   local otvarsZonk		Args((Cell,List,Int));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 deriveEnum		Args((Tycon));static List   local deriveIx		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,Int)); static List   local deriveRead		Args((Cell));static Cell   local mkReadCon		Args((Name,Cell,Cell));static Cell   local mkReadPrefix	Args((Cell));static Cell   local mkReadInfix		Args((Cell));static Cell   local mkReadTuple		Args((Cell));static Cell   local mkReadRecord	Args((Cell,List)); static List   local deriveBounded	Args((Tycon));static List   local mkBndBinds		Args((Int,Cell,Int)); static Void   local checkDefaultDefns	Args((Void)); static List   local checkPrimDefn	Args((Triple));static Name   local addNewPrim		Args((Int,Text,String,Cell)); static Void   local checkForeignImport  Args((Name));static Void   local checkForeignExport  Args((Name));static Void   local linkForeign         Args((Name)); static Cell   local tidyInfix		Args((Int,Cell));static Pair   local attachFixity	Args((Int,Cell));static Syntax local lookupSyntax	Args((Text)); 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 addToPatVars	Args((Int,Cell));static Name   local conDefined		Args((Int,Cell,Bool));static Void   local checkIsCfun		Args((Int,Name));static Void   local checkCfunArgs	Args((Int,Cell,Int));static Cell   local checkPatType	Args((Int,String,Cell,Type));static Cell   local applyBtyvs		Args((Cell));static Cell   local bindPat		Args((Int,Cell));static Void   local bindPats		Args((Int,List)); static List   local extractSigdecls	Args((List));static List   local extractFixdecls	Args((List));static List   local extractBindings	Args((List));static List   local getPatVars		Args((Int,Cell,List));static List   local addPatVar		Args((Int,Cell,List));static List   local eqnsToBindings	Args((List,List,List,List));static Void   local notDefined		Args((Int,List,Cell));static Cell   local findBinding		Args((Text,List));static Cell   local getAttr		Args((List,Cell));static Void   local addSigdecl		Args((List,Cell));static Void   local addFixdecl		Args((List,List,List,List,Triple));static Void   local dupFixity		Args((Int,Text));static Void   local missFixity		Args((Int,Text)); 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 saveSyntax		Args((Cell,Cell));static Void   local dropNameClash	Args((Cell));#if IPARAMstatic Bool   local checkIBindings      Args((Int,List));#endif static Void   local depBinding		Args((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 Cell   local depLetRec		Args((Bool,Int,Cell));static Void   local depRhs		Args((Cell));static Void   local depGuard		Args((Cell));static Void   local depPair		Args((Int,Cell));static Void   local depTriple		Args((Int,Cell));static Void   local depComp		Args((Int,Cell,List));#if ZIP_COMPstatic Void   local depZComp		Args((Int,Cell,List));static Void   local depZCompBranch	Args((Int,List));static List   local intersectBinds	Args((List bs1,List bs2));static List   local getBindVars		Args((List bs));#endifstatic Void   local depCaseAlt		Args((Int,Cell));static Cell   local depVar		Args((Int,Cell,Bool));static Cell   local depQVar		Args((Int,Cell,Bool));static Void   local depConFlds		Args((Int,Cell,Bool));static Void   local depUpdFlds		Args((Int,Cell));static List   local depFields		Args((Int,Cell,List,Bool));static Void   local checkNameAmbigName  Args((Int,Name,Bool));static Void   local checkNameAmbig      Args((Int,Text,Cell));static Cell   local checkTyconAmbig     Args((Int,Text,Cell));#if IPARAMstatic Void   local depWith		Args((Int,Cell));static List   local depDwFlds		Args((Int,Cell,List));#endif#if TREXstatic Void   local trexUsed            Args((Void));static Void   local trexLoad            Args((Void));static Cell   local depRecord		Args((Int,Cell));#endif #if MUDOstatic Void   local mdoLoad             Args((Void));static Void   local mdoUsed             Args((Void));static List   local mdoGetPatVarsLet	Args((Int,List,List));static List   local mdoBVars		Args((Int,List));static List   local mdoUsedVars		Args((List,Cell,List,List));static Void   local depRecComp		Args((Int,Cell,List));static Void   local mdoExpandQualifiers Args((Int,Cell,List,List));static Bool   local mdoIsConnected	Args((Cell,List));static Int    local mdoSegment		Args((Cell,List));static Void   local mdoSCC		Args((List));static List   local mdoCleanSegment	Args((Triple));static List   local mdoNoLets		Args((Triple));static Void   local mdoComputeExports	Args((Triple,Cell));static Bool   local mdoUsedInAnySeg	Args((Text,List));/*#define DEBUG_MDO_SEGMENTS*/#endif static List   local tcscc		Args((List,List));static List   local bscc		Args((List)); static Void   local addRSsigdecls	Args((Pair));static Void   local allNoPrevDef	Args((Cell));static Void   local noPrevDef		Args((Int,Cell));static Bool   local odiff		Args((List,List)); static Void   local duplicateError	Args((Int,Module,Text,String));static Void   local checkTypeIn		Args((Pair)); static Bool   local h98Pred		Args((Bool,Cell));static Cell   local h98Context		Args((Bool,List));static Void   local h98CheckCtxt	Args((Int,String,Bool,List,Inst));static Void   local h98CheckType	Args((Int,String,Cell,Type)); /* -------------------------------------------------------------------------- * The code in this file is arranged in roughly the following order: *  - Kind inference preliminaries *  - Module declarations *  - Type declarations (data, type, newtype, type in) *  - Class declarations *  - Type signatures *  - Instance declarations *  - Default declarations *  - Primitive definitions *  - Foreign Function Interface declarations *  - Patterns *  - Infix expressions *  - Value definitions *  - Top-level static analysis and control *  - Haskell 98 compatibility tests * ------------------------------------------------------------------------*/ /* -------------------------------------------------------------------------- * Kind checking preliminaries: * ------------------------------------------------------------------------*/ Bool kindExpert = FALSE;		/* TRUE => display kind errors in  */					/*	   full detail		   */ static Void local kindError(l,c,in,wh,k,o)Int    l;				/* line number near constuctor exp */Constr c;				/* constructor			   */Constr in;				/* context (if any)		   */String wh;				/* place in which error occurs	   */Kind   k;				/* expected kind (k,o)		   */Int    o; {				/* inferred kind (typeIs,typeOff)  */    clearMarks();     if (!kindExpert) {			/* for those with a fear of kinds  */	ERRMSG(l) "Illegal type" ETHEN	if (nonNull(in)) {	    ERRTEXT " \"" ETHEN ERRTYPE(in);	    ERRTEXT "\""  ETHEN	}	ERRTEXT " in %s\n", wh	EEND;    }     ERRMSG(l) "Kind error in %s", wh ETHEN    if (nonNull(in)) {	ERRTEXT "\n*** expression     : " ETHEN ERRTYPE(in);    }    ERRTEXT "\n*** constructor    : " ETHEN ERRTYPE(c);    ERRTEXT "\n*** kind           : " ETHEN ERRKIND(copyType(typeIs,typeOff));    ERRTEXT "\n*** does not match : " ETHEN ERRKIND(copyType(k,o));    if (unifyFails) {	ERRTEXT "\n*** because        : %s", unifyFails ETHEN    }    ERRTEXT "\n"    EEND;} #define shouldKind(l,c,in,wh,k,o)	if (!kunify(typeIs,typeOff,k,o)) \					    kindError(l,c,in,wh,k,o)#define checkKind(l,a,m,c,in,wh,k,o)	kindConstr(l,a,m,c); \					shouldKind(l,c,in,wh,k,o)#define inferKind(k,o)			typeIs=k; typeOff=o static List unkindTypes;		/* types in need of kind annotation*/#if TREXKind   extKind;				/* Kind of extension, *->row->row  */#endif /* -------------------------------------------------------------------------- * Static analysis of modules: * ------------------------------------------------------------------------*/ #if HSCRIPTString reloadModule;#endif Void startModule(nm)                             /* switch to a new module */Cell nm; {    Module m;    Text t = textOf(nm);    if (!isCon(nm)) internal("startModule");    if (isNull(m = findModule(t))) {	m = newModule(t);	if ( moduleUserPrelude == 0 && t == textUserPrelude ) {	  moduleUserPrelude = m;	}    } else if (!isPreludeScript()) {	/* You're allowed to break the rules in the Prelude! */#if HSCRIPT	reloadModule = textToStr(t);#endif	ERRMSG(0) "Module \"%s\" already loaded", textToStr(t)	EEND;    }    setCurrModule(m);} Void setExportList(exps)              /* Add export list to current module */List exps; {    module(currentModule).exports = exps;} static Void local checkQualImport(i)   /* Process qualified import         */Pair i; {    Module m = findModid(snd(i));    if (isNull(m)) {	ERRMSG(0) "Module \"%s\" not previously loaded",		  textToStr(textOf(snd(i)))	EEND;    }    snd(i)=m;} static Void local checkUnqualImport(i) /* Process unqualified import       */Pair i; {    Module m = findModid(fst(i));    if (isNull(m)) {	ERRMSG(0) "Module \"%s\" not previously loaded",		  textToStr(textOf(fst(i)))	EEND;    }    fst(i)=m;} /* the bulk of the module system implementation now resides in module.c */  /* -------------------------------------------------------------------------- * 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)	/* 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...	   */    Text t = textOf(getHead(lhs));    Tycon tc = findTycon(t);     if ( nonNull(tc) ) {	ERRMSG(line) "Multiple declarations of type constructor \"%s\"",		     textToStr(t)	EEND;    } else if (nonNull(tc) && nonNull(tycon(tc).clashes)) {        List ls = tycon(tc).clashes;	ERRMSG(line) "Ambiguous type constructor occurrence \"%s\"", textToStr(t) ETHEN        ERRTEXT "\n*** Could refer to: " ETHEN       ERRTEXT "%s.%s ", textToStr(module(tycon(tc).mod).text), textToStr(tycon(tc).text) ETHEN	for(;nonNull(ls);ls=tl(ls)) {	  ERRTEXT "%s.%s ", textToStr(module(tycon(hd(ls)).mod).text), textToStr(tycon(hd(ls)).text)	  ETHEN	}	ERRTEXT "\n" 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;	if (what==RESTRICTSYN) {	    h98DoesntSupport(line,"restricted type synonyms");	    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 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)))) {

Lines 1–500 of 7397. Load more