X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Finterpreter%2Fstatic.c;h=16fad260e804d2936688594c99ae4311bfaab722;hb=313a61d546f55bb2c098ecd0ebb42e15d943201e;hp=601ef0a626c04b1dabb8156eb43a34a269504a8f;hpb=438596897ebbe25a07e1c82085cfbc5bdb00f09e;p=ghc-hetmet.git diff --git a/ghc/interpreter/static.c b/ghc/interpreter/static.c index 601ef0a..16fad26 100644 --- a/ghc/interpreter/static.c +++ b/ghc/interpreter/static.c @@ -1,176 +1,203 @@ -/* -*- mode: hugs-c; -*- */ + /* -------------------------------------------------------------------------- * Static Analysis for Hugs * - * Copyright (c) The University of Nottingham and Yale University, 1994-1997. - * All rights reserved. See NOTICE for details and conditions of use etc... - * Hugs version 1.4, December 1997 + * The Hugs 98 system is Copyright (c) Mark P Jones, Alastair Reid, the + * Yale Haskell Group, and the Oregon Graduate Institute of Science and + * Technology, 1994-1999, 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.2 $ - * $Date: 1998/12/02 13:22:35 $ + * $Revision: 1.40 $ + * $Date: 2000/04/07 10:00:28 $ * ------------------------------------------------------------------------*/ -#include "prelude.h" +#include "hugsbasictypes.h" #include "storage.h" #include "connect.h" -#include "input.h" -#include "type.h" -#include "static.h" -#include "translate.h" -#include "hugs.h" /* for target */ #include "errors.h" -#include "subst.h" -#include "link.h" -#include "modules.h" -#include "derive.h" /* -------------------------------------------------------------------------- * local function prototypes: * ------------------------------------------------------------------------*/ -static Module thisModule = 0; /* module currently being processed*/ - -static Void local kindError Args((Int,Constr,Constr,String,Kind,Int)); - -static Void local checkTyconDefn Args((Tycon)); -static Void local depConstrs Args((Tycon,List,Cell)); -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)); -#if EVAL_INSTANCES -static Void local deriveEval Args((List)); -static List local calcEvalContexts Args((Tycon,List,List)); +static Void local kindError ( Int,Constr,Constr,String,Kind,Int ); +static Void local checkQualImport ( Pair ); +static Void local checkUnqualImport ( Triple ); + +static Name local lookupName ( Text,List ); +static List local checkSubentities ( List,List,List,String,Text ); +static List local checkExportTycon ( List,Text,Cell,Tycon ); +static List local checkExportClass ( List,Text,Cell,Class ); +static List local checkExport ( List,Text,Cell ); +static List local checkImportEntity ( List,Module,Cell ); +static List local resolveImportList ( Module,Cell ); +static Void local checkImportList ( Pair ); + +static Void local importEntity ( Module,Cell ); +static Void local importName ( Module,Name ); +static Void local importTycon ( Module,Tycon ); +static Void local importClass ( Module,Class ); +static List local checkExports ( List, Module ); + +static Void local checkTyconDefn ( Tycon ); +static Void local depConstrs ( Tycon,List,Cell ); +static List local addSels ( Int,Name,List,List ); +static List local selectCtxt ( List,List ); +static Void local checkSynonyms ( List ); +static List local visitSyn ( List,Tycon,List ); +static Type local instantiateSyn ( Type,Type ); + +static Void local checkClassDefn ( Class ); +static Cell local depPredExp ( Int,List,Cell ); +static Void local checkMems ( Class,List,Cell ); +static Void local checkMems2 ( Class,Cell ); +static Void local addMembers ( Class ); +static Name local newMember ( Int,Int,Cell,Type,Class ); +static Text local generateText ( String,Class ); + +static List local classBindings ( String,Class,List ); +static Name local memberName ( Class,Text ); +static List local numInsert ( Int,Cell,List ); + +static List local maybeAppendVar ( Cell,List ); + +static Type local checkSigType ( Int,String,Cell,Type ); +static Void local checkOptQuantVars ( Int,List,List ); +static Type local depTopType ( Int,List,Type ); +static Type local depCompType ( Int,List,Type ); +static Type local depTypeExp ( Int,List,Type ); +static Type local depTypeVar ( Int,List,Text ); +static List local checkQuantVars ( Int,List,List,Cell ); +static List local otvars ( Cell,List ); +static Bool local osubset ( List,List ); +static Void local kindConstr ( Int,Int,Int,Constr ); +static Kind local kindAtom ( Int,Constr ); +static Void local kindPred ( Int,Int,Int,Cell ); +static Void local kindType ( Int,String,Type ); +static Void local fixKinds ( Void ); + +static Void local kindTCGroup ( List ); +static Void local initTCKind ( Cell ); +static Void local kindTC ( Cell ); +static Void local genTC ( Cell ); + +static Void local checkInstDefn ( Inst ); +static Void local insertInst ( Inst ); +static Bool local instCompare ( Inst,Inst ); +static Name local newInstImp ( Inst ); +static Void local kindInst ( Inst,Int ); +static Void local checkDerive ( Tycon,List,List,Cell ); +static Void local addDerInst ( Int,Class,List,List,Type,Int ); +static Void local deriveContexts ( List ); +static Void local initDerInst ( Inst ); +static Void local calcInstPreds ( Inst ); +static Void local maybeAddPred ( Cell,Int,Int,List ); +static List local calcFunDeps ( List ); +static Cell local copyAdj ( Cell,Int,Int ); +static Void local tidyDerInst ( Inst ); +static List local otvarsZonk ( Cell,List,Int ); + +static Void local addDerivImp ( Inst ); + +static Void local checkDefaultDefns ( Void ); + +static Void local checkForeignImport ( Name ); +static Void local checkForeignExport ( Name ); + +static Cell local tidyInfix ( Int,Cell ); +static Pair local attachFixity ( Int,Cell ); +static Syntax local lookupSyntax ( Text ); + +static Cell local checkPat ( Int,Cell ); +static Cell local checkMaybeCnkPat ( Int,Cell ); +static Cell local checkApPat ( Int,Int,Cell ); +static Void local addToPatVars ( Int,Cell ); +static Name local conDefined ( Int,Cell ); +static Void local checkIsCfun ( Int,Name ); +static Void local checkCfunArgs ( Int,Cell,Int ); +static Cell local checkPatType ( Int,String,Cell,Type ); +static Cell local applyBtyvs ( Cell ); +static Cell local bindPat ( Int,Cell ); +static Void local bindPats ( Int,List ); + +static List local extractSigdecls ( List ); +static List local extractFixdecls ( List ); +static List local extractBindings ( List ); +static List local getPatVars ( Int,Cell,List ); +static List local addPatVar ( Int,Cell,List ); +static List local eqnsToBindings ( List,List,List,List ); +static Void local notDefined ( Int,List,Cell ); +static Cell local findBinding ( Text,List ); +static Cell local getAttr ( List,Cell ); +static Void local addSigdecl ( List,Cell ); +static Void local addFixdecl ( List,List,List,List,Triple ); +static Void local dupFixity ( Int,Text ); +static Void local missFixity ( Int,Text ); + +static List local dependencyAnal ( List ); +static List local topDependAnal ( List ); +static Void local addDepField ( Cell ); +static Void local remDepField ( List ); +static Void local remDepField1 ( Cell ); +static Void local clearScope ( Void ); +static Void local withinScope ( List ); +static Void local leaveScope ( Void ); +static Void local saveSyntax ( Cell,Cell ); + +static Void local depBinding ( Cell ); +static Void local depDefaults ( Class ); +static Void local depInsts ( Inst ); +static Void local depClassBindings ( List ); +static Void local depAlt ( Cell ); +static Void local depRhs ( Cell ); +static Void local depGuard ( Cell ); +static Cell local depExpr ( Int,Cell ); +static Void local depPair ( Int,Cell ); +static Void local depTriple ( Int,Cell ); +static Void local depComp ( Int,Cell,List ); +static Void local depCaseAlt ( Int,Cell ); +static Cell local depVar ( Int,Cell ); +static Cell local depQVar ( Int,Cell ); +static Void local depConFlds ( Int,Cell,Bool ); +static Void local depUpdFlds ( Int,Cell ); +static List local depFields ( Int,Cell,List,Bool ); +#if IPARAM +static Void local depWith ( Int,Cell ); +static List local depDwFlds ( Int,Cell,List ); #endif -static Void local checkBanged Args((Name,Kinds,List,Type)); -static Type local instantiateSyn Args((Type,Type)); - -static Void local checkClassDefn Args((Class)); -static Void local depPredExp Args((Int,List,Cell)); -static Void local checkMems Args((Class,List,Cell)); -static Void local addMembers Args((Class)); -static Name local newMember Args((Int,Int,Cell,Type)); -static Name local newDSel Args((Class,Int)); -static Name local newDBuild Args((Class)); -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)); -static List local maybeAppendVar Args((Cell,List)); - -static Type local checkSigType Args((Int,String,Cell,Type)); -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 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 Void local maybeAddPred Args((Cell,Int,Int,List)); -static Cell local copyAdj Args((Cell,Int,Int)); -static Void local tidyDerInst Args((Inst)); - -static Void local addDerivImp Args((Inst)); - -static Void local checkDefaultDefns Args((Void)); - -static Void local checkForeignImport Args((Name)); -static Void local checkForeignExport Args((Name)); - -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)); -static Name local conDefined Args((Int,Cell)); -static Void local checkIsCfun Args((Int,Name)); -static Void local checkCfunArgs Args((Int,Cell,Int)); -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 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 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 depComp Args((Int,Cell,List)); -static Void local depCaseAlt Args((Int,Cell)); -static Cell local depVar Args((Int,Cell)); -static Cell local depQVar Args((Int,Cell)); -static Void local depConFlds Args((Int,Cell,Bool)); -static Void local depUpdFlds Args((Int,Cell)); -static List local depFields Args((Int,Cell,List,Bool)); #if TREX -static Cell local depRecord Args((Int,Cell)); +static Cell local depRecord ( Int,Cell ); #endif -static List local tcscc Args((List,List)); -static List local bscc Args((List)); +static List local tcscc ( List,List ); +static List local bscc ( 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 duplicateError Args((Int,Module,Text,String)); -static Void local checkTypeIn Args((Pair)); +static Void local addRSsigdecls ( Pair ); +static Void local allNoPrevDef ( Cell ); +static Void local noPrevDef ( Int,Cell ); +static Bool local odiff ( List,List ); + +static Void local duplicateErrorAux ( Int,Module,Text,String ); +#define duplicateError(l,m,t,k) duplicateErrorAux(l,m,t,k) +static Void local checkTypeIn ( Pair ); /* -------------------------------------------------------------------------- * 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 * - Patterns + * - Infix expressions * - Value definitions * - Top-level static analysis and control + * - Haskell 98 compatibility tests * ------------------------------------------------------------------------*/ /* -------------------------------------------------------------------------- @@ -225,6 +252,437 @@ Kind extKind; /* Kind of extension, *->row->row */ #endif /* -------------------------------------------------------------------------- + * Static analysis of modules: + * ------------------------------------------------------------------------*/ + +Void startModule ( Module m ) /* switch to a new module */ +{ + if (isNull(m)) internal("startModule"); + setCurrModule(m); +} + +Void setExportList(exps) /* Add export list to current module */ +List exps; { + module(currentModule).exports = exps; +} + +Void addQualImport(orig,new) /* Add to qualified import list */ +Cell orig; /* Original name of module */ +Cell new; { /* Name module is called within this module (or NIL) */ + module(currentModule).qualImports = + cons(pair(isNull(new)?orig:new,orig),module(currentModule).qualImports); +} + +Void addUnqualImport(mod,entities) /* Add to unqualified import list */ +Cell mod; /* Name of module */ +List entities; { /* List of entity names */ + unqualImports = cons(pair(mod,entities),unqualImports); +} + +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; +} + +static Name local lookupName(t,nms) /* find text t in list of Names */ +Text t; +List nms; { /* :: [Name] */ + for(; nonNull(nms); nms=tl(nms)) { + if (t == name(hd(nms)).text) + return hd(nms); + } + return NIL; +} + +static List local checkSubentities(imports,named,wanted,description,textParent) +List imports; +List named; /* :: [ Q?(Var|Con)(Id|Op) ] */ +List wanted; /* :: [Name] */ +String description; /* "| of |" */ +Text textParent; { + for(; nonNull(named); named=tl(named)) { + Pair x = hd(named); + /* ToDo: ignores qualifier; doesn't check that entity is in scope */ + Text t = isPair(snd(x)) ? qtextOf(x) : textOf(x); + Name n = lookupName(t,wanted); + if (isNull(n)) { + ERRMSG(0) "Entity \"%s\" is not a %s \"%s\"", + textToStr(t), + description, + textToStr(textParent) + EEND; + } + imports = cons(n,imports); + } + return imports; +} + +static List local checkImportEntity(imports,exporter,entity) +List imports; /* Accumulated list of things to import */ +Module exporter; +Cell entity; { /* Entry from import list */ + List oldImports = imports; + Text t = isIdent(entity) ? textOf(entity) : textOf(fst(entity)); + List es = NIL; + es = module(exporter).exports; + + for(; nonNull(es); es=tl(es)) { + Cell e = hd(es); /* :: Entity + | (Entity, NIL|DOTDOT) + | tycon + | class + */ + if (isPair(e)) { + Cell f = fst(e); + if (isTycon(f)) { + if (tycon(f).text == t) { + imports = cons(f,imports); + if (!isIdent(entity)) { + switch (tycon(f).what) { + case NEWTYPE: + case DATATYPE: + if (DOTDOT == snd(entity)) { + imports = dupOnto(tycon(f).defn,imports); + } else { + imports = checkSubentities( + imports,snd(entity),tycon(f).defn, + "constructor of type",t); + } + break; + default:; + /* deliberate fall thru */ + } + } + } + } else if (isClass(f)) { + if (cclass(f).text == t) { + imports = cons(f,imports); + if (!isIdent(entity)) { + if (DOTDOT == snd(entity)) { + return dupOnto(cclass(f).members,imports); + } else { + return checkSubentities( + imports,snd(entity),cclass(f).members, + "member of class",t); + } + } + } + } else { + internal("checkImportEntity2"); + } + } else if (isName(e)) { + if (isIdent(entity) && name(e).text == t) { + imports = cons(e,imports); + } + } else { + internal("checkImportEntity3"); + } + } + if (imports == oldImports) { + ERRMSG(0) "Unknown entity \"%s\" imported from module \"%s\"", + textToStr(t), + textToStr(module(exporter ).text) + EEND; + } + return imports; +} + +static List local resolveImportList(m,impList) +Module m; /* exporting module */ +Cell impList; { + List imports = NIL; + if (DOTDOT == impList) { + List es = module(m).exports; + for(; nonNull(es); es=tl(es)) { + Cell e = hd(es); + if (isName(e)) { + imports = cons(e,imports); + } else { + Cell c = fst(e); + List subentities = NIL; + imports = cons(c,imports); + if (isTycon(c) + && (tycon(c).what == DATATYPE + || tycon(c).what == NEWTYPE)) + subentities = tycon(c).defn; + else if (isClass(c)) + subentities = cclass(c).members; + if (DOTDOT == snd(e)) { + imports = dupOnto(subentities,imports); + } + } + } + } else { + map1Accum(checkImportEntity,imports,m,impList); + } + return imports; +} + +static Void local checkImportList(importSpec) /*Import a module unqualified*/ +Pair importSpec; { + Module m = fst(importSpec); + Cell impList = snd(importSpec); + + List imports = NIL; /* entities we want to import */ + List hidden = NIL; /* entities we want to hide */ + + if (isPair(impList) && HIDDEN == fst(impList)) { + /* Somewhat inefficient - but obviously correct: + * imports = importsOf("module Foo") `setDifference` hidden; + */ + hidden = resolveImportList(m, snd(impList)); + imports = resolveImportList(m, DOTDOT); + } else { + imports = resolveImportList(m, impList); + } + + for(; nonNull(imports); imports=tl(imports)) { + Cell e = hd(imports); + if (!cellIsMember(e,hidden)) + importEntity(m,e); + } + /* ToDo: hang onto the imports list for processing export list entries + * of the form "module Foo" + */ +} + +static Void local importEntity(source,e) +Module source; +Cell e; { + switch (whatIs(e)) { + case NAME : importName(source,e); + break; + case TUPLE: + case TYCON : importTycon(source,e); + break; + case CLASS : importClass(source,e); + break; + default: internal("importEntity"); + } +} + +static Void local importName(source,n) +Module source; +Name n; { + Name clash = addName(n); + if (nonNull(clash) && clash!=n) { + ERRMSG(0) "Entity \"%s\" imported from module \"%s\"" + " already defined in module \"%s\"", + textToStr(name(n).text), + textToStr(module(source).text), + textToStr(module(name(clash).mod).text) + EEND; + } +} + +static Void local importTycon(source,tc) +Module source; +Tycon tc; { + Tycon clash=addTycon(tc); + if (nonNull(clash) && clash!=tc) { + ERRMSG(0) "Tycon \"%s\" imported from \"%s\" already defined in module \"%s\"", + textToStr(tycon(tc).text), + textToStr(module(source).text), + textToStr(module(tycon(clash).mod).text) + EEND; + } + if (nonNull(findClass(tycon(tc).text))) { + ERRMSG(0) "Import of type constructor \"%s\" clashes with class in module \"%s\"", + textToStr(tycon(tc).text), + textToStr(module(tycon(tc).mod).text) + EEND; + } +} + +static Void local importClass(source,c) +Module source; +Class c; { + Class clash=addClass(c); + if (nonNull(clash) && clash!=c) { + ERRMSG(0) "Class \"%s\" imported from \"%s\" already defined in module \"%s\"", + textToStr(cclass(c).text), + textToStr(module(source).text), + textToStr(module(cclass(clash).mod).text) + EEND; + } + if (nonNull(findTycon(cclass(c).text))) { + ERRMSG(0) "Import of class \"%s\" clashes with type constructor in module \"%s\"", + textToStr(cclass(c).text), + textToStr(module(source).text) + EEND; + } +} + +static List local checkExportTycon(exports,mt,spec,tc) +List exports; +Text mt; +Cell spec; +Tycon tc; { + if (DOTDOT == spec || SYNONYM == tycon(tc).what) { + return cons(pair(tc,DOTDOT), exports); + } else { + return cons(pair(tc,NIL), exports); + } +} + +static List local checkExportClass(exports,mt,spec,cl) +List exports; +Text mt; +Class cl; +Cell spec; { + if (DOTDOT == spec) { + return cons(pair(cl,DOTDOT), exports); + } else { + return cons(pair(cl,NIL), exports); + } +} + +static List local checkExport(exports,mt,e) /* Process entry in export list*/ +List exports; +Text mt; +Cell e; { + if (isIdent(e)) { + Cell export = NIL; + List origExports = exports; + if (nonNull(export=findQualName(e))) { + exports=cons(export,exports); + } + if (isQCon(e) && nonNull(export=findQualTycon(e))) { + exports = checkExportTycon(exports,mt,NIL,export); + } + if (isQCon(e) && nonNull(export=findQualClass(e))) { + /* opaque class export */ + exports = checkExportClass(exports,mt,NIL,export); + } + if (exports == origExports) { + ERRMSG(0) "Unknown entity \"%s\" exported from module \"%s\"", + identToStr(e), + textToStr(mt) + EEND; + } + return exports; + } else if (MODULEENT == fst(e)) { + Module m = findModid(snd(e)); + /* ToDo: shouldn't allow export of module we didn't import */ + if (isNull(m)) { + ERRMSG(0) "Unknown module \"%s\" exported from module \"%s\"", + textToStr(textOf(snd(e))), + textToStr(mt) + EEND; + } + if (m == currentModule) { + /* Exporting the current module exports local definitions */ + List xs; + for(xs=module(m).classes; nonNull(xs); xs=tl(xs)) { + if (cclass(hd(xs)).mod==m) + exports = checkExportClass(exports,mt,DOTDOT,hd(xs)); + } + for(xs=module(m).tycons; nonNull(xs); xs=tl(xs)) { + if (tycon(hd(xs)).mod==m) + exports = checkExportTycon(exports,mt,DOTDOT,hd(xs)); + } + for(xs=module(m).names; nonNull(xs); xs=tl(xs)) { + if (name(hd(xs)).mod==m) + exports = cons(hd(xs),exports); + } + } else { + /* Exporting other modules imports all things imported + * unqualified from it. + * ToDo: we reexport everything exported by a module - + * whether we imported it or not. This gives the wrong + * result for "module M(module N) where import N(x)" + */ + exports = dupOnto(module(m).exports,exports); + } + return exports; + } else { + Cell ident = fst(e); /* class name or type name */ + Cell parts = snd(e); /* members or constructors */ + Cell nm; + if (isQCon(ident) && nonNull(nm=findQualTycon(ident))) { + switch (tycon(nm).what) { + case SYNONYM: + if (DOTDOT!=parts) { + ERRMSG(0) "Explicit constructor list given for type synonym" + " \"%s\" in export list of module \"%s\"", + identToStr(ident), + textToStr(mt) + EEND; + } + return cons(pair(nm,DOTDOT),exports); + case RESTRICTSYN: + ERRMSG(0) "Transparent export of restricted type synonym" + " \"%s\" in export list of module \"%s\"", + identToStr(ident), + textToStr(mt) + EEND; + return exports; /* Not reached */ + case NEWTYPE: + case DATATYPE: + if (DOTDOT==parts) { + return cons(pair(nm,DOTDOT),exports); + } else { + exports = checkSubentities(exports,parts,tycon(nm).defn, + "constructor of type", + tycon(nm).text); + return cons(pair(nm,DOTDOT), exports); + } + default: + internal("checkExport1"); + } + } else if (isQCon(ident) && nonNull(nm=findQualClass(ident))) { + if (DOTDOT == parts) { + return cons(pair(nm,DOTDOT),exports); + } else { + exports = checkSubentities(exports,parts,cclass(nm).members, + "member of class",cclass(nm).text); + return cons(pair(nm,DOTDOT), exports); + } + } else { + ERRMSG(0) "Explicit export list given for non-class/datatype \"%s\" in export list of module \"%s\"", + identToStr(ident), + textToStr(mt) + EEND; + } + } + return exports; /* NOTUSED */ +} + +static List local checkExports ( List exports, Module thisModule ) +{ + Module m = thisModule; + Text mt = module(m).text; + List es = NIL; + + map1Accum(checkExport,es,mt,exports); + +#if DEBUG_MODULES + for(xs=es; nonNull(xs); xs=tl(xs)) { + Printf(" %s", textToStr(textOfEntity(hd(xs)))); + } +#endif + return es; +} + + +/* -------------------------------------------------------------------------- * Static analysis of type declarations: * * Type declarations come in two forms: @@ -265,6 +723,7 @@ Cell what; { /* SYNONYM/DATATYPE/etc... */ 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); } @@ -370,16 +829,16 @@ Cell cd; { /* definitions (w or w/o deriving) */ List derivs = snd(cd); List compTypes = NIL; List sels = NIL; - Int ntvs = length(tyvars); Int i; for (i=0; i0) /* Add rank 2 annotation */ - type = ap(RANK2,pair(mkInt(nr2),type)); + if (nr2>0) { /* Add rank 2 annotation */ + type = ap(RANK2,pair(mkInt(nr2-length(lps)),type)); + } - if (etvs>ntvs) { /* Add existential annotation */ + if (nonNull(evs)) { /* Add existential annotation */ if (nonNull(derivs)) { ERRMSG(line) "Cannot derive instances for types" ETHEN ERRTEXT " with existentially typed components" @@ -472,11 +954,17 @@ Cell cd; { /* definitions (w or w/o deriving) */ "Cannot use selectors with existentially typed components" EEND; } - type = ap(EXIST,pair(mkInt(etvs-ntvs),type)); + type = ap(EXIST,pair(mkInt(length(evs)),type)); + } + + if (nonNull(lps)) { /* Add local preds part to type */ + type = ap(CDICTS,pair(lps,type)); } + if (nonNull(ctxt1)) { /* Add context part to type */ type = ap(QUAL,pair(ctxt1,type)); } + if (nonNull(sig)) { /* Add quantifiers to type */ List ts1 = sig; for (; nonNull(ts1); ts1=tl(ts1)) { @@ -487,20 +975,38 @@ Cell cd; { /* definitions (w or w/o deriving) */ n = findName(textOf(con)); /* Allocate constructor fun name */ if (isNull(n)) { - n = newName(textOf(con)); + n = newName(textOf(con),NIL); } else if (name(n).defn!=PREDEFINED) { duplicateError(line,name(n).mod,name(n).text, "constructor function"); } name(n).arity = arity; /* Save constructor fun details */ name(n).line = line; + name(n).parent = t; name(n).number = cfunNo(conNo++); name(n).type = type; if (tycon(t).what==NEWTYPE) { + if (nonNull(lps)) { + ERRMSG(line) + "A newtype constructor cannot have class constraints" + EEND; + } + if (arity!=1) { + ERRMSG(line) + "A newtype constructor must have exactly one argument" + EEND; + } + if (nonNull(scs)) { + ERRMSG(line) + "Illegal strictess annotation for newtype constructor" + EEND; + } name(n).defn = nameId; } else { implementCfun(n,scs); + name(n).hasStrict = nonNull(scs); } + hd(cs) = n; if (fs!=NONE) { sels = addSels(line,n,fs,sels); @@ -518,15 +1024,31 @@ Cell cd; { /* definitions (w or w/o deriving) */ } } +Int userArity(c) /* Find arity for cfun, ignoring */ +Name c; { /* CDICTS parameters */ + Int a = name(c).arity; + Type t = name(c).type; + Int w; + if (isPolyType(t)) { + t = monotypeOf(t); + } + if ((w=whatIs(t))==QUAL) { + w = whatIs(t=snd(snd(t))); + } + if (w==CDICTS) { + a -= length(fst(snd(t))); + } + return a; +} + + static List local addSels(line,c,fs,ss) /* Add fields to selector list */ Int line; /* line number of constructor */ Name c; /* corresponding constr function */ List fs; /* list of fields (varids) */ List ss; { /* list of existing selectors */ Int sn = 1; -#if DERIVE_SHOW | DERIVE_READ cfunSfuns = cons(pair(c,fs),cfunSfuns); -#endif for (; nonNull(fs); fs=tl(fs), ++sn) { List ns = ss; Text t = textOf(hd(fs)); @@ -540,6 +1062,7 @@ List ss; { /* list of existing selectors */ while (nonNull(ns) && t!=name(hd(ns)).text) { ns = tl(ns); } + if (nonNull(ns)) { name(hd(ns)).defn = cons(pair(c,mkInt(sn)),name(hd(ns)).defn); } else { @@ -549,7 +1072,7 @@ List ss; { /* list of existing selectors */ textToStr(t) EEND; } - n = newName(t); + n = newName(t,c); name(n).line = line; name(n).number = SELNAME; name(n).defn = singleton(pair(c,mkInt(sn))); @@ -608,8 +1131,9 @@ List syns; { List path1 = NIL; for (; nonNull(ds); ds=tl(ds)) { if (cellIsMember(hd(ds),syns)) { - if (isNull(path1)) + if (isNull(path1)) { path1 = cons(t,path); + } syns = visitSyn(path1,hd(ds),syns); } } @@ -619,154 +1143,6 @@ List syns; { } /* -------------------------------------------------------------------------- - * The following code is used in calculating contexts for the automatically - * derived Eval instances for newtype and restricted type synonyms. This is - * ugly code, resulting from an ugly feature in the language, and I hope that - * the feature, and hence the code, will be removed in the not too distant - * future. - * ------------------------------------------------------------------------*/ - -#if EVAL_INSTANCES -static Void local deriveEval(tcs) /* Derive instances of Eval */ -List tcs; { - List ts1 = tcs; - List ts = NIL; - for (; nonNull(ts1); ts1=tl(ts1)) { /* Build list of rsyns and newtypes*/ - Tycon t = hd(ts1); /* and derive instances for data */ - switch (whatIs(tycon(t).what)) { - case DATATYPE : addEvalInst(tycon(t).line,t,tycon(t).arity,NIL); - break; - case NEWTYPE : - case RESTRICTSYN : ts = cons(t,ts); - break; - } - } - emptySubstitution(); /* then derive other instances */ - while (nonNull(ts)) { - ts = calcEvalContexts(hd(ts),tl(ts),NIL); - } - emptySubstitution(); - - for (; nonNull(tcs); tcs=tl(tcs)) { /* Check any banged components */ - Tycon t = hd(tcs); - if (whatIs(tycon(t).what)==DATATYPE) { - List cs = tycon(t).defn; - for (; hasCfun(cs); cs=tl(cs)) { - Name c = hd(cs); - if (isPair(name(c).defn)) { - Type t = name(c).type; - List scs = fst(name(c).defn); - Kinds ks = NIL; - List ctxt = NIL; - Int n = 1; - if (isPolyType(t)) { - ks = polySigOf(t); - t = monotypeOf(t); - } - if (whatIs(t)==QUAL) { - ctxt = fst(snd(t)); - t = snd(snd(t)); - } - for (; nonNull(scs); scs=tl(scs)) { - Int i = intOf(hd(scs)); - for (; n=tycon(h).arity) { - expandSyn(h,argCount,&t,&o); - } else if (isOffset(h)) { /* Stop if var at head */ - ctxt = singleton(ap(classEval,copyType(t,o))); - break; - } else if (isTuple(h) /* Check for tuples ... */ - || h==tc /* ... direct recursion */ - || cellIsMember(h,ps) /* ... mutual recursion */ - || tycon(h).what==DATATYPE) { /* ... or datatype. */ - break; /* => empty context */ - } else { - Cell pi = ap(classEval,t); - Inst in; - - if (cellIsMember(h,ts)) { /* Not yet visited? */ - ts = calcEvalContexts(h,removeCell(h,ts),cons(h,ts)); - } - if (nonNull(in=findInstFor(pi,o))) {/* Look for Eval instance */ - List qs = inst(in).specifics; - Int o1 = typeOff; - if (isNull(qs)) { /* No context there */ - break; /* => empty context here */ - } - if (isNull(tl(qs)) && classEval==fun(hd(qs))) { - t = arg(hd(qs)); - o = o1; - continue; - } - } - return ts; /* No instance, so give up */ - } - } - addEvalInst(tycon(tc).line,tc,tycon(tc).arity,ctxt); - return ts; -} - -static Void local checkBanged(c,ks,ps,ty) -Name c; /* Check that banged component of c*/ -Kinds ks; /* with type ty is an instance of */ -List ps; /* Eval under the predicates in ps.*/ -Type ty; { /* (All types using ks) */ - Cell pi = ap(classEval,ty); - if (isNull(provePred(ks,ps,pi))) { - ERRMSG(name(c).line) "Illegal datatype strictness annotation:" ETHEN - ERRTEXT "\n*** Constructor : " ETHEN ERREXPR(c); - ERRTEXT "\n*** Context : " ETHEN ERRCONTEXT(ps); - ERRTEXT "\n*** Required : " ETHEN ERRPRED(pi); - ERRTEXT "\n" - EEND; - } -} -#endif - -/* -------------------------------------------------------------------------- * Expanding out all type synonyms in a type expression: * ------------------------------------------------------------------------*/ @@ -825,30 +1201,35 @@ Type env; { /* values for OFFSET type vars */ * 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(getHead(snd(head))); - Int arity = argCount; +Void classDefn(line,head,ms,fds) /* process new class definition */ +Int line; /* definition line number */ +Cell head; /* class header :: ([Supers],Class) */ +List ms; /* class definition body */ +List fds; { /* functional dependencies */ + Text ct = textOf(getHead(snd(head))); + Int arity = argCount; if (nonNull(findClass(ct))) { - ERRMSG(line) "Repeated definition of class \"%s\"", - textToStr(ct) - EEND; + 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; + ERRMSG(line) "\"%s\" used as both class and type constructor", + textToStr(ct) + EEND; } else { - Class nw = newClass(ct); - cclass(nw).line = line; - cclass(nw).arity = arity; - cclass(nw).head = snd(head); - cclass(nw).supers = fst(head); - cclass(nw).members = ms; - cclass(nw).level = 0; - classDefns = cons(nw,classDefns); + Class nw = newClass(ct); + cclass(nw).line = line; + cclass(nw).arity = arity; + cclass(nw).head = snd(head); + cclass(nw).supers = fst(head); + cclass(nw).members = ms; + cclass(nw).level = 0; + cclass(nw).fds = fds; + cclass(nw).xfds = NIL; + classDefns = cons(nw,classDefns); + if (arity!=1) + h98DoesntSupport(line,"multiple parameter classes"); } } @@ -863,7 +1244,7 @@ List ms; { /* class definition body */ * class definition: * - check that variables in header are distinct * - replace head by skeleton - * - check superclass declarations, replace by skeltons + * - check superclass declarations, replace by skeletons * - 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!) @@ -876,11 +1257,13 @@ List ms; { /* class definition body */ * - check that extended class hierarchy does not contain any cycles * ------------------------------------------------------------------------*/ -static Void local checkClassDefn(c) /* validate class definition */ +static Void local checkClassDefn(c) /* validate class definition */ Class c; { List tyvars = NIL; Int args = cclass(c).arity - 1; Cell temp = cclass(c).head; + List fs = NIL; + List ss = NIL; for (; isAp(temp); temp=fun(temp)) { if (!isVar(arg(temp))) { @@ -896,34 +1279,164 @@ Class c; { tyvars = cons(arg(temp),tyvars); } - for (temp=cclass(c).head; args>0; temp=fun(temp), args--) { - arg(temp) = mkOffset(args); + for (fs=cclass(c).fds; nonNull(fs); fs=tl(fs)) { + Pair fd = hd(fs); + List vs = snd(fd); + + /* Check for trivial dependency + */ + if (isNull(vs)) { + ERRMSG(cclass(c).line) "Functional dependency is trivial" + EEND; + } + + /* Check for duplicated vars on right hand side, and for vars on + * right that also appear on the left: + */ + for (vs=snd(fd); nonNull(vs); vs=tl(vs)) { + if (varIsMember(textOf(hd(vs)),fst(fd))) { + ERRMSG(cclass(c).line) + "Trivial dependency for variable \"%s\"", + textToStr(textOf(hd(vs))) + EEND; + } + if (varIsMember(textOf(hd(vs)),tl(vs))) { + ERRMSG(cclass(c).line) + "Repeated variable \"%s\" in functional dependency", + textToStr(textOf(hd(vs))) + EEND; + } + hd(vs) = depTypeVar(cclass(c).line,tyvars,textOf(hd(vs))); + } + + /* Check for duplicated vars on left hand side: + */ + for (vs=fst(fd); nonNull(vs); vs=tl(vs)) { + if (varIsMember(textOf(hd(vs)),tl(vs))) { + ERRMSG(cclass(c).line) + "Repeated variable \"%s\" in functional dependency", + textToStr(textOf(hd(vs))) + EEND; + } + hd(vs) = depTypeVar(cclass(c).line,tyvars,textOf(hd(vs))); + } + } + + if (cclass(c).arity==0) { + cclass(c).head = c; + } else { + Int args = cclass(c).arity - 1; + for (temp=cclass(c).head; args>0; temp=fun(temp), args--) { + arg(temp) = mkOffset(args); + } + arg(temp) = mkOffset(0); + fun(temp) = c; } - arg(temp) = mkOffset(0); - fun(temp) = c; - tcDeps = NIL; /* find dependents */ - map2Proc(depPredExp,cclass(c).line,tyvars,cclass(c).supers); + tcDeps = NIL; /* find dependents */ + map2Over(depPredExp,cclass(c).line,tyvars,cclass(c).supers); + h98CheckCtxt(cclass(c).line,"class definition",FALSE,cclass(c).supers,NIL); cclass(c).numSupers = length(cclass(c).supers); cclass(c).defaults = extractBindings(cclass(c).members); /* defaults*/ - cclass(c).members = extractSigdecls(cclass(c).members); - map2Proc(checkMems,c,tyvars,cclass(c).members); + ss = extractSigdecls(cclass(c).members); + fs = extractFixdecls(cclass(c).members); + cclass(c).members = pair(ss,fs); + map2Proc(checkMems,c,tyvars,ss); + cclass(c).kinds = tcDeps; tcDeps = NIL; } -static Void local depPredExp(line,tyvars,pred) + +/* -------------------------------------------------------------------------- + * Functional dependencies are inherited from superclasses. + * For example, if I've got the following classes: + * + * class C a b | a -> b + * class C [b] a => D a b + * + * then C will have the dependency ([a], [b]) as expected, and D will inherit + * the dependency ([b], [a]) from C. + * When doing pairwise improvement, we have to consider not just improving + * when we see a pair of Cs or a pair of Ds in the context, but when we've + * got a C and a D as well. In this case, we only improve when the + * predicate in question matches the type skeleton in the relevant superclass + * constraint. E.g., we improve the pair (C [Int] a, D b Int) (unifying + * a and b), but we don't improve the pair (C Int a, D b Int). + * To implement functional dependency inheritance, we calculate + * the closure of all functional dependencies, and store the result + * in an additional field `xfds' (extended functional dependencies). + * The `xfds' field is a list of functional dependency lists, annotated + * with a list of predicate skeletons constraining when improvement can + * happen against this dependency list. For example, the xfds field + * for C above would be: + * [([C a b], [([a], [b])])] + * and the xfds field for D would be: + * [([C [b] a, D a b], [([b], [a])])] + * Self-improvement (of a C with a C, or a D with a D) is treated as a + * special case of an inherited dependency. + * ------------------------------------------------------------------------*/ +static List local inheritFundeps ( Class c, Cell pi, Int o ) +{ + Int alpha = newKindedVars(cclass(c).kinds); + List scs = cclass(c).supers; + List xfds = NIL; + Cell this = NIL; + /* better not fail ;-) */ + if (!matchPred(pi,o,cclass(c).head,alpha)) + internal("inheritFundeps - predicate failed to match it's own head!"); + this = copyPred(pi,o); + for (; nonNull(scs); scs=tl(scs)) { + Class s = getHead(hd(scs)); + if (isClass(s)) { + List sfds = inheritFundeps(s,hd(scs),alpha); + for (; nonNull(sfds); sfds=tl(sfds)) { + Cell h = hd(sfds); + xfds = cons(pair(cons(this,fst(h)),snd(h)),xfds); + } + } + } + if (nonNull(cclass(c).fds)) { + List fds = NIL, fs = cclass(c).fds; + for (; nonNull(fs); fs=tl(fs)) { + fds = cons(pair(otvars(this,fst(hd(fs))), + otvars(this,snd(hd(fs)))),fds); + } + xfds = cons(pair(cons(this,NIL),fds),xfds); + } + return xfds; +} + +static Void local extendFundeps ( Class c ) +{ + Int alpha; + emptySubstitution(); + alpha = newKindedVars(cclass(c).kinds); + cclass(c).xfds = inheritFundeps(c,cclass(c).head,alpha); + + /* we can now check for ambiguity */ + map1Proc(checkMems2,c,fst(cclass(c).members)); +} + + +static Cell local depPredExp(line,tyvars,pred) Int line; List tyvars; Cell pred; { - Int args = 1; /* parser guarantees >=1 args */ - Cell h = fun(pred); + Int args = 0; + Cell prev = NIL; + Cell h = pred; for (; isAp(h); args++) { - arg(pred) = depTypeExp(line,tyvars,arg(pred)); - pred = h; - h = fun(pred); + arg(h) = depTypeExp(line,tyvars,arg(h)); + prev = h; + h = fun(h); + } + + if (args==0) { + h98DoesntSupport(line,"tag classes"); + } else if (args!=1) { + h98DoesntSupport(line,"multiple parameter classes"); } - arg(pred) = depTypeExp(line,tyvars,arg(pred)); if (isQCon(h)) { /* standard class constraint */ Class c = findQualClass(h); @@ -931,14 +1444,19 @@ Cell pred; { ERRMSG(line) "Undefined class \"%s\"", identToStr(h) EEND; } - fun(pred) = c; + if (isNull(prev)) { + pred = c; + } else { + fun(prev) = c; + } if (args!=cclass(c).arity) { ERRMSG(line) "Wrong number of arguments for class \"%s\"", textToStr(cclass(c).text) EEND; } - if (cellIsMember(c,classDefns) && !cellIsMember(c,tcDeps)) + if (cellIsMember(c,classDefns) && !cellIsMember(c,tcDeps)) { tcDeps = cons(c,tcDeps); + } } #if TREX else if (isExt(h)) { /* Lacks predicate */ @@ -948,9 +1466,14 @@ Cell pred; { } } #endif - else { /* check for other kinds of pred */ - internal("depPredExp"); /* ... but there aren't any! */ + else +#if IPARAM + if (whatIs(h) != IPCELL) +#endif + { + internal("depPredExp"); } + return pred; } static Void local checkMems(c,tyvars,m) /* check member function details */ @@ -962,11 +1485,20 @@ Cell m; { Type t = thd3(m); List sig = NIL; List tvs = NIL; + List xtvs = NIL; - tyvars = typeVarsIn(t,NIL,tyvars);/* Look for extra type vars. */ + if (isPolyType(t)) { + xtvs = fst(snd(t)); + t = monotypeOf(t); + } + - if (whatIs(t)==QUAL) { /* Overloaded member signatures? */ - map2Proc(depPredExp,line,tyvars,fst(snd(t))); + tyvars = typeVarsIn(t,NIL,xtvs,tyvars); + /* Look for extra type vars. */ + checkOptQuantVars(line,xtvs,tyvars); + + if (isQualType(t)) { /* Overloaded member signatures? */ + map2Over(depPredExp,line,tyvars,fst(snd(t))); } else { t = ap(QUAL,pair(NIL,t)); } @@ -974,21 +1506,33 @@ Cell m; { fst(snd(t)) = cons(cclass(c).head,fst(snd(t)));/* Add main predicate */ snd(snd(t)) = depTopType(line,tyvars,snd(snd(t))); - for (tvs=tyvars; nonNull(tvs); tvs=tl(tvs)) { /* Quantify */ + for (tvs=tyvars; nonNull(tvs); tvs=tl(tvs)){/* Quantify */ sig = ap(NIL,sig); } - t = mkPolyType(sig,t); + if (nonNull(sig)) { + t = mkPolyType(sig,t); + } thd3(m) = t; /* Save type */ take(cclass(c).arity,tyvars); /* Delete extra type vars */ if (isAmbiguous(t)) { ambigError(line,"class declaration",hd(vs),t); } + h98CheckType(line,"member type",hd(vs),t); +} + +static Void local checkMems2(c,m) /* check member function details */ +Class c; +Cell m; { + Int line = intOf(fst3(m)); + List vs = snd3(m); + Type t = thd3(m); } static Void local addMembers(c) /* Add definitions of member funs */ Class c; { /* and other parts of class struct.*/ - List ms = cclass(c).members; + List ms = fst(cclass(c).members); + List fs = snd(cclass(c).members); List ns = NIL; /* List of names */ Int mno; /* Member function number */ @@ -1002,12 +1546,27 @@ Class c; { /* and other parts of class struct.*/ List vs = rev(snd3(hd(ms))); Type t = thd3(hd(ms)); for (; nonNull(vs); vs=tl(vs)) { - ns = cons(newMember(line,mno++,hd(vs),t),ns); + ns = cons(newMember(line,mno++,hd(vs),t,c),ns); } } cclass(c).members = rev(ns); /* Save list of members */ cclass(c).numMembers = length(cclass(c).members); + for (; nonNull(fs); fs=tl(fs)) { /* fixity declarations */ + Int line = intOf(fst3(hd(fs))); + List ops = snd3(hd(fs)); + Syntax s = intOf(thd3(hd(fs))); + for (; nonNull(ops); ops=tl(ops)) { + Name n = nameIsMember(textOf(hd(ops)),cclass(c).members); + if (isNull(n)) { + missFixity(line,textOf(hd(ops))); + } else if (name(n).syntax!=NO_SYNTAX) { + dupFixity(line,textOf(hd(ops))); + } + name(n).syntax = s; + } + } + /* Not actually needed just yet; for the time being, dictionary code will not be passed through the type checker. @@ -1019,62 +1578,61 @@ Class c; { /* and other parts of class struct.*/ */ mno = cclass(c).numSupers + cclass(c).numMembers; - cclass(c).dcon = addPrimCfun(generateText("Make.%s",c),mno,0,0); - implementCfun(cclass(c).dcon,NIL); /* ADR addition */ -#if USE_NEWTYPE_FOR_DICTS + /* cclass(c).dcon = addPrimCfun(generateText("Make.%s",c),mno,0,NIL); */ + cclass(c).dcon = addPrimCfun(generateText(":D%s",c),mno,0,NIL); + /* implementCfun(cclass(c).dcon,NIL); + Don't manufacture a wrapper fn for dictionary constructors. + Applications of dictionary constructors are always saturated, + and translate.c:stgExpr() special-cases saturated constructor apps. + */ + if (mno==1) { /* Single entry dicts use newtype */ name(cclass(c).dcon).defn = nameId; - name(hd(cclass(c).members)).number = mfunNo(0); + if (nonNull(cclass(c).members)) { + name(hd(cclass(c).members)).number = mfunNo(0); + } } -#endif - cclass(c).dbuild = newDBuild(c); 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; { +static Name local newMember(l,no,v,t,parent) +Int l; /* Make definition for member fn */ +Int no; +Cell v; +Type t; +Class parent; { Name m = findName(textOf(v)); if (isNull(m)) { - m = newName(textOf(v)); + m = newName(textOf(v),parent); } 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).line = l; + name(m).arity = 1; + name(m).number = mfunNo(no); + name(m).type = t; return m; } -static Name local newDSel(c,no) /* Make definition for dict selectr*/ +Name newDSel(c,no) /* Make definition for dict selectr*/ Class c; Int no; { Name s; char buf[16]; - sprintf(buf,"sc%d.%s",no,"%s"); - s = newName(generateText(buf,c)); - name(s).line = cclass(c).line; - name(s).arity = 1; - name(s).number = DFUNNAME; + /* sprintf(buf,"sc%d.%s",no,"%s"); */ + sprintf(buf,"$p%d%s",no+1,"%s"); + s = newName(generateText(buf,c),c); + name(s).line = cclass(c).line; + name(s).arity = 1; + name(s).number = DFUNNAME; return s; } -static Name local newDBuild(c) /* Make definition for builder */ -Class c; { - Name b = newName(generateText("class.%s",c)); - name(b).line = cclass(c).line; - name(b).arity = cclass(c).numSupers+1; - return b; -} - #define MAX_GEN 128 static Text local generateText(sk,c) /* We need to generate names for */ @@ -1091,7 +1649,7 @@ Class c; { /* to each class. */ return findText(buffer); } -static Int local visitClass(c) /* visit class defn to check that */ + Int visitClass(c) /* visit class defn to check that */ Class c; { /* class hierarchy is acyclic */ #if TREX if (isExt(c)) { /* special case for lacks preds */ @@ -1102,7 +1660,7 @@ Class c; { /* class hierarchy is acyclic */ 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 */ + } else if (cclass(c).level == 0) { /* visiting class for first time */ List scs = cclass(c).supers; Int lev = 0; cclass(c).level = (-1); @@ -1120,30 +1678,30 @@ Class c; { /* class hierarchy is acyclic */ * ------------------------------------------------------------------------*/ static List local classBindings(where,c,bs) -String where; /*check validity of bindings bs for*/ -Class c; /* class c (or an instance of c) */ +String where; /* Check validity of bindings bs */ +Class c; /* for class c (or an inst of c) */ List bs; { /* sort into approp. member order */ List nbs = NIL; for (; nonNull(bs); bs=tl(bs)) { - Cell b = hd(bs); + Cell b = hd(bs); + Cell body = snd(snd(b)); Name mnm; - if (!isVar(fst(b))) { /* only allows function bindings */ - ERRMSG(rhsLine(snd(snd(snd(b))))) - "Pattern binding illegal in %s declaration", where + if (!isVar(fst(b))) { /* Only allow function bindings */ + ERRMSG(rhsLine(snd(body))) + "Pattern binding illegal in %s declaration", where EEND; } if (isNull(mnm=memberName(c,textOf(fst(b))))) { - ERRMSG(rhsLine(snd(hd(snd(snd(b)))))) + ERRMSG(rhsLine(snd(hd(body)))) "No member \"%s\" in class \"%s\"", textToStr(textOf(fst(b))), textToStr(cclass(c).text) EEND; } - - snd(b) = snd(snd(b)); - nbs = numInsert(mfunOf(mnm)-1,b,nbs); + snd(b) = body; + nbs = numInsert(mfunOf(mnm)-1,b,nbs); } return nbs; } @@ -1160,8 +1718,8 @@ Text t; { /* return NIL if not a member */ return NIL; } -static List local numInsert(n,x,xs) /* insert x at nth position in xs, */ -Int n; /* filling gaps with NIL */ +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; @@ -1182,44 +1740,54 @@ List xs; { * occur in the type expression when read from left to right. * ------------------------------------------------------------------------*/ -static List local typeVarsIn(ty,us,vs) /* Calculate list of type variables*/ -Cell ty; /* used in type expression, reading*/ -List us; /* from left to right ignoring any */ -List vs; { /* listed in us. */ +List local typeVarsIn(ty,us,ws,vs) /*Calculate list of type variables*/ +Cell ty; /* used in type expression, reading*/ +List us; /* from left to right ignoring any */ +List ws; /* listed in us. */ +List vs; { /* ws = explicitly quantified vars */ + if (isNull(ty)) return vs; switch (whatIs(ty)) { - case AP : return typeVarsIn(snd(ty),us, - typeVarsIn(fst(ty),us,vs)); - - case VARIDCELL : - case VAROPCELL : if (nonNull(findBtyvs(textOf(ty))) - || varIsMember(textOf(ty),us)) { - return vs; - } else { - return maybeAppendVar(ty,vs); - } - case POLYTYPE : return typeVarsIn(monotypeOf(ty),polySigOf(ty),vs); - - case QUAL : { List qs = fst(snd(ty)); - for (; nonNull(qs); qs=tl(qs)) { - vs = typeVarsIn(hd(qs),us,vs); - } - return typeVarsIn(snd(snd(ty)),us,vs); - } - - case BANG : return typeVarsIn(snd(ty),us,vs); - - case LABC : { List fs = snd(snd(ty)); - for (; nonNull(fs); fs=tl(fs)) { - vs = typeVarsIn(snd(hd(fs)),us,vs); - } - return vs; - } - } - return vs; + case DICTAP : return typeVarsIn(snd(snd(ty)),us,ws,vs); + case UNBOXEDTUP: return typeVarsIn(snd(ty),us,ws,vs); + + case AP : return typeVarsIn(snd(ty),us,ws, + typeVarsIn(fst(ty),us,ws,vs)); + + case VARIDCELL : + case VAROPCELL : if ((nonNull(findBtyvs(textOf(ty))) + && !varIsMember(textOf(ty),ws)) + || varIsMember(textOf(ty),us)) { + return vs; + } else { + return maybeAppendVar(ty,vs); + } + + case POLYTYPE : return typeVarsIn(monotypeOf(ty),polySigOf(ty),ws,vs); + + case QUAL : { vs = typeVarsIn(fst(snd(ty)),us,ws,vs); + return typeVarsIn(snd(snd(ty)),us,ws,vs); + } + + case BANG : return typeVarsIn(snd(ty),us,ws,vs); + + case LABC : { List fs = snd(snd(ty)); + for (; nonNull(fs); fs=tl(fs)) { + vs = typeVarsIn(snd(hd(fs)),us,ws,vs); + } + return vs; + } + case TUPLE: + case TYCON: + case CONIDCELL: + case QUALIDENT: return vs; + + default: fprintf(stderr, " bad tag = %d\n", whatIs(ty));internal("typeVarsIn"); + } + assert(0); } -static List local maybeAppendVar(v,vs) /* append variable to list if not */ -Cell v; /* already included */ +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; @@ -1238,6 +1806,7 @@ List vs; { } else { vs = cons(v,NIL); } + return vs; } @@ -1253,13 +1822,21 @@ Int line; /* Check validity of type expr in */ String where; /* explicit type signature */ Cell e; Type type; { - List tvs = typeVarsIn(type,NIL,NIL); - Int n = length(tvs); - List sunk = unkindTypes; + List tvs = NIL; + List sunk = NIL; + List xtvs = NIL; + + if (isPolyType(type)) { + xtvs = fst(snd(type)); + type = monotypeOf(type); + } + tvs = typeVarsIn(type,NIL,xtvs,NIL); + sunk = unkindTypes; + checkOptQuantVars(line,xtvs,tvs); - if (whatIs(type)==QUAL) { - map2Proc(depPredExp,line,tvs,fst(snd(type))); - snd(snd(type)) = depTopType(line,tvs,snd(snd(type))); + if (isQualType(type)) { + map2Over(depPredExp,line,tvs,fst(snd(type))); + snd(snd(type)) = depTopType(line,tvs,snd(snd(type))); if (isAmbiguous(type)) { ambigError(line,where,e,type); @@ -1267,8 +1844,9 @@ Type type; { } else { type = depTopType(line,tvs,type); } - if (n>0) { - if (n>=NUM_OFFSETS) { + + if (nonNull(tvs)) { + if (length(tvs) >= (OFF_MAX-OFF_MIN+1)) { ERRMSG(line) "Too many type variables in %s\n", where EEND; } else { @@ -1284,9 +1862,39 @@ Type type; { kindType(line,"type expression",type); fixKinds(); unkindTypes = sunk; + + h98CheckType(line,where,e,type); return type; } +static Void local checkOptQuantVars(line,xtvs,tvs) +Int line; +List xtvs; /* Explicitly quantified vars */ +List tvs; { /* Implicitly quantified vars */ + if (nonNull(xtvs)) { + List vs = tvs; + for (; nonNull(vs); vs=tl(vs)) { + if (!varIsMember(textOf(hd(vs)),xtvs)) { + ERRMSG(line) "Quantifier does not mention type variable \"%s\"", + textToStr(textOf(hd(vs))) + EEND; + } + } + for (vs=xtvs; nonNull(vs); vs=tl(vs)) { + if (!varIsMember(textOf(hd(vs)),tvs)) { + ERRMSG(line) "Quantified type variable \"%s\" is not used", + textToStr(textOf(hd(vs))) + EEND; + } + if (varIsMember(textOf(hd(vs)),tl(vs))) { + ERRMSG(line) "Quantified type variable \"%s\" is repeated", + textToStr(textOf(hd(vs))) + EEND; + } + } + } +} + static Type local depTopType(l,tvs,t) /* Check top-level of type sig */ Int l; List tvs; @@ -1295,9 +1903,9 @@ Type t; { Type t1 = t; Int nr2 = 0; Int i = 1; - for (; getHead(t1)==typeArrow; ++i) { + for (; getHead(t1)==typeArrow && argCount==2; ++i) { arg(fun(t1)) = depCompType(l,tvs,arg(fun(t1))); - if (isPolyType(arg(fun(t1)))) { + if (isPolyOrQualType(arg(fun(t1)))) { nr2 = i; } prev = t1; @@ -1318,51 +1926,28 @@ static Type local depCompType(l,tvs,t) /* Check component type for constr */ Int l; List tvs; Type t; { - if (isPolyType(t)) { - Int ntvs = length(tvs); - List nfr = NIL; - if (isPolyType(t)) { - List vs = fst(snd(t)); - List bvs = typeVarsIn(monotypeOf(t),NIL,NIL); - List us = vs; - for (; nonNull(us); us=tl(us)) { - Text u = textOf(hd(us)); - if (varIsMember(u,tl(us))) { - ERRMSG(l) "Duplicated quantified variable %s", - textToStr(u) - EEND; - } - if (varIsMember(u,tvs)) { - ERRMSG(l) "Local quantifier for %s hides an outer use", - textToStr(u) - EEND; - } - if (!varIsMember(u,bvs)) { - ERRMSG(l) "Locally quantified variable %s is not used", - textToStr(u) - EEND; - } - } - nfr = replicate(length(vs),NIL); - tvs = appendOnto(tvs,vs); - t = monotypeOf(t); - } - if (whatIs(t)==QUAL) { - map2Proc(depPredExp,l,tvs,fst(snd(t))); - snd(snd(t)) = depTypeExp(l,tvs,snd(snd(t))); - if (isAmbiguous(t)) - ambigError(l,"type component",NIL,t); - } else { - t = depTypeExp(l,tvs,t); - } - if (isNull(nfr)) { - return t; - } - take(ntvs,tvs); - return mkPolyType(nfr,t); - } else { - return depTypeExp(l,tvs,t); + Int ntvs = length(tvs); + List nfr = NIL; + if (isPolyType(t)) { + List vs = fst(snd(t)); + t = monotypeOf(t); + tvs = checkQuantVars(l,vs,tvs,t); + nfr = replicate(length(vs),NIL); + } + if (isQualType(t)) { + map2Over(depPredExp,l,tvs,fst(snd(t))); + snd(snd(t)) = depTypeExp(l,tvs,snd(snd(t))); + if (isAmbiguous(t)) { + ambigError(l,"type component",NIL,t); } + } else { + t = depTypeExp(l,tvs,t); + } + if (isNull(nfr)) { + return t; + } + take(ntvs,tvs); + return mkPolyType(nfr,t); } static Type local depTypeExp(line,tyvars,type) @@ -1395,58 +1980,258 @@ Type type; { return tc; } -#if TREX - case EXT : -#endif - case TYCON : - case TUPLE : break; +#if TREX + case EXT : h98DoesntSupport(line,"extensible records"); +#endif + case TYCON : + case TUPLE : break; + + default : internal("depTypeExp"); + } + return type; +} + +static Type local depTypeVar(line,tyvars,tv) +Int line; +List tyvars; +Text tv; { + Int offset = 0; + Int found = (-1); + + for (; nonNull(tyvars); offset++) { + if (tv==textOf(hd(tyvars))) { + found = offset; + } + tyvars = tl(tyvars); + } + if (found<0) { + Cell vt = findBtyvs(tv); + if (nonNull(vt)) { + return fst(vt); + } + ERRMSG(line) "Undefined type variable \"%s\"", textToStr(tv) + EEND; + } + return mkOffset(found); +} + +static List local checkQuantVars(line,vs,tvs,body) +Int line; +List vs; /* variables to quantify over */ +List tvs; /* variables already in scope */ +Cell body; { /* type/constr for scope of vars */ + if (nonNull(vs)) { + List bvs = typeVarsIn(body,NIL,NIL,NIL); + List us = vs; + for (; nonNull(us); us=tl(us)) { + Text u = textOf(hd(us)); + if (varIsMember(u,tl(us))) { + ERRMSG(line) "Duplicated quantified variable %s", + textToStr(u) + EEND; + } +#if 0 + if (varIsMember(u,tvs)) { + ERRMSG(line) "Local quantifier for %s hides an outer use", + textToStr(u) + EEND; + } +#endif + if (!varIsMember(u,bvs)) { + ERRMSG(line) "Locally quantified variable %s is not used", + textToStr(u) + EEND; + } + } + tvs = appendOnto(tvs,vs); + } + return tvs; +} + +/* -------------------------------------------------------------------------- + * Check for ambiguous types: + * A type Preds => type is ambiguous if not (TV(P) `subset` TV(type)) + * ------------------------------------------------------------------------*/ + +List 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)); - default : internal("depTypeExp"); + case OFFSET : if (cellIsMember(t,vs)) + return vs; + else + return cons(t,vs); + + case QUAL : return offsetTyvarsIn(snd(t),vs); + + case POLYTYPE : return offsetTyvarsIn(monotypeOf(t),vs); + /* slightly inaccurate, but won't matter here */ + + case EXIST : + case RANK2 : return offsetTyvarsIn(snd(snd(t)),vs); + + default : return vs; } - return type; } -static Type local depTypeVar(line,tyvars,tv) -Int line; -List tyvars; -Text tv; { - Int offset = 0; - Cell vt = findBtyvs(tv); +List zonkTyvarsIn(t,vs) +Type t; +List vs; { + switch (whatIs(t)) { + case AP : return zonkTyvarsIn(fun(t), + zonkTyvarsIn(arg(t),vs)); - if (nonNull(vt)) { - return fst(vt); + case INTCELL : if (cellIsMember(t,vs)) + return vs; + else + return cons(t,vs); + + /* this case will lead to a type error -- + much better than reporting an internal error ;-) */ + /* case OFFSET : internal("zonkTyvarsIn"); */ + + default : return vs; } - for (; nonNull(tyvars) && tv!=textOf(hd(tyvars)); offset++) { - tyvars = tl(tyvars); +} + +static List local otvars(pi,os) /* os is a list of offsets that */ +Cell pi; /* refer to the arguments of pi; */ +List os; { /* find list of offsets in those */ + List us = NIL; /* positions */ + for (; nonNull(os); os=tl(os)) { + us = offsetTyvarsIn(nthArg(offsetOf(hd(os)),pi),us); } - if (isNull(tyvars)) { - ERRMSG(line) "Undefined type variable \"%s\"", textToStr(tv) - EEND; + return us; +} + +static List local otvarsZonk(pi,os,o) /* same as above, but zonks */ +Cell pi; +List os; { + List us = NIL; + for (; nonNull(os); os=tl(os)) { + Type t = zonkType(nthArg(offsetOf(hd(os)),pi),o); + us = zonkTyvarsIn(t,us); } - return mkOffset(offset); + return us; } -/* -------------------------------------------------------------------------- - * Check for ambiguous types: - * A type Preds => type is ambiguous if not (TV(P) `subset` TV(type)) - * ------------------------------------------------------------------------*/ +static Bool local odiff(us,vs) +List us, vs; { + while (nonNull(us) && cellIsMember(hd(us),vs)) { + us = tl(us); + } + return us; +} + +static Bool local osubset(us,vs) /* Determine whether us is subset */ +List us, vs; { /* of vs */ + while (nonNull(us) && cellIsMember(hd(us),vs)) { + us = tl(us); + } + return isNull(us); +} + +List oclose(fds,vs) /* Compute closure of vs wrt to fds*/ +List fds; +List vs; { + Bool changed = TRUE; + while (changed) { + List fds1 = NIL; + changed = FALSE; + while (nonNull(fds)) { + Cell fd = hd(fds); + List next = tl(fds); + if (osubset(fst(fd),vs)) { /* Test if fd applies */ + List os = snd(fd); + for (; nonNull(os); os=tl(os)) { + if (!cellIsMember(hd(os),vs)) { + vs = cons(hd(os),vs); + changed = TRUE; + } + } + } else { /* Didn't apply this time, so keep */ + tl(fds) = fds1; + fds1 = fds; + } + fds = next; + } + fds = fds1; + } + return vs; +} -Bool isAmbiguous(type) /* Determine whether type is */ -Type type; { /* ambiguous */ +Bool isAmbiguous(type) /* Determine whether type is */ +Type type; { /* ambiguous */ if (isPolyType(type)) { - type = monotypeOf(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); + if (isQualType(type)) { /* only qualified types can be */ + List ps = fst(snd(type)); /* ambiguous */ + List tvps = offsetTyvarsIn(ps,NIL); + List tvts = offsetTyvarsIn(snd(snd(type)),NIL); + List fds = calcFunDeps(ps); + + tvts = oclose(fds,tvts); /* Close tvts under fds */ + return !osubset(tvps,tvts); } return FALSE; } +List calcFunDeps(ps) +List ps; { + List fds = NIL; + for (; nonNull(ps); ps=tl(ps)) {/* Calc functional dependencies */ + Cell pi = hd(ps); + Cell c = getHead(pi); + if (isClass(c)) { + List xfs = cclass(c).xfds; + for (; nonNull(xfs); xfs=tl(xfs)) { + List fs = snd(hd(xfs)); + for (; nonNull(fs); fs=tl(fs)) { + fds = cons(pair(otvars(pi,fst(hd(fs))), + otvars(pi,snd(hd(fs)))),fds); + } + } + } +#if IPARAM + else if (isIP(c)) { + fds = cons(pair(NIL,offsetTyvarsIn(arg(pi),NIL)),fds); + } +#endif + } + return fds; +} + +List calcFunDepsPreds(ps) +List ps; { + List fds = NIL; + for (; nonNull(ps); ps=tl(ps)) {/* Calc functional dependencies */ + Cell pi3 = hd(ps); + Cell pi = fst3(pi3); + Cell c = getHead(pi); + Int o = intOf(snd3(pi3)); + if (isClass(c)) { + List xfs = cclass(c).xfds; + for (; nonNull(xfs); xfs=tl(xfs)) { + List fs = snd(hd(xfs)); + for (; nonNull(fs); fs=tl(fs)) { + fds = cons(pair(otvarsZonk(pi,fst(hd(fs)),o), + otvarsZonk(pi,snd(hd(fs)),o)),fds); + } + } + } +#if IPARAM + else if (isIP(c)) { + fds = cons(pair(NIL,zonkTyvarsIn(arg(pi),NIL)),fds); + } +#endif + } + return fds; +} + Void ambigError(line,where,e,type) /* produce error message for */ Int line; /* ambiguity */ String where; @@ -1474,9 +2259,9 @@ Cell c; { Int n = argCount; #ifdef DEBUG_KINDS - printf("kindConstr: alpha=%d, m=%d, c=",alpha,m); + Printf("kindConstr: alpha=%d, m=%d, c=",alpha,m); printType(stdout,c); - printf("\n"); + Printf("\n"); #endif switch (whatIs(h)) { @@ -1488,14 +2273,16 @@ Cell c; { Kinds ks = polySigOf(t); Int m1 = 0; Int beta; - for (; isAp(ks); ks=tl(ks)) + for (; isAp(ks); ks=tl(ks)) { m1++; + } beta = newKindvars(m1); unkindTypes = cons(pair(mkInt(beta),t),unkindTypes); checkKind(line,beta,m1,monotypeOf(t),NIL,pt,STAR,0); } return; + case CDICTS : case QUAL : if (n!=0) { internal("kindConstr2"); } @@ -1528,7 +2315,7 @@ Cell c; { if (n==0) { /* trivial case, no arguments */ typeIs = kindAtom(alpha,c); - } else { /* non-trivial application */ + } else { /* non-trivial application */ static String app = "constructor application"; Cell a = c; Int i; @@ -1569,9 +2356,9 @@ Cell c; { #endif } #if DEBUG_KINDS - printf("kindAtom(%d,whatIs(%d)) on ",alpha,whatIs(c)); + Printf("kindAtom(%d,whatIs(%d)) on ",alpha,whatIs(c)); printType(stdout,c); - printf("\n"); + Printf("\n"); #endif internal("kindAtom"); return STAR;/* not reached */ @@ -1583,12 +2370,19 @@ Int alpha; Int m; Cell pi; { #if TREX - if (isExt(fun(pi))) { + if (isAp(pi) && isExt(fun(pi))) { static String lackspred = "lacks predicate"; checkKind(l,alpha,m,arg(pi),NIL,lackspred,ROW,0); return; } #endif +#if IPARAM + if (isAp(pi) && whatIs(fun(pi)) == IPCELL) { + static String ippred = "iparam predicate"; + checkKind(l,alpha,m,arg(pi),NIL,ippred,STAR,0); + return; + } +#endif { static String predicate = "class constraint"; Class c = getHead(pi); List as = getArgs(pi); @@ -1628,11 +2422,11 @@ static Void local fixKinds() { /* add kind annotations to types */ } } #ifdef DEBUG_KINDS - printf("Type expression: "); + Printf("Type expression: "); printType(stdout,snd(pr)); - printf(" :: "); + Printf(" :: "); printKind(stdout,polySigOf(snd(pr))); - printf("\n"); + Printf("\n"); #endif } } @@ -1667,10 +2461,10 @@ Cell c; { Int n = cclass(c).arity; Int beta = newKindvars(n); cclass(c).kinds = NIL; - do { + while (n>0) { n--; cclass(c).kinds = pair(mkInt(beta+n),cclass(c).kinds); - } while (n>0); + } } } @@ -1685,7 +2479,7 @@ Cell c; { /* is well-kinded */ switch (whatIs(tycon(c).what)) { case NEWTYPE : case DATATYPE : { List cs = tycon(c).defn; - if (whatIs(cs)==QUAL) { + if (isQualType(cs)) { map3Proc(kindPred,line,beta,m, fst(snd(cs))); tycon(c).defn = cs = snd(snd(cs)); @@ -1701,8 +2495,8 @@ Cell c; { /* is well-kinded */ } } else { /* scan type exprs in class defn to*/ - List ms = cclass(c).members; /* determine the class signature */ - Int m = cclass(c).arity; + List ms = fst(cclass(c).members); + Int m = cclass(c).arity; /* determine the class signature */ Int beta = newKindvars(m); kindPred(cclass(c).line,beta,m,cclass(c).head); map3Proc(kindPred,cclass(c).line,beta,m,cclass(c).supers); @@ -1719,9 +2513,9 @@ Cell c; { /* given tycon/class */ if (isTycon(c)) { tycon(c).kind = copyKindvar(intOf(tycon(c).kind)); #ifdef DEBUG_KINDS - printf("%s :: ",textToStr(tycon(c).text)); + Printf("%s :: ",textToStr(tycon(c).text)); printKind(stdout,tycon(c).kind); - putchar('\n'); + Putchar('\n'); #endif } else { Kinds ks = cclass(c).kinds; @@ -1729,9 +2523,9 @@ Cell c; { /* given tycon/class */ hd(ks) = copyKindvar(intOf(hd(ks))); } #ifdef DEBUG_KINDS - printf("%s :: ",textToStr(cclass(c).text)); + Printf("%s :: ",textToStr(cclass(c).text)); printKinds(stdout,cclass(c).kinds); - putchar('\n'); + Putchar('\n'); #endif } } @@ -1747,10 +2541,10 @@ Cell c; { /* given tycon/class */ * 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 */ +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 = fst(head); @@ -1776,38 +2570,117 @@ List ms; { /* instance members */ * ------------------------------------------------------------------------*/ Bool allowOverlap = FALSE; /* TRUE => allow overlapping insts */ +Name nameListMonad = NIL; /* builder function for List Monad */ static Void local checkInstDefn(in) /* Validate instance declaration */ Inst in; { Int line = inst(in).line; - List tyvars = typeVarsIn(inst(in).head,NIL,NIL); + List tyvars = typeVarsIn(inst(in).head,NIL,NIL,NIL); + List tvps = NIL, tvts = NIL; + List fds = NIL; + + if (haskell98) { /* Check for `simple' type */ + List tvs = NIL; + Cell t = arg(inst(in).head); + for (; isAp(t); t=fun(t)) { + if (!isVar(arg(t))) { + ERRMSG(line) + "syntax error in instance head (variable expected)" + EEND; + } + if (varIsMember(textOf(arg(t)),tvs)) { + ERRMSG(line) "repeated type variable \"%s\" in instance head", + textToStr(textOf(arg(t))) + EEND; + } + tvs = cons(arg(t),tvs); + } + if (isVar(t)) { + ERRMSG(line) + "syntax error in instance head (constructor expected)" + EEND; + } + } + + /* add in the tyvars from the `specifics' so that we don't + prematurely complain about undefined tyvars */ + tyvars = typeVarsIn(inst(in).specifics,NIL,NIL,tyvars); + inst(in).head = depPredExp(line,tyvars,inst(in).head); + + if (haskell98) { + Type h = getHead(arg(inst(in).head)); + if (isSynonym(h)) { + ERRMSG(line) "Cannot use type synonym in instance head" + EEND; + } + } - depPredExp(line,tyvars,inst(in).head); - map2Proc(depPredExp,line,tyvars,inst(in).specifics); + map2Over(depPredExp,line,tyvars,inst(in).specifics); + + /* OK, now we start over, and test for ambiguity */ + tvts = offsetTyvarsIn(inst(in).head,NIL); + tvps = offsetTyvarsIn(inst(in).specifics,NIL); + fds = calcFunDeps(inst(in).specifics); + tvts = oclose(fds,tvts); + tvts = odiff(tvps,tvts); + if (!isNull(tvts)) { + ERRMSG(line) "Undefined type variable \"%s\"", + textToStr(textOf(nth(offsetOf(hd(tvts)),tyvars))) + EEND; + } + + h98CheckCtxt(line,"instance definition",FALSE,inst(in).specifics,NIL); inst(in).numSpecifics = length(inst(in).specifics); inst(in).c = getHead(inst(in).head); if (!isClass(inst(in).c)) { ERRMSG(line) "Illegal predicate in instance declaration" EEND; } -#if EVAL_INSTANCES - if (inst(in).c==classEval) { - ERRMSG(line) "Instances of class \"%s\" are generated automatically", - textToStr(cclass(inst(in).c).text) - EEND; + + if (nonNull(cclass(inst(in).c).fds)) { + List fds = cclass(inst(in).c).fds; + for (; nonNull(fds); fds=tl(fds)) { + List as = otvars(inst(in).head, fst(hd(fds))); + List bs = otvars(inst(in).head, snd(hd(fds))); + List fs = calcFunDeps(inst(in).specifics); + as = oclose(fs,as); + if (!osubset(bs,as)) { + ERRMSG(inst(in).line) + "Instance is more general than a dependency allows" + ETHEN + ERRTEXT "\n*** Instance : " + ETHEN ERRPRED(inst(in).head); + ERRTEXT "\n*** For class : " + ETHEN ERRPRED(cclass(inst(in).c).head); + ERRTEXT "\n*** Under dependency : " + ETHEN ERRFD(hd(fds)); + ERRTEXT "\n" + EEND; + } + } } -#endif + kindInst(in,length(tyvars)); insertInst(in); if (nonNull(extractSigdecls(inst(in).implements))) { - ERRMSG(line) "Type signature decls not permitted in instance decl" + ERRMSG(line) + "Type signature declarations not permitted in instance declaration" + EEND; + } + if (nonNull(extractFixdecls(inst(in).implements))) { + ERRMSG(line) + "Fixity declarations not permitted in instance declaration" EEND; } inst(in).implements = classBindings("instance", inst(in).c, extractBindings(inst(in).implements)); inst(in).builder = newInstImp(in); + if (!preludeLoaded && isNull(nameListMonad) && isAp(inst(in).head) + && fun(inst(in).head)==classMonad && arg(inst(in).head)==typeList) { + nameListMonad = inst(in).builder; + } } static Void local insertInst(in) /* Insert instance into class */ @@ -1816,13 +2689,55 @@ Inst in; { List ins = cclass(c).instances; List prev = NIL; + if (nonNull(cclass(c).fds)) { /* Check for conflicts with fds */ + List ins1 = cclass(c).instances; + for (; nonNull(ins1); ins1=tl(ins1)) { + List fds = cclass(c).fds; + substitution(RESET); + for (; nonNull(fds); fds=tl(fds)) { + Int alpha = newKindedVars(inst(in).kinds); + Int beta = newKindedVars(inst(hd(ins1)).kinds); + List as = fst(hd(fds)); + Bool same = TRUE; + for (; same && nonNull(as); as=tl(as)) { + Int n = offsetOf(hd(as)); + same &= unify(nthArg(n,inst(in).head),alpha, + nthArg(n,inst(hd(ins1)).head),beta); + } + if (isNull(as) && same) { + for (as=snd(hd(fds)); same && nonNull(as); as=tl(as)) { + Int n = offsetOf(hd(as)); + same &= sameType(nthArg(n,inst(in).head),alpha, + nthArg(n,inst(hd(ins1)).head),beta); + } + if (!same) { + ERRMSG(inst(in).line) + "Instances are not consistent with dependencies" + ETHEN + ERRTEXT "\n*** This instance : " + ETHEN ERRPRED(inst(in).head); + ERRTEXT "\n*** Conflicts with : " + ETHEN ERRPRED(inst(hd(ins)).head); + ERRTEXT "\n*** For class : " + ETHEN ERRPRED(cclass(c).head); + ERRTEXT "\n*** Under dependency : " + ETHEN ERRFD(hd(fds)); + ERRTEXT "\n" + EEND; + } + } + } + } + } + + substitution(RESET); while (nonNull(ins)) { /* Look for overlap w/ other insts */ Int alpha = newKindedVars(inst(in).kinds); Int beta = newKindedVars(inst(hd(ins)).kinds); if (unifyPred(inst(in).head,alpha,inst(hd(ins)).head,beta)) { Cell pi = copyPred(inst(in).head,alpha); - if (allowOverlap) { /* So long as one is more specific */ + if (allowOverlap && !haskell98) { Bool bef = instCompare(in,hd(ins)); Bool aft = instCompare(hd(ins),in); if (bef && !aft) { /* in comes strictly before hd(ins)*/ @@ -1834,6 +2749,11 @@ Inst in; { continue; } } +#if MULTI_INST + if (multiInstRes && nonNull(inst(in).specifics)) { + break; + } else { +#endif ERRMSG(inst(in).line) "Overlapping instances for class \"%s\"", textToStr(cclass(c).text) ETHEN @@ -1845,6 +2765,9 @@ Inst in; { ERRTEXT "\n" EEND; } +#if MULTI_INST + } +#endif prev = ins; /* No overlap detected, so move on */ ins = tl(ins); /* to next instance */ } @@ -1866,7 +2789,7 @@ Inst ia, ib;{ static Name local newInstImp(in) /* Make definition for inst builder*/ Inst in; { - Name b = newName(inventText()); + Name b = newName(inventText(),in); name(b).line = inst(in).line; name(b).arity = inst(in).numSpecifics; name(b).number = DFUNNAME; @@ -1892,11 +2815,11 @@ Int freedom; { inst(in).kinds = cons(copyKindvar(beta+freedom),inst(in).kinds); } #ifdef DEBUG_KINDS - printf("instance "); + Printf("instance "); printPred(stdout,inst(in).head); - printf(" :: "); + Printf(" :: "); printKinds(stdout,inst(in).kinds); - putchar('\n'); + Putchar('\n'); #endif emptySubstitution(); } @@ -1913,10 +2836,10 @@ 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)); + Class c = findQualClass(ct); if (isNull(c)) { ERRMSG(line) "Unknown class \"%s\" in derived instance", - textToStr(textOf(ct)) + identToStr(ct) EEND; } addDerInst(line,c,p,dupList(ts),t,tycon(t).arity); @@ -1959,48 +2882,19 @@ Int n; { addDerInst(0,c,NIL,cts,mkTuple(n),n); } -#if EVAL_INSTANCES -/* ADR addition */ -static List evalInsts = NIL; - -Void addEvalInst(line,t,arity,ctxt) /* Add dummy instance for Eval */ -Int line; -Cell t; -Int arity; -List ctxt; { - Inst in = newInst(); - Cell head = t; - Int i; - for (i=0; i= factor*cutoff) { + Cell bpi = inst(in).head; + ERRMSG(inst(in).line) "\n*** Cannot derive " ETHEN ERRPRED(bpi); + ERRTEXT " after %d iterations.", its-1 ETHEN + ERRTEXT + "\n*** This may indicate that the problem is undecidable. However,\n" + ETHEN ERRTEXT + "*** you may still try to increase the cutoff limit using the -c\n" + ETHEN ERRTEXT + "*** option and then try again. (The current setting is -c%d)\n", + cutoff + EEND; + } if (isInt(fst(p))) { /* Delayed substitution? */ List qs = snd(p); for (; nonNull(hd(qs)); qs=tl(qs)) { @@ -2159,8 +3065,9 @@ Inst in; { /* of the context for a derived */ List qs = inst(in1).specifics; Int off = mkInt(typeOff); if (whatIs(qs)==DERIVE) { /* Still being derived */ - for (qs=fst(snd(qs)); nonNull(hd(qs)); qs=tl(qs)) + for (qs=fst(snd(qs)); nonNull(hd(qs)); qs=tl(qs)) { ps = cons(pair(hd(qs),off),ps); + } retain = cons(pair(off,qs),retain); } else { /* Previously def'd inst */ for (; nonNull(qs); qs=tl(qs)) { @@ -2222,7 +3129,7 @@ Int beta; { return copyAdj(tyv->bound,tyv->offs,beta); } vn -= beta; - if (vn<0 || vn>=NUM_OFFSETS) { + if (vn<0 || vn>=(OFF_MAX-OFF_MIN+1)) { internal("copyAdj"); } return mkOffset(vn); @@ -2238,14 +3145,15 @@ Inst in; { /* calculations */ clearMarks(); copyPred(inst(in).head,o); inst(in).specifics = simpleContext(ps,o); + h98CheckCtxt(inst(in).line,"derived instance",FALSE,inst(in).specifics,in); inst(in).numSpecifics = length(inst(in).specifics); #ifdef DEBUG_DERIVING - printf("Derived instance: "); + Printf("Derived instance: "); printContext(stdout,inst(in).specifics); - printf(" ||- "); + Printf(" ||- "); printPred(stdout,inst(in).head); - printf("\n"); + Printf("\n"); #endif } @@ -2258,42 +3166,21 @@ Inst in; { List imp = NIL; Type t = getHead(arg(inst(in).head)); Class c = inst(in).c; -#if DERIVE_EQ - if (c==classEq) + if (c==classEq) { imp = deriveEq(t); - else -#endif -#if DERIVE_ORD - if (c==classOrd) + } else if (c==classOrd) { imp = deriveOrd(t); - else -#endif -#if DERIVE_ENUM - if (c==classEnum) + } else if (c==classEnum) { imp = deriveEnum(t); - else -#endif -#if DERIVE_IX - if (c==classIx) + } else if (c==classIx) { imp = deriveIx(t); - else -#endif -#if DERIVE_SHOW - if (c==classShow) + } else if (c==classShow) { imp = deriveShow(t); - else -#endif -#if DERIVE_READ - if (c==classRead) + } else if (c==classRead) { imp = deriveRead(t); - else -#endif -#if DERIVE_BOUNDED - if (c==classBounded) + } else if (c==classBounded) { imp = deriveBounded(t); - else -#endif - { + } else { ERRMSG(inst(in).line) "Cannot derive instances of class \"%s\"", textToStr(cclass(inst(in).c).text) EEND; @@ -2307,6 +3194,7 @@ Inst in; { imp); } + /* -------------------------------------------------------------------------- * Default definitions; only one default definition is permitted in a * given script file. If no default is supplied, then a standard system @@ -2339,6 +3227,11 @@ static Void local checkDefaultDefns() { /* check that default types are */ } else { defaultDefns = stdDefaults; } + + if (isNull(classNum)) { + classNum = findClass(findText("Num")); + } + for (ds=defaultDefns; nonNull(ds); ds=tl(ds)) { if (isNull(provePred(NIL,NIL,ap(classNum,hd(ds))))) { ERRMSG(defaultLine) @@ -2348,36 +3241,40 @@ static Void local checkDefaultDefns() { /* check that default types are */ } } + /* -------------------------------------------------------------------------- * Foreign import declarations are Hugs' equivalent of GHC's ccall mechanism. * They are used to "import" C functions into a module. * They are usually not written by hand but, rather, generated automatically - * by GreenCard, IDL compilers or whatever. + * by GreenCard, IDL compilers or whatever. We support foreign import + * (static) and foreign import dynamic. In the latter case, extName==NIL. * * Foreign export declarations generate C wrappers for Hugs functions. * Hugs only provides "foreign export dynamic" because it's not obvious * what "foreign export static" would mean in an interactive setting. * ------------------------------------------------------------------------*/ -Void foreignImport(line,extName,intName,type) /* Handle foreign imports */ +Void foreignImport(line,callconv,extName,intName,type) + /* Handle foreign imports */ Cell line; +Text callconv; Pair extName; Cell intName; Cell type; { Text t = textOf(intName); Name n = findName(t); - Int l = intOf(line); if (isNull(n)) { - n = newName(t); + n = newName(t,NIL); } else if (name(n).defn!=PREDEFINED) { - ERRMSG(l) "Redeclaration of foreign \"%s\"", textToStr(t) + ERRMSG(line) "Redeclaration of foreign \"%s\"", textToStr(t) EEND; } - name(n).line = l; - name(n).defn = extName; - name(n).type = type; - foreignImports = cons(n,foreignImports); + name(n).line = line; + name(n).defn = extName; + name(n).type = type; + name(n).callconv = callconv; + foreignImports = cons(n,foreignImports); } static Void local checkForeignImport(p) /* Check foreign import */ @@ -2394,25 +3291,27 @@ Name p; { implementForeignImport(p); } -Void foreignExport(line,extName,intName,type)/* Handle foreign exports */ +Void foreignExport(line,callconv,extName,intName,type) + /* Handle foreign exports */ Cell line; +Text callconv; Cell extName; Cell intName; Cell type; { Text t = textOf(intName); Name n = findName(t); - Int l = intOf(line); if (isNull(n)) { - n = newName(t); + n = newName(t,NIL); } else if (name(n).defn!=PREDEFINED) { - ERRMSG(l) "Redeclaration of foreign \"%s\"", textToStr(t) + ERRMSG(line) "Redeclaration of foreign \"%s\"", textToStr(t) EEND; } - name(n).line = l; - name(n).defn = NIL; /* nothing to say */ - name(n).type = type; - foreignExports = cons(n,foreignExports); + name(n).line = line; + name(n).defn = NIL; /* nothing to say */ + name(n).type = type; + name(n).callconv = callconv; + foreignExports = cons(n,foreignExports); } static Void local checkForeignExport(p) /* Check foreign export */ @@ -2425,6 +3324,8 @@ Name p; { implementForeignExport(p); } + + /* -------------------------------------------------------------------------- * Static analysis of patterns: * @@ -2444,31 +3345,32 @@ Name p; { * complete pattern list (as is required on the lhs of a function defn). * ------------------------------------------------------------------------*/ -static List patVars; /* List of vars bound in pattern */ +static List patVars; /* List of vars bound in pattern */ -static Cell local checkPat(line,p) /* Check valid pattern syntax */ +static Cell local checkPat(line,p) /* Check valid pattern syntax */ Int line; Cell p; { switch (whatIs(p)) { case VARIDCELL : - case VAROPCELL : addPatVar(line,p); + case VAROPCELL : addToPatVars(line,p); break; + case INFIX : return checkPat(line,tidyInfix(line,snd(p))); + case AP : return checkMaybeCnkPat(line,p); case NAME : case QUALIDENT : - case CONIDCELL : + case CONIDCELL : case CONOPCELL : return checkApPat(line,0,p); case WILDCARD : case STRCELL : case CHARCELL : - case INTCELL : - case BIGCELL : case FLOATCELL : break; + case INTCELL : break; - case ASPAT : addPatVar(line,fst(snd(p))); + case ASPAT : addToPatVars(line,fst(snd(p))); snd(snd(p)) = checkPat(line,snd(snd(p))); break; @@ -2481,27 +3383,11 @@ Cell p; { case CONFLDS : depConFlds(line,p,TRUE); break; - case ESIGN : { Type t = snd(snd(p)); - List tvs = typeVarsIn(t,NIL,NIL); - for (; nonNull(tvs); tvs=tl(tvs)) { - Int beta = newKindvars(1); - hd(btyvars) = cons(pair(hd(tvs),mkInt(beta)), - hd(btyvars)); - } - t = checkSigType(line, - "pattern type", - fst(snd(p)), - t); - if (isPolyType(t) - || whatIs(t)==QUAL - || whatIs(t)==RANK2) { - ERRMSG(line) - "Illegal type in pattern annotation" - EEND; - } - snd(snd(p)) = t; - fst(snd(p)) = checkPat(line,fst(snd(p))); - } + case ESIGN : snd(snd(p)) = checkPatType(line, + "pattern", + fst(snd(p)), + snd(snd(p))); + fst(snd(p)) = checkPat(line,fst(snd(p))); break; default : ERRMSG(line) "Illegal pattern syntax" @@ -2510,35 +3396,32 @@ Cell p; { return p; } -static Cell local checkMaybeCnkPat(l,p) /* Check applicative pattern with */ -Int l; /* the possibility of n+k pattern */ +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)) && !isBignum(arg(p))) { - ERRMSG(l) "Second argument in (n+k) pattern must be an integer" - EEND; + if (!isInt(arg(p))) { + ERRMSG(l) "Second argument in (n+k) pattern must be an integer" + EEND; } -#if 0 /* can't call intOf - it might be a bignum */ if (intOf(arg(p))<=0) { - ERRMSG(l) "Integer k in (n+k) pattern must be > 0" - EEND; + ERRMSG(l) "Integer k in (n+k) pattern must be > 0" + EEND; } -#endif - overwrite2(fun(p),ADDPAT,arg(p)); + 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 */ +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)); @@ -2552,19 +3435,20 @@ Cell p; { break; #if TREX - case EXT : if (args!=2) { + case EXT : h98DoesntSupport(line,"extensible records"); + if (args!=2) { ERRMSG(line) "Illegal record pattern" EEND; } break; #endif - case QUALIDENT : - if (!isQCon(p)) { - ERRMSG(line) "Illegal use of qualified variable in pattern" - EEND; - } - /* deliberate fall through */ + case QUALIDENT : if (!isQCon(p)) { + ERRMSG(line) + "Illegal use of qualified variable in pattern" + EEND; + } + /* deliberate fall through */ case CONIDCELL : case CONOPCELL : p = conDefined(line,p); checkCfunArgs(line,p,args); @@ -2580,40 +3464,41 @@ Cell p; { 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; - - 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)) { +static Void local addToPatVars(line,v) /* Add variable v to list of vars */ +Int line; /* in current pattern, checking */ +Cell v; { /* for repeated variables. */ + Text t = textOf(v); + List p = NIL; + List n = patVars; + + 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 { + } else { tl(p) = cons(v,NIL); - } + } } -static Name local conDefined(line,nm) /* check that nm is the name of a */ -Int line; /* previously defined constructor */ -Cell nm; { /* function. */ - Cell c=findQualName(line,nm); - if (isNull(c)) { +static Name local conDefined(line,nm) /* check that nm is the name of a */ +Int line; /* previously defined constructor */ +Cell nm; { /* function. */ + Name n = findQualName(nm); + if (isNull(n)) { ERRMSG(line) "Undefined constructor function \"%s\"", identToStr(nm) EEND; } - checkIsCfun(line,c); - return c; + checkIsCfun(line,n); + return n; } -static Void local checkIsCfun(line,c) /* Check that c is a constructor fn*/ +static Void local checkIsCfun(line,c) /* Check that c is a constructor fn */ Int line; Name c; { if (!isCfun(c)) { @@ -2624,20 +3509,41 @@ Name c; { } static Void local checkCfunArgs(line,c,args) -Int line; /* Check constructor applied with */ -Cell c; /* correct number of arguments */ +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 + Int a = userArity(c); + if (a!=args) { + ERRMSG(line) + "Constructor \"%s\" must have exactly %d argument%s in pattern", + textToStr(name(c).text), a, ((a==1)?"":"s") + EEND; + } +} + +static Cell local checkPatType(l,wh,e,t)/* Check type appearing in pattern */ +Int l; +String wh; +Cell e; +Type t; { + List tvs = typeVarsIn(t,NIL,NIL,NIL); + h98DoesntSupport(l,"pattern type annotations"); + for (; nonNull(tvs); tvs=tl(tvs)) { + Int beta = newKindvars(1); + hd(btyvars) = cons(pair(hd(tvs),mkInt(beta)), hd(btyvars)); + } + t = checkSigType(l,"pattern type",e,t); + if (isPolyOrQualType(t) || whatIs(t)==RANK2) { + ERRMSG(l) "Illegal syntax in %s type annotation", wh EEND; } + return t; } static Cell local applyBtyvs(pat) /* Record bound type vars in pat */ Cell pat; { List bts = hd(btyvars); - btyvars = tl(btyvars); + leaveBtyvs(); if (nonNull(bts)) { pat = ap(BIGLAM,pair(bts,pat)); for (; nonNull(bts); bts=tl(bts)) { @@ -2652,14 +3558,18 @@ Cell pat; { * 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 */ +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 */ +/* bounds :: [[Var]] -- var equality used on Vars */ +/* bindings :: [[([Var],?)]] -- var equality used on Vars */ +/* depends :: [[Var]] -- pointer equality used on Vars */ -static Cell local bindPat(line,p) /* add new bound vars for pattern */ +#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; @@ -2668,7 +3578,7 @@ Cell p; { return p; } -static Void local bindPats(line,ps) /* add new bound vars for patterns */ +static Void local bindPats(line,ps) /* add new bound vars for patterns */ Int line; List ps; { patVars = NIL; @@ -2684,7 +3594,9 @@ List ps; { * known. * * The result of parsing a list of value declarations is a list of Eqns: - * Eqn ::= (SIGDECL,(Line,[Var],type)) | (Expr,Rhs) + * Eqn ::= (SIGDECL,(Line,[Var],type)) + * | (FIXDECL,(Line,[Op],SyntaxInt)) + * | (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 @@ -2713,15 +3625,16 @@ List ps; { * - 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. + * - Similar properties for fixity declarations. * * ------------------------------------------------------------------------*/ -#define bindingType(b) fst(snd(b)) /* type (or types) for binding */ -#define fbindAlts(b) snd(snd(b)) /*alternatives for function binding*/ +#define bindingAttr(b) fst(snd(b)) /* type(s)/fixity(ies) for binding */ +#define fbindAlts(b) snd(snd(b)) /* alternatives for function binding*/ -static List local extractSigdecls(es) /* extract the SIGDECLS from list */ -List es; { /* of equations */ - List sigDecls = NIL; /* :: [(Line,[Var],Type)] */ +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? */ @@ -2735,103 +3648,167 @@ List es; { /* of equations */ EEND; } } - sigDecls = cons(sig,sigDecls); /* discard SIGDECL tag */ + sigdecls = cons(sig,sigdecls); /* discard SIGDECL tag*/ + } + } + return sigdecls; +} + +static List local extractFixdecls(es) /* Extract the FIXDECLS from list */ +List es; { /* of equations */ + List fixdecls = NIL; /* :: [(Line,SyntaxInt,[Op])] */ + + for(; nonNull(es); es=tl(es)) { + if (fst(hd(es))==FIXDECL) { /* fixity declaration?*/ + fixdecls = cons(snd(hd(es)),fixdecls); /* discard FIXDECL tag*/ } } - return sigDecls; + return fixdecls; } -static List local extractBindings(es) /* extract untyped bindings from */ -List es; { /* given list of equations */ +static List local extractBindings(ds) /* extract untyped bindings from */ +List ds; { /* 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)!=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); - bs = cons(pair(lhsHead, - pair(NIL, - singleton(newAlt))), - bs); - } + for(; nonNull(ds); ds=tl(ds)) { + Cell d = hd(ds); + if (fst(d)==FUNBIND) { /* Function bindings */ + Cell rhs = snd(snd(d)); + Int line = rhsLine(rhs); + Cell lhs = fst(snd(d)); + Cell v = getHead(lhs); + Cell newAlt = pair(getArgs(lhs),rhs); + if (!isVar(v)) { + internal("FUNBIND"); + } + if (nonNull(lastVar) && textOf(v)==textOf(lastVar)) { + if (argCount!=lastArity) { + ERRMSG(line) "Equations give different arities for \"%s\"", + textToStr(textOf(v)) + EEND; } - break; + fbindAlts(hd(bs)) = cons(newAlt,fbindAlts(hd(bs))); + } + else { + lastVar = v; + lastArity = argCount; + notDefined(line,bs,v); + bs = cons(pair(v,pair(NIL,singleton(newAlt))),bs); + } - case QUALIDENT: if (isQVar(lhsHead)) { - ERRMSG(line) "Binding for qualified variable \"%s\" not allowed", - identToStr(lhsHead) - EEND; - } - break; - /* deliberate fall through */ -#if TREX - case EXT : -#endif - case CONFLDS : - case CONOPCELL : - case CONIDCELL : - case FINLIST : - case TUPLE : - case NAME : - case LAZYPAT : - case ASPAT : lastVar = NIL; /* pattern-binding? */ - patVars = NIL; - enterBtyvs(); - 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); - if (nonNull(hd(btyvars))) { - ERRMSG(line) - "Sorry, no type variables are allowed in pattern binding type annotations" - EEND; - } - leaveBtyvs(); - break; - - default : ERRMSG(line) "Improper left hand side" - EEND; + } else if (fst(d)==PATBIND) { /* Pattern bindings */ + Cell rhs = snd(snd(d)); + Int line = rhsLine(rhs); + Cell pat = fst(snd(d)); + while (whatIs(pat)==ESIGN) {/* Move type annotations to rhs */ + Cell p = fst(snd(pat)); + fst(snd(pat)) = rhs; + snd(snd(d)) = rhs = pat; + fst(snd(d)) = pat = p; + fst(rhs) = RSIGN; + } + if (isVar(pat)) { /* Convert simple pattern bind to */ + notDefined(line,bs,pat);/* a function binding */ + bs = cons(pair(pat,pair(NIL,singleton(pair(NIL,rhs)))),bs); + } else { + List vs = getPatVars(line,pat,NIL); + if (isNull(vs)) { + ERRMSG(line) "No variables defined in lhs pattern" + EEND; + } + map2Proc(notDefined,line,bs,vs); + bs = cons(pair(vs,pair(NIL,snd(d))),bs); } + lastVar = NIL; } } return bs; } -static List local eqnsToBindings(es) /*Convert list of equations to list*/ -List es; { /*of typed bindings */ +static List local getPatVars(line,p,vs) /* Find list of variables bound in */ +Int line; /* pattern p */ +Cell p; +List vs; { + switch (whatIs(p)) { + case AP : do { + vs = getPatVars(line,arg(p),vs); + p = fun(p); + } while (isAp(p)); + return vs; /* Ignore head of application */ + + case CONFLDS : { List pfs = snd(snd(p)); + for (; nonNull(pfs); pfs=tl(pfs)) { + if (isVar(hd(pfs))) { + vs = addPatVar(line,hd(pfs),vs); + } else { + vs = getPatVars(line,snd(hd(pfs)),vs); + } + } + } + return vs; + + case FINLIST : { List ps = snd(p); + for (; nonNull(ps); ps=tl(ps)) { + vs = getPatVars(line,hd(ps),vs); + } + } + return vs; + + case ESIGN : return getPatVars(line,fst(snd(p)),vs); + + case LAZYPAT : + case NEG : + case ONLY : + case INFIX : return getPatVars(line,snd(p),vs); + + case ASPAT : return addPatVar(line,fst(snd(p)), + getPatVars(line,snd(snd(p)),vs)); + + case VARIDCELL : + case VAROPCELL : return addPatVar(line,p,vs); + + case CONIDCELL : + case CONOPCELL : + case QUALIDENT : + case INTCELL : + case FLOATCELL : + case CHARCELL : + case STRCELL : + case NAME : + case WILDCARD : return vs; + + default : internal("getPatVars"); + } + return vs; +} + +static List local addPatVar(line,v,vs) /* Add var to list of previously */ +Int line; /* encountered variables */ +Cell v; +List vs; { + if (varIsMember(textOf(v),vs)) { + ERRMSG(line) "Repeated use of variable \"%s\" in pattern binding", + textToStr(textOf(v)) + EEND; + } + return cons(v,vs); +} + +static List local eqnsToBindings(es,ts,cs,ps) +List es; /* Convert list of equations to */ +List ts; /* list of typed bindings */ +List cs; +List ps; { List bs = extractBindings(es); - map1Proc(addSigDecl,bs,extractSigdecls(es)); + map1Proc(addSigdecl,bs,extractSigdecls(es)); + map4Proc(addFixdecl,bs,ts,cs,ps,extractFixdecls(es)); return bs; } -static Void local notDefined(line,bs,v) /* check if name already defined in*/ -Int line; /* list of bindings */ +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))) { @@ -2840,70 +3817,441 @@ Cell v; { } } -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); +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 Cell local getAttr(bs,v) /* Locate type/fixity attribute */ +List bs; /* for variable v in bindings bs */ +Cell v; { + Text t = textOf(v); + Cell b = findBinding(t,bs); + + if (isNull(b)) { /* No binding */ + return NIL; + } else if (isVar(fst(b))) { /* func binding? */ + if (isNull(bindingAttr(b))) { + bindingAttr(b) = pair(NIL,NIL); + } + return bindingAttr(b); + } else { /* pat binding? */ + List vs = fst(b); + List as = bindingAttr(b); + + if (isNull(as)) { + bindingAttr(b) = as = replicate(length(vs),NIL); + } + + while (nonNull(vs) && t!=textOf(hd(vs))) { + vs = tl(vs); + as = tl(as); + } + + if (isNull(vs)) { + internal("getAttr"); + } else if (isNull(hd(as))) { + hd(as) = pair(NIL,NIL); + } + return hd(as); + } +} + +static Void local addSigdecl(bs,sigdecl)/* add type information to bindings*/ +List bs; /* :: [Binding] */ +Cell sigdecl; { /* :: (Line,[Var],Type) */ + Int l = intOf(fst3(sigdecl)); + List vs = snd3(sigdecl); + Type type = checkSigType(l,"type declaration",hd(vs),thd3(sigdecl)); + + for (; nonNull(vs); vs=tl(vs)) { + Cell v = hd(vs); + Pair attr = getAttr(bs,v); + if (isNull(attr)) { + ERRMSG(l) "Missing binding for variable \"%s\" in type signature", + textToStr(textOf(v)) + EEND; + } else if (nonNull(fst(attr))) { + ERRMSG(l) "Repeated type signature for \"%s\"", + textToStr(textOf(v)) + EEND; + } + fst(attr) = type; + } +} + +static Void local addFixdecl(bs,ts,cs,ps,fixdecl) +List bs; +List ts; +List cs; +List ps; +Triple fixdecl; { + Int line = intOf(fst3(fixdecl)); + List ops = snd3(fixdecl); + Cell sy = thd3(fixdecl); + + for (; nonNull(ops); ops=tl(ops)) { + Cell op = hd(ops); + Text t = textOf(op); + Cell attr = getAttr(bs,op); + if (nonNull(attr)) { /* Found name in binding? */ + if (nonNull(snd(attr))) { + dupFixity(line,t); } - } else if (nonNull(varIsMember(t,fst(hd(bs))))) { /* pattern-binding? */ - return hd(bs); + snd(attr) = sy; + } else { /* Look in tycons, classes, prims */ + Name n = NIL; + List ts1 = ts; + List cs1 = cs; + List ps1 = ps; + for (; isNull(n) && nonNull(ts1); ts1=tl(ts1)) { /* tycons */ + Tycon tc = hd(ts1); + if (tycon(tc).what==DATATYPE || tycon(tc).what==NEWTYPE) { + n = nameIsMember(t,tycon(tc).defn); + } + } + for (; isNull(n) && nonNull(cs1); cs1=tl(cs1)) { /* classes */ + n = nameIsMember(t,cclass(hd(cs1)).members); + } + for (; isNull(n) && nonNull(ps1); ps1=tl(ps1)) { /* prims */ + n = nameIsMember(t,hd(ps1)); + } + + if (isNull(n)) { + missFixity(line,t); + } else if (name(n).syntax!=NO_SYNTAX) { + dupFixity(line,t); + } + name(n).syntax = intOf(sy); } } - 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)); +static Void local dupFixity(line,t) /* Report repeated fixity decl */ +Int line; +Text t; { + ERRMSG(line) + "Repeated fixity declaration for operator \"%s\"", textToStr(t) + EEND; +} - map3Proc(setType,line,type,bs,vs); +static Void local missFixity(line,t) /* Report missing op for fixity */ +Int line; +Text t; { + ERRMSG(line) + "Cannot find binding for operator \"%s\" in fixity declaration", + textToStr(t) + EEND; } -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); +/* -------------------------------------------------------------------------- + * Dealing with infix operators: + * + * Expressions involving infix operators or unary minus are parsed as + * elements of the following type: + * + * data InfixExp = Only Exp | Neg InfixExp | Infix InfixExp Op Exp + * + * (The algorithms here do not assume that negation can be applied only once, + * i.e., that - - x is a syntax error, as required by the Haskell report. + * Instead, that restriction is captured by the grammar itself, given above.) + * + * There are rules of precedence and grouping, expressed by two functions: + * + * prec :: Op -> Int; assoc :: Op -> Assoc (Assoc = {L, N, R}) + * + * InfixExp values are rearranged accordingly when a complete expression + * has been read using a simple shift-reduce parser whose result may be taken + * to be a value of the following type: + * + * data Exp = Atom Int | Negate Exp | Apply Op Exp Exp | Error String + * + * The machine on which this parser is based can be defined as follows: + * + * tidy :: InfixExp -> [(Op,Exp)] -> Exp + * tidy (Only a) [] = a + * tidy (Only a) ((o,b):ss) = tidy (Only (Apply o a b)) ss + * tidy (Infix a o b) [] = tidy a [(o,b)] + * tidy (Infix a o b) ((p,c):ss) + * | shift o p = tidy a ((o,b):(p,c):ss) + * | red o p = tidy (Infix a o (Apply p b c)) ss + * | ambig o p = Error "ambiguous use of operators" + * tidy (Neg e) [] = tidy (tidyNeg e) [] + * tidy (Neg e) ((o,b):ss) + * | nshift o = tidy (Neg (underNeg o b e)) ss + * | nred o = tidy (tidyNeg e) ((o,b):ss) + * | nambig o = Error "illegal use of negation" + * + * At each stage, the parser can either shift, reduce, accept, or error. + * The transitions when dealing with juxtaposed operators o and p are + * determined by the following rules: + * + * shift o p = (prec o > prec p) + * || (prec o == prec p && assoc o == L && assoc p == L) + * + * red o p = (prec o < prec p) + * || (prec o == prec p && assoc o == R && assoc p == R) + * + * ambig o p = (prec o == prec p) + * && (assoc o == N || assoc p == N || assoc o /= assoc p) + * + * The transitions when dealing with juxtaposed unary minus and infix + * operators are as follows. The precedence of unary minus (infixl 6) is + * hardwired in to these definitions, as it is to the definitions of the + * Haskell grammar in the official report. + * + * nshift o = (prec o > 6) + * nred o = (prec o < 6) || (prec o == 6 && assoc o == L) + * nambig o = prec o == 6 && (assoc o == R || assoc o == N) + * + * An InfixExp of the form (Neg e) means negate the last thing in + * the InfixExp e; we can force this negation using: + * + * tidyNeg :: OpExp -> OpExp + * tidyNeg (Only e) = Only (Negate e) + * tidyNeg (Infix a o b) = Infix a o (Negate b) + * tidyNeg (Neg e) = tidyNeg (tidyNeg e) + * + * On the other hand, if we want to sneak application of an infix operator + * under a negation, then we use: + * + * underNeg :: Op -> Exp -> OpExp -> OpExp + * underNeg o b (Only e) = Only (Apply o e b) + * underNeg o b (Neg e) = Neg (underNeg o b e) + * underNeg o b (Infix e p f) = Infix e p (Apply o f b) + * + * As a concession to efficiency, we lower the number of calls to syntaxOf + * by keeping track of the values of sye, sys throughout the process. The + * value APPLIC is used to indicate that the syntax value is unknown. + * ------------------------------------------------------------------------*/ - if (isNull(b)) { - ERRMSG(line) "Type declaration for variable \"%s\" with no body", - textToStr(t) - EEND; +static Cell local tidyInfix(line,e) /* Convert infixExp to Exp */ +Int line; +Cell e; { /* :: OpExp */ + Cell s = NIL; /* :: [(Op,Exp)] */ + Syntax sye = APPLIC; /* Syntax of op in e (init unknown)*/ + Syntax sys = APPLIC; /* Syntax of op in s (init unknown)*/ + Cell d = e; + + while (fst(d)!=ONLY) { /* Attach fixities to operators */ + if (fst(d)==NEG) { + d = snd(d); + } else { + fun(fun(d)) = attachFixity(line,fun(fun(d))); + d = arg(fun(d)); + } } - 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); + for (;;) + switch (whatIs(e)) { + case ONLY : e = snd(e); + while (nonNull(s)) { + Cell next = arg(fun(s)); + arg(fun(s)) = e; + fun(fun(s)) = snd(fun(fun(s))); + e = s; + s = next; + } + return e; - if (isNull(ts)) { - bindingType(b) = ts = replicate(length(vs),NIL); - } - while (nonNull(vs) && t!=textOf(hd(vs))) { - vs = tl(vs); - ts = tl(ts); - } + case NEG : if (nonNull(s)) { + if (sys==APPLIC) { /* calculate sys */ + sys = intOf(fst(fun(fun(s)))); + } - if (nonNull(vs) && isNull(hd(ts))) { - hd(ts) = type; - return; + if (precOf(sys)==UMINUS_PREC && /* nambig */ + assocOf(sys)!=UMINUS_ASSOC) { + ERRMSG(line) + "Ambiguous use of unary minus with \"" + ETHEN ERREXPR(snd(fun(fun(s)))); + ERRTEXT "\"" + EEND; + } + + if (precOf(sys)>UMINUS_PREC) { /* nshift */ + Cell e1 = snd(e); + Cell t = s; + s = arg(fun(s)); + while (whatIs(e1)==NEG) + e1 = snd(e1); + arg(fun(t)) = arg(e1); + fun(fun(t)) = snd(fun(fun(t))); + arg(e1) = t; + sys = APPLIC; + continue; + } + } + + /* Intentional fall-thru for nreduce and isNull(s) */ + + { Cell prev = e; /* e := tidyNeg e */ + Cell temp = arg(prev); + Int nneg = 1; + for (; whatIs(temp)==NEG; nneg++) { + fun(prev) = nameNegate; + prev = temp; + temp = arg(prev); + } + if (isInt(arg(temp))) { /* special cases */ + if (nneg&1) /* for literals */ + arg(temp) = mkInt(-intOf(arg(temp))); + } + else if (isFloat(arg(temp))) { + if (nneg&1) + arg(temp) = floatNegate(arg(temp)); + //mkFloat(-floatOf(arg(temp))); + } + else { + fun(prev) = nameNegate; + arg(prev) = arg(temp); + arg(temp) = e; + } + e = temp; + } + continue; + + default : if (isNull(s)) {/* Move operation onto empty stack */ + Cell next = arg(fun(e)); + s = e; + arg(fun(s)) = NIL; + e = next; + sys = sye; + sye = APPLIC; + } + else { /* deal with pair of operators */ + + if (sye==APPLIC) { /* calculate sys and sye */ + sye = intOf(fst(fun(fun(e)))); + } + if (sys==APPLIC) { + sys = intOf(fst(fun(fun(s)))); + } + + if (precOf(sye)==precOf(sys) && /* ambig */ + (assocOf(sye)!=assocOf(sys) || + assocOf(sye)==NON_ASS)) { + ERRMSG(line) "Ambiguous use of operator \"" + ETHEN ERREXPR(snd(fun(fun(e)))); + ERRTEXT "\" with \"" + ETHEN ERREXPR(snd(fun(fun(s)))); + ERRTEXT "\"" + EEND; + } + + if (precOf(sye)>precOf(sys) || /* shift */ + (precOf(sye)==precOf(sys) && + assocOf(sye)==LEFT_ASS && + assocOf(sys)==LEFT_ASS)) { + Cell next = arg(fun(e)); + arg(fun(e)) = s; + s = e; + e = next; + sys = sye; + sye = APPLIC; + } + else { /* reduce */ + Cell next = arg(fun(s)); + arg(fun(s)) = arg(e); + fun(fun(s)) = snd(fun(fun(s))); + arg(e) = s; + s = next; + sys = APPLIC; + /* sye unchanged */ + } + } + continue; } +} + +static Pair local attachFixity(line,op) /* Attach fixity to operator in an */ +Int line; /* infix expression */ +Cell op; { + Syntax sy = DEF_OPSYNTAX; + + switch (whatIs(op)) { + case VAROPCELL : + case VARIDCELL : if ((sy=lookupSyntax(textOf(op)))==NO_SYNTAX) { + Name n = findName(textOf(op)); + if (isNull(n)) { + ERRMSG(line) "Undefined variable \"%s\"", + textToStr(textOf(op)) + EEND; + } + sy = syntaxOf(n); + op = n; + } + break; + + case CONOPCELL : + case CONIDCELL : sy = syntaxOf(op = conDefined(line,op)); + break; + + case QUALIDENT : { Name n = findQualName(op); + if (nonNull(n)) { + op = n; + sy = syntaxOf(n); + } else { + ERRMSG(line) + "Undefined qualified variable \"%s\"", + identToStr(op) + EEND; + } + } + break; + } + if (sy==APPLIC) { + sy = DEF_OPSYNTAX; } + return pair(mkInt(sy),op); /* Pair fixity with (possibly) */ + /* translated operator */ +} - ERRMSG(line) "Repeated type declaration for \"%s\"", textToStr(t) - EEND; +static Syntax local lookupSyntax(t) /* Try to find fixity for var in */ +Text t; { /* enclosing bindings */ + List bounds1 = bounds; + List bindings1 = bindings; + + while (nonNull(bindings1)) { + if (nonNull(varIsMember(t,hd(bounds1)))) { + return DEF_OPSYNTAX; + } else { + Cell b = findBinding(t,hd(bindings1)); + if (nonNull(b)) { + Cell a = fst(snd(b)); + if (isVar(fst(b))) { /* Function binding */ + if (nonNull(a) && nonNull(snd(a))) { + return intOf(snd(a)); + } + } else { /* Pattern binding */ + List vs = fst(b); + while (nonNull(vs) && nonNull(a)) { + if (t==textOf(hd(vs))) { + if (nonNull(hd(a)) && isInt(snd(hd(a)))) { + return intOf(snd(hd(a))); + } + break; + } + vs = tl(vs); + a = tl(a); + } + } + return DEF_OPSYNTAX; + } + } + bounds1 = tl(bounds1); + bindings1 = tl(bindings1); + } + return NO_SYNTAX; } /* -------------------------------------------------------------------------- @@ -2919,76 +4267,115 @@ List bs; { * 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 + * Binding' ::= (Var, (Attr, (Dep, [Alt]))) -- function binding + * | ([Var], ([Attr], (Dep, (Pat,Rhs)))) -- pattern binding * * ------------------------------------------------------------------------*/ -#define depVal(d) (fst(snd(d))) /* Access to dependency information*/ - +#define depVal(d) (fst(snd(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 */ - + /* 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; -} - + 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)) { - emptySubstitution(); - 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 */ + 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)) { + emptySubstitution(); + 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(snd(b)) = pair(NIL,snd(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(snd(b)) = snd(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 */ + List bs = hd(bindings); /* Remove fixity info from binds */ + Bool toplevel = isNull(tl(bindings)); + for (; nonNull(bs); bs=tl(bs)) { + Cell b = hd(bs); + if (isVar(fst(b))) { /* Variable binding */ + Cell a = fst(snd(b)); + if (isPair(a)) { + if (toplevel) { + saveSyntax(fst(b),snd(a)); + } + fst(snd(b)) = fst(a); + } + } else { /* Pattern binding */ + List vs = fst(b); + List as = fst(snd(b)); + while (nonNull(vs) && nonNull(as)) { + if (isPair(hd(as))) { + if (toplevel) { + saveSyntax(hd(vs),snd(hd(as))); + } + hd(as) = fst(hd(as)); + } + vs = tl(vs); + as = tl(as); + } + } + } bounds = tl(bounds); bindings = tl(bindings); depends = tl(depends); } +static Void local saveSyntax(v,sy) /* Save syntax of top-level var */ +Cell v; /* in corresponding Name */ +Cell sy; { + Name n = findName(textOf(v)); + if (isNull(n) || name(n).syntax!=NO_SYNTAX) { + internal("saveSyntax"); + } + if (nonNull(sy)) { + name(n).syntax = intOf(sy); + } +} + /* -------------------------------------------------------------------------- * As a side effect of the dependency analysis we also make the following * checks: @@ -3003,38 +4390,52 @@ static Void local leaveScope() { /* leave scope of last withinScope */ * - No free (i.e. unbound) variables are used in the declaration list. * ------------------------------------------------------------------------*/ -static Void local depBinding(b) /* find dependents of binding */ +static Void local depBinding(b) /* find dependents of binding */ Cell b; { - Cell defpart = snd(snd(snd(b))); /* definition part of binding */ + Cell defpart = snd(snd(snd(b))); /* definition part of binding */ hd(depends) = NIL; - if (isVar(fst(b))) { /* function-binding? */ + if (isVar(fst(b))) { /* function-binding? */ mapProc(depAlt,defpart); - if (isNull(fst(snd(snd(b))))) { /* Save dep info for implicitly */ - fst(snd(snd(b))) = ap(IMPDEPS,hd(depends)); /* typed var binds */ + if (isNull(fst(snd(b)))) { /* Save dep info if no type sig */ + fst(snd(b)) = pair(ap(IMPDEPS,hd(depends)),NIL); + } else if (isNull(fst(fst(snd(b))))) { + fst(fst(snd(b))) = ap(IMPDEPS,hd(depends)); } - } else { /* pattern-binding? */ + } else { /* pattern-binding? */ + Int line = rhsLine(snd(defpart)); + enterBtyvs(); + patVars = NIL; + fst(defpart) = checkPat(line,fst(defpart)); depRhs(snd(defpart)); +#if 0 + if (nonNull(hd(btyvars))) { + ERRMSG(line) + "Sorry, no type variables are allowed in pattern binding type annotations" + EEND; + } +#endif + fst(defpart) = applyBtyvs(fst(defpart)); } depVal(b) = hd(depends); } -static Void local depDefaults(c) /* dependency analysis on defaults */ -Class c; { /* from class definition */ +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 */ +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,snd(hd(bs))); /* dependency information ... */ +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,snd(hd(bs)));/* dependency information... */ } } } @@ -3055,7 +4456,7 @@ Cell r; { case GUARDED : mapProc(depGuard,snd(r)); break; - case LETREC : fst(snd(r)) = eqnsToBindings(fst(snd(r))); + case LETREC : fst(snd(r)) = eqnsToBindings(fst(snd(r)),NIL,NIL,NIL); withinScope(fst(snd(r))); fst(snd(r)) = dependencyAnal(fst(snd(r))); hd(depends) = fst(snd(r)); @@ -3063,19 +4464,28 @@ Cell r; { leaveScope(); break; + case RSIGN : snd(snd(r)) = checkPatType(rhsLine(fst(snd(r))), + "result", + rhsExpr(fst(snd(r))), + snd(snd(r))); + depRhs(fst(snd(r))); + break; + default : snd(r) = depExpr(intOf(fst(r)),snd(r)); break; } } -static Void local depGuard(g) /*find dependents of single guarded*/ -Cell g; { /* expression */ +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 */ +static Cell local depExpr(line,e) /* find dependents of expression */ Int line; Cell e; { + //Printf( "\n\n"); print(e,100); Printf("\n"); + //printExp(stdout,e); switch (whatIs(e)) { case VARIDCELL : @@ -3090,6 +4500,8 @@ Cell e; { return conDefined(line,e); } + case INFIX : return depExpr(line,tidyInfix(line,snd(e))); + #if TREX case RECSEL : break; @@ -3111,13 +4523,17 @@ Cell e; { break; #endif +#if IPARAM + case IPVAR : +#endif + case NAME : case TUPLE : case STRCELL : case CHARCELL : - case INTCELL : - case BIGCELL : - case FLOATCELL : break; + case FLOATCELL : + case BIGCELL : + case INTCELL : break; case COND : depTriple(line,snd(e)); break; @@ -3125,7 +4541,7 @@ Cell e; { case FINLIST : map1Over(depExpr,line,snd(e)); break; - case LETREC : fst(snd(e)) = eqnsToBindings(fst(snd(e))); + case LETREC : fst(snd(e)) = eqnsToBindings(fst(snd(e)),NIL,NIL,NIL); withinScope(fst(snd(e))); fst(snd(e)) = dependencyAnal(fst(snd(e))); hd(depends) = fst(snd(e)); @@ -3157,6 +4573,11 @@ Cell e; { case UPDFLDS : depUpdFlds(line,e); break; +#if IPARAM + case WITHEXP : depWith(line,e); + break; +#endif + case ASPAT : ERRMSG(line) "Illegal `@' in expression" EEND; @@ -3171,7 +4592,7 @@ Cell e; { EEND; #endif - default : internal("in depExpr"); + default : internal("depExpr"); } return e; } @@ -3195,9 +4616,9 @@ static Void local depComp(l,e,qs) /* find dependents of comprehension*/ Int l; Cell e; List qs; { - if (isNull(qs)) + if (isNull(qs)) { fst(e) = depExpr(l,fst(e)); - else { + } else { Cell q = hd(qs); List qs1 = tl(qs); switch (whatIs(q)) { @@ -3211,7 +4632,7 @@ List qs; { } break; - case QWHERE : snd(q) = eqnsToBindings(snd(q)); + case QWHERE : snd(q) = eqnsToBindings(snd(q),NIL,NIL,NIL); withinScope(snd(q)); snd(q) = dependencyAnal(snd(q)); hd(depends) = snd(q); @@ -3254,8 +4675,9 @@ Cell e; { } 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)); + if (!cellIsMember(n,hd(depends1))) { + hd(depends1) = cons(n,hd(depends1)); + } return (isVar(fst(n)) ? fst(n) : e); } @@ -3269,20 +4691,17 @@ Cell e; { EEND; } - if (name(n).mod != thisModule) { - return n; - } /* Later phases of the system cannot cope if we resolve references * to unprocessed objects too early. This is the main reason that * we cannot cope with recursive modules at the moment. */ - return n; + return e; } static Cell local depQVar(line,e)/* register occurrence of qualified variable */ Int line; Cell e; { - Cell n = findQualName(line,e); + Name n = findQualName(e); if (isNull(n)) { /* check global definitions */ ERRMSG(line) "Undefined qualified variable \"%s\"", identToStr(e) EEND; @@ -3316,13 +4735,16 @@ Bool isP; { if (!isP && isPair(name(c).defn)) { /* Check that banged fields defined*/ List scs = fst(name(c).defn); /* List of strict components */ Type t = name(c).type; - Int a = name(c).arity; + Int a = userArity(c); List fs = snd(snd(e)); List ss; if (isPolyType(t)) { /* Find tycon that c belongs to */ t = monotypeOf(t); } - if (whatIs(t)==QUAL) { + if (isQualType(t)) { + t = snd(snd(t)); + } + if (whatIs(t)==CDICTS) { t = snd(snd(t)); } while (0