2 /* --------------------------------------------------------------------------
3 * Static Analysis for Hugs
5 * The Hugs 98 system is Copyright (c) Mark P Jones, Alastair Reid, the
6 * Yale Haskell Group, and the Oregon Graduate Institute of Science and
7 * Technology, 1994-1999, All rights reserved. It is distributed as
8 * free software under the license in the file "License", which is
9 * included in the distribution.
11 * $RCSfile: static.c,v $
13 * $Date: 2000/04/06 00:01:27 $
14 * ------------------------------------------------------------------------*/
16 #include "hugsbasictypes.h"
21 /* --------------------------------------------------------------------------
22 * local function prototypes:
23 * ------------------------------------------------------------------------*/
25 static Void local kindError ( Int,Constr,Constr,String,Kind,Int );
26 static Void local checkQualImport ( Pair );
27 static Void local checkUnqualImport ( Triple );
29 static Name local lookupName ( Text,List );
30 static List local checkSubentities ( List,List,List,String,Text );
31 static List local checkExportTycon ( List,Text,Cell,Tycon );
32 static List local checkExportClass ( List,Text,Cell,Class );
33 static List local checkExport ( List,Text,Cell );
34 static List local checkImportEntity ( List,Module,Bool,Cell );
35 static List local resolveImportList ( Module,Cell,Bool );
36 static Void local checkImportList ( Pair );
38 static Void local importEntity ( Module,Cell );
39 static Void local importName ( Module,Name );
40 static Void local importTycon ( Module,Tycon );
41 static Void local importClass ( Module,Class );
42 static List local checkExports ( List, Module );
44 static Void local checkTyconDefn ( Tycon );
45 static Void local depConstrs ( Tycon,List,Cell );
46 static List local addSels ( Int,Name,List,List );
47 static List local selectCtxt ( List,List );
48 static Void local checkSynonyms ( List );
49 static List local visitSyn ( List,Tycon,List );
50 static Type local instantiateSyn ( Type,Type );
52 static Void local checkClassDefn ( Class );
53 static Cell local depPredExp ( Int,List,Cell );
54 static Void local checkMems ( Class,List,Cell );
55 static Void local checkMems2 ( Class,Cell );
56 static Void local addMembers ( Class );
57 static Name local newMember ( Int,Int,Cell,Type,Class );
58 static Text local generateText ( String,Class );
60 static List local classBindings ( String,Class,List );
61 static Name local memberName ( Class,Text );
62 static List local numInsert ( Int,Cell,List );
64 static List local maybeAppendVar ( Cell,List );
66 static Type local checkSigType ( Int,String,Cell,Type );
67 static Void local checkOptQuantVars ( Int,List,List );
68 static Type local depTopType ( Int,List,Type );
69 static Type local depCompType ( Int,List,Type );
70 static Type local depTypeExp ( Int,List,Type );
71 static Type local depTypeVar ( Int,List,Text );
72 static List local checkQuantVars ( Int,List,List,Cell );
73 static List local otvars ( Cell,List );
74 static Bool local osubset ( List,List );
75 static Void local kindConstr ( Int,Int,Int,Constr );
76 static Kind local kindAtom ( Int,Constr );
77 static Void local kindPred ( Int,Int,Int,Cell );
78 static Void local kindType ( Int,String,Type );
79 static Void local fixKinds ( Void );
81 static Void local kindTCGroup ( List );
82 static Void local initTCKind ( Cell );
83 static Void local kindTC ( Cell );
84 static Void local genTC ( Cell );
86 static Void local checkInstDefn ( Inst );
87 static Void local insertInst ( Inst );
88 static Bool local instCompare ( Inst,Inst );
89 static Name local newInstImp ( Inst );
90 static Void local kindInst ( Inst,Int );
91 static Void local checkDerive ( Tycon,List,List,Cell );
92 static Void local addDerInst ( Int,Class,List,List,Type,Int );
93 static Void local deriveContexts ( List );
94 static Void local initDerInst ( Inst );
95 static Void local calcInstPreds ( Inst );
96 static Void local maybeAddPred ( Cell,Int,Int,List );
97 static List local calcFunDeps ( List );
98 static Cell local copyAdj ( Cell,Int,Int );
99 static Void local tidyDerInst ( Inst );
100 static List local otvarsZonk ( Cell,List,Int );
102 static Void local addDerivImp ( Inst );
104 static Void local checkDefaultDefns ( Void );
106 static Void local checkForeignImport ( Name );
107 static Void local checkForeignExport ( Name );
109 static Cell local tidyInfix ( Int,Cell );
110 static Pair local attachFixity ( Int,Cell );
111 static Syntax local lookupSyntax ( Text );
113 static Cell local checkPat ( Int,Cell );
114 static Cell local checkMaybeCnkPat ( Int,Cell );
115 static Cell local checkApPat ( Int,Int,Cell );
116 static Void local addToPatVars ( Int,Cell );
117 static Name local conDefined ( Int,Cell );
118 static Void local checkIsCfun ( Int,Name );
119 static Void local checkCfunArgs ( Int,Cell,Int );
120 static Cell local checkPatType ( Int,String,Cell,Type );
121 static Cell local applyBtyvs ( Cell );
122 static Cell local bindPat ( Int,Cell );
123 static Void local bindPats ( Int,List );
125 static List local extractSigdecls ( List );
126 static List local extractFixdecls ( List );
127 static List local extractBindings ( List );
128 static List local getPatVars ( Int,Cell,List );
129 static List local addPatVar ( Int,Cell,List );
130 static List local eqnsToBindings ( List,List,List,List );
131 static Void local notDefined ( Int,List,Cell );
132 static Cell local findBinding ( Text,List );
133 static Cell local getAttr ( List,Cell );
134 static Void local addSigdecl ( List,Cell );
135 static Void local addFixdecl ( List,List,List,List,Triple );
136 static Void local dupFixity ( Int,Text );
137 static Void local missFixity ( Int,Text );
139 static List local dependencyAnal ( List );
140 static List local topDependAnal ( List );
141 static Void local addDepField ( Cell );
142 static Void local remDepField ( List );
143 static Void local remDepField1 ( Cell );
144 static Void local clearScope ( Void );
145 static Void local withinScope ( List );
146 static Void local leaveScope ( Void );
147 static Void local saveSyntax ( Cell,Cell );
149 static Void local depBinding ( Cell );
150 static Void local depDefaults ( Class );
151 static Void local depInsts ( Inst );
152 static Void local depClassBindings ( List );
153 static Void local depAlt ( Cell );
154 static Void local depRhs ( Cell );
155 static Void local depGuard ( Cell );
156 static Cell local depExpr ( Int,Cell );
157 static Void local depPair ( Int,Cell );
158 static Void local depTriple ( Int,Cell );
159 static Void local depComp ( Int,Cell,List );
160 static Void local depCaseAlt ( Int,Cell );
161 static Cell local depVar ( Int,Cell );
162 static Cell local depQVar ( Int,Cell );
163 static Void local depConFlds ( Int,Cell,Bool );
164 static Void local depUpdFlds ( Int,Cell );
165 static List local depFields ( Int,Cell,List,Bool );
167 static Void local depWith ( Int,Cell );
168 static List local depDwFlds ( Int,Cell,List );
171 static Cell local depRecord ( Int,Cell );
174 static List local tcscc ( List,List );
175 static List local bscc ( List );
177 static Void local addRSsigdecls ( Pair );
178 static Void local allNoPrevDef ( Cell );
179 static Void local noPrevDef ( Int,Cell );
180 static Bool local odiff ( List,List );
182 static Void local duplicateErrorAux ( Int,Module,Text,String );
183 #define duplicateError(l,m,t,k) duplicateErrorAux(l,m,t,k)
184 static Void local checkTypeIn ( Pair );
186 /* --------------------------------------------------------------------------
187 * The code in this file is arranged in roughly the following order:
188 * - Kind inference preliminaries
189 * - Module declarations
190 * - Type declarations (data, type, newtype, type in)
191 * - Class declarations
193 * - Instance declarations
194 * - Default declarations
195 * - Primitive definitions
197 * - Infix expressions
198 * - Value definitions
199 * - Top-level static analysis and control
200 * - Haskell 98 compatibility tests
201 * ------------------------------------------------------------------------*/
203 /* --------------------------------------------------------------------------
204 * Kind checking preliminaries:
205 * ------------------------------------------------------------------------*/
207 Bool kindExpert = FALSE; /* TRUE => display kind errors in */
210 static Void local kindError(l,c,in,wh,k,o)
211 Int l; /* line number near constuctor exp */
212 Constr c; /* constructor */
213 Constr in; /* context (if any) */
214 String wh; /* place in which error occurs */
215 Kind k; /* expected kind (k,o) */
216 Int o; { /* inferred kind (typeIs,typeOff) */
219 if (!kindExpert) { /* for those with a fear of kinds */
220 ERRMSG(l) "Illegal type" ETHEN
222 ERRTEXT " \"" ETHEN ERRTYPE(in);
225 ERRTEXT " in %s\n", wh
229 ERRMSG(l) "Kind error in %s", wh ETHEN
231 ERRTEXT "\n*** expression : " ETHEN ERRTYPE(in);
233 ERRTEXT "\n*** constructor : " ETHEN ERRTYPE(c);
234 ERRTEXT "\n*** kind : " ETHEN ERRKIND(copyType(typeIs,typeOff));
235 ERRTEXT "\n*** does not match : " ETHEN ERRKIND(copyType(k,o));
237 ERRTEXT "\n*** because : %s", unifyFails ETHEN
243 #define shouldKind(l,c,in,wh,k,o) if (!kunify(typeIs,typeOff,k,o)) \
244 kindError(l,c,in,wh,k,o)
245 #define checkKind(l,a,m,c,in,wh,k,o) kindConstr(l,a,m,c); \
246 shouldKind(l,c,in,wh,k,o)
247 #define inferKind(k,o) typeIs=k; typeOff=o
249 static List unkindTypes; /* types in need of kind annotation*/
251 Kind extKind; /* Kind of extension, *->row->row */
254 /* --------------------------------------------------------------------------
255 * Static analysis of modules:
256 * ------------------------------------------------------------------------*/
258 Void startModule ( Module m ) /* switch to a new module */
260 if (isNull(m)) internal("startModule");
264 Void setExportList(exps) /* Add export list to current module */
266 module(currentModule).exports = exps;
269 Void addQualImport(orig,new) /* Add to qualified import list */
270 Cell orig; /* Original name of module */
271 Cell new; { /* Name module is called within this module (or NIL) */
272 module(currentModule).qualImports =
273 cons(pair(isNull(new)?orig:new,orig),module(currentModule).qualImports);
276 Void addUnqualImport(mod,entities) /* Add to unqualified import list */
277 Cell mod; /* Name of module */
278 List entities; { /* List of entity names */
279 unqualImports = cons(pair(mod,entities),unqualImports);
282 static Void local checkQualImport(i) /* Process qualified import */
284 Module m = findModid(snd(i));
286 ERRMSG(0) "Module \"%s\" not previously loaded",
287 textToStr(textOf(snd(i)))
293 static Void local checkUnqualImport(i) /* Process unqualified import */
295 Module m = findModid(fst(i));
297 ERRMSG(0) "Module \"%s\" not previously loaded",
298 textToStr(textOf(fst(i)))
304 static Name local lookupName(t,nms) /* find text t in list of Names */
306 List nms; { /* :: [Name] */
307 for(; nonNull(nms); nms=tl(nms)) {
308 if (t == name(hd(nms)).text)
314 static List local checkSubentities(imports,named,wanted,description,textParent)
316 List named; /* :: [ Q?(Var|Con)(Id|Op) ] */
317 List wanted; /* :: [Name] */
318 String description; /* "<constructor>|<member> of <type>|<class>" */
320 for(; nonNull(named); named=tl(named)) {
322 /* ToDo: ignores qualifier; doesn't check that entity is in scope */
323 Text t = isPair(snd(x)) ? qtextOf(x) : textOf(x);
324 Name n = lookupName(t,wanted);
326 ERRMSG(0) "Entity \"%s\" is not a %s \"%s\"",
329 textToStr(textParent)
332 imports = cons(n,imports);
337 static List local checkImportEntity(imports,exporter,priv,entity)
338 List imports; /* Accumulated list of things to import */
341 Cell entity; { /* Entry from import list */
342 List oldImports = imports;
343 Text t = isIdent(entity) ? textOf(entity) : textOf(fst(entity));
346 es = module(exporter).names;
347 es = dupOnto(module(exporter).tycons,es);
348 es = dupOnto(module(exporter).classes,es);
350 es = module(exporter).exports;
353 for(; nonNull(es); es=tl(es)) {
354 Cell e = hd(es); /* :: Entity
355 | (Entity, NIL|DOTDOT)
362 if (tycon(f).text == t) {
363 imports = cons(f,imports);
364 if (!isIdent(entity)) {
365 switch (tycon(f).what) {
368 if (DOTDOT == snd(entity)) {
369 imports = dupOnto(tycon(f).defn,imports);
371 imports = checkSubentities(
372 imports,snd(entity),tycon(f).defn,
373 "constructor of type",t);
377 /* deliberate fall thru */
381 } else if (isClass(f)) {
382 if (cclass(f).text == t) {
383 imports = cons(f,imports);
384 if (!isIdent(entity)) {
385 if (DOTDOT == snd(entity)) {
386 return dupOnto(cclass(f).members,imports);
388 return checkSubentities(
389 imports,snd(entity),cclass(f).members,
390 "member of class",t);
395 internal("checkImportEntity2");
397 } else if (isName(e)) {
398 if (isIdent(entity) && name(e).text == t) {
399 imports = cons(e,imports);
401 } else if (isTycon(e) && priv) {
402 if (tycon(e).text == t) {
403 imports = cons(e,imports);
404 return dupOnto(tycon(e).defn,imports);
406 } else if (isClass(e) && priv) {
407 if (cclass(e).text == t) {
408 imports = cons(e,imports);
409 return dupOnto(cclass(e).members,imports);
411 } else if (whatIs(e) == TUPLE && priv) {
414 internal("checkImportEntity3");
417 if (imports == oldImports) {
418 ERRMSG(0) "Unknown entity \"%s\" imported from module \"%s\"",
420 textToStr(module(exporter ).text)
426 static List local resolveImportList(m,impList,priv)
427 Module m; /* exporting module */
431 if (DOTDOT == impList) {
432 List es = module(m).exports;
433 for(; nonNull(es); es=tl(es)) {
436 imports = cons(e,imports);
439 List subentities = NIL;
440 imports = cons(c,imports);
442 && (tycon(c).what == DATATYPE
443 || tycon(c).what == NEWTYPE))
444 subentities = tycon(c).defn;
446 subentities = cclass(c).members;
447 if (DOTDOT == snd(e)) {
448 imports = dupOnto(subentities,imports);
453 map2Accum(checkImportEntity,imports,m,priv,impList);
458 static Void local checkImportList(importSpec) /*Import a module unqualified*/
460 Module m = fst(importSpec);
461 Cell impList = snd(importSpec);
463 List imports = NIL; /* entities we want to import */
464 List hidden = NIL; /* entities we want to hide */
466 if (isPair(impList) && HIDDEN == fst(impList)) {
467 /* Somewhat inefficient - but obviously correct:
468 * imports = importsOf("module Foo") `setDifference` hidden;
470 hidden = resolveImportList(m, snd(impList),FALSE);
471 imports = resolveImportList(m, DOTDOT,FALSE);
472 } else if (isPair(impList) && STAR == fst(impList)) {
473 // Previously, I was forcing an import Prelude,
474 // but this precluded doing things like
475 // import Prelude hiding ( catch)
476 // so, for now, you need to put an explicit
477 // import Prelude if you use import privileged.
478 imports = resolveImportList(m, snd(impList),TRUE);
480 imports = resolveImportList(m, impList,FALSE);
483 for(; nonNull(imports); imports=tl(imports)) {
484 Cell e = hd(imports);
485 if (!cellIsMember(e,hidden))
488 /* ToDo: hang onto the imports list for processing export list entries
489 * of the form "module Foo"
493 static Void local importEntity(source,e)
497 case NAME : importName(source,e);
500 case TYCON : importTycon(source,e);
502 case CLASS : importClass(source,e);
504 default: internal("importEntity");
508 static Void local importName(source,n)
511 Name clash = addName(n);
512 if (nonNull(clash) && clash!=n) {
513 ERRMSG(0) "Entity \"%s\" imported from module \"%s\""
514 " already defined in module \"%s\"",
515 textToStr(name(n).text),
516 textToStr(module(source).text),
517 textToStr(module(name(clash).mod).text)
522 static Void local importTycon(source,tc)
525 Tycon clash=addTycon(tc);
526 if (nonNull(clash) && clash!=tc) {
527 ERRMSG(0) "Tycon \"%s\" imported from \"%s\" already defined in module \"%s\"",
528 textToStr(tycon(tc).text),
529 textToStr(module(source).text),
530 textToStr(module(tycon(clash).mod).text)
533 if (nonNull(findClass(tycon(tc).text))) {
534 ERRMSG(0) "Import of type constructor \"%s\" clashes with class in module \"%s\"",
535 textToStr(tycon(tc).text),
536 textToStr(module(tycon(tc).mod).text)
541 static Void local importClass(source,c)
544 Class clash=addClass(c);
545 if (nonNull(clash) && clash!=c) {
546 ERRMSG(0) "Class \"%s\" imported from \"%s\" already defined in module \"%s\"",
547 textToStr(cclass(c).text),
548 textToStr(module(source).text),
549 textToStr(module(cclass(clash).mod).text)
552 if (nonNull(findTycon(cclass(c).text))) {
553 ERRMSG(0) "Import of class \"%s\" clashes with type constructor in module \"%s\"",
554 textToStr(cclass(c).text),
555 textToStr(module(source).text)
560 static List local checkExportTycon(exports,mt,spec,tc)
565 if (DOTDOT == spec || SYNONYM == tycon(tc).what) {
566 return cons(pair(tc,DOTDOT), exports);
568 return cons(pair(tc,NIL), exports);
572 static List local checkExportClass(exports,mt,spec,cl)
577 if (DOTDOT == spec) {
578 return cons(pair(cl,DOTDOT), exports);
580 return cons(pair(cl,NIL), exports);
584 static List local checkExport(exports,mt,e) /* Process entry in export list*/
590 List origExports = exports;
591 if (nonNull(export=findQualName(e))) {
592 exports=cons(export,exports);
594 if (isQCon(e) && nonNull(export=findQualTycon(e))) {
595 exports = checkExportTycon(exports,mt,NIL,export);
597 if (isQCon(e) && nonNull(export=findQualClass(e))) {
598 /* opaque class export */
599 exports = checkExportClass(exports,mt,NIL,export);
601 if (exports == origExports) {
602 ERRMSG(0) "Unknown entity \"%s\" exported from module \"%s\"",
608 } else if (MODULEENT == fst(e)) {
609 Module m = findModid(snd(e));
610 /* ToDo: shouldn't allow export of module we didn't import */
612 ERRMSG(0) "Unknown module \"%s\" exported from module \"%s\"",
613 textToStr(textOf(snd(e))),
617 if (m == currentModule) {
618 /* Exporting the current module exports local definitions */
620 for(xs=module(m).classes; nonNull(xs); xs=tl(xs)) {
621 if (cclass(hd(xs)).mod==m)
622 exports = checkExportClass(exports,mt,DOTDOT,hd(xs));
624 for(xs=module(m).tycons; nonNull(xs); xs=tl(xs)) {
625 if (tycon(hd(xs)).mod==m)
626 exports = checkExportTycon(exports,mt,DOTDOT,hd(xs));
628 for(xs=module(m).names; nonNull(xs); xs=tl(xs)) {
629 if (name(hd(xs)).mod==m)
630 exports = cons(hd(xs),exports);
633 /* Exporting other modules imports all things imported
634 * unqualified from it.
635 * ToDo: we reexport everything exported by a module -
636 * whether we imported it or not. This gives the wrong
637 * result for "module M(module N) where import N(x)"
639 exports = dupOnto(module(m).exports,exports);
643 Cell ident = fst(e); /* class name or type name */
644 Cell parts = snd(e); /* members or constructors */
646 if (isQCon(ident) && nonNull(nm=findQualTycon(ident))) {
647 switch (tycon(nm).what) {
650 ERRMSG(0) "Explicit constructor list given for type synonym"
651 " \"%s\" in export list of module \"%s\"",
656 return cons(pair(nm,DOTDOT),exports);
658 ERRMSG(0) "Transparent export of restricted type synonym"
659 " \"%s\" in export list of module \"%s\"",
663 return exports; /* Not reached */
667 return cons(pair(nm,DOTDOT),exports);
669 exports = checkSubentities(exports,parts,tycon(nm).defn,
670 "constructor of type",
672 return cons(pair(nm,DOTDOT), exports);
675 internal("checkExport1");
677 } else if (isQCon(ident) && nonNull(nm=findQualClass(ident))) {
678 if (DOTDOT == parts) {
679 return cons(pair(nm,DOTDOT),exports);
681 exports = checkSubentities(exports,parts,cclass(nm).members,
682 "member of class",cclass(nm).text);
683 return cons(pair(nm,DOTDOT), exports);
686 ERRMSG(0) "Explicit export list given for non-class/datatype \"%s\" in export list of module \"%s\"",
692 return exports; /* NOTUSED */
695 static List local checkExports ( List exports, Module thisModule )
697 Module m = thisModule;
698 Text mt = module(m).text;
701 map1Accum(checkExport,es,mt,exports);
704 for(xs=es; nonNull(xs); xs=tl(xs)) {
705 Printf(" %s", textToStr(textOfEntity(hd(xs))));
712 /* --------------------------------------------------------------------------
713 * Static analysis of type declarations:
715 * Type declarations come in two forms:
716 * - data declarations - define new constructed data types
717 * - type declarations - define new type synonyms
719 * A certain amount of work is carried out as the declarations are
720 * read during parsing. In particular, for each type constructor
721 * definition encountered:
722 * - check that there is no previous definition of constructor
723 * - ensure type constructor not previously used as a class name
724 * - make a new entry in the type constructor table
725 * - record line number of declaration
726 * - Build separate lists of newly defined constructors for later use.
727 * ------------------------------------------------------------------------*/
729 Void tyconDefn(line,lhs,rhs,what) /* process new type definition */
730 Int line; /* definition line number */
731 Cell lhs; /* left hand side of definition */
732 Cell rhs; /* right hand side of definition */
733 Cell what; { /* SYNONYM/DATATYPE/etc... */
734 Text t = textOf(getHead(lhs));
736 if (nonNull(findTycon(t))) {
737 ERRMSG(line) "Repeated definition of type constructor \"%s\"",
741 else if (nonNull(findClass(t))) {
742 ERRMSG(line) "\"%s\" used as both class and type constructor",
747 Tycon nw = newTycon(t);
748 tyconDefns = cons(nw,tyconDefns);
749 tycon(nw).line = line;
750 tycon(nw).arity = argCount;
751 tycon(nw).what = what;
752 if (what==RESTRICTSYN) {
753 h98DoesntSupport(line,"restricted type synonyms");
754 typeInDefns = cons(pair(nw,snd(rhs)),typeInDefns);
757 tycon(nw).defn = pair(lhs,rhs);
761 Void setTypeIns(bs) /* set local synonyms for given */
762 List bs; { /* binding group */
763 List cvs = typeInDefns;
764 for (; nonNull(cvs); cvs=tl(cvs)) {
765 Tycon c = fst(hd(cvs));
766 List vs = snd(hd(cvs));
767 for (tycon(c).what = RESTRICTSYN; nonNull(vs); vs=tl(vs)) {
768 if (nonNull(findBinding(textOf(hd(vs)),bs))) {
769 tycon(c).what = SYNONYM;
776 Void clearTypeIns() { /* clear list of local synonyms */
777 for (; nonNull(typeInDefns); typeInDefns=tl(typeInDefns))
778 tycon(fst(hd(typeInDefns))).what = RESTRICTSYN;
781 /* --------------------------------------------------------------------------
782 * Further analysis of Type declarations:
784 * In order to allow the definition of mutually recursive families of
785 * data types, the static analysis of the right hand sides of type
786 * declarations cannot be performed until all of the type declarations
789 * Once parsing is complete, we carry out the following:
791 * - check format of lhs, extracting list of bound vars and ensuring that
792 * there are no repeated variables and no Skolem variables.
793 * - run dependency analysis on rhs to check that only bound type vars
794 * appear in type and that all constructors are defined.
795 * Replace type variables by offsets, constructors by Tycons.
796 * - use list of dependents to sort into strongly connected components.
797 * - ensure that there is not more than one synonym in each group.
798 * - kind-check each group of type definitions.
800 * - check that there are no previous definitions for constructor
801 * functions in data type definitions.
802 * - install synonym expansions and constructor definitions.
803 * ------------------------------------------------------------------------*/
805 static List tcDeps = NIL; /* list of dependent tycons/classes*/
807 static Void local checkTyconDefn(d) /* validate type constructor defn */
809 Cell lhs = fst(tycon(d).defn);
810 Cell rhs = snd(tycon(d).defn);
811 Int line = tycon(d).line;
812 List tyvars = getArgs(lhs);
814 /* check for repeated tyvars on lhs*/
815 for (temp=tyvars; nonNull(temp); temp=tl(temp))
816 if (nonNull(varIsMember(textOf(hd(temp)),tl(temp)))) {
817 ERRMSG(line) "Repeated type variable \"%s\" on left hand side",
818 textToStr(textOf(hd(temp)))
822 tcDeps = NIL; /* find dependents */
823 switch (whatIs(tycon(d).what)) {
825 case SYNONYM : rhs = depTypeExp(line,tyvars,rhs);
826 if (cellIsMember(d,tcDeps)) {
827 ERRMSG(line) "Recursive type synonym \"%s\"",
828 textToStr(tycon(d).text)
834 case NEWTYPE : depConstrs(d,tyvars,rhs);
838 default : internal("checkTyconDefn");
843 tycon(d).kind = tcDeps;
847 static Void local depConstrs(t,tyvars,cd)
848 Tycon t; /* Define constructor functions and*/
849 List tyvars; /* do dependency analysis for data */
850 Cell cd; { /* definitions (w or w/o deriving) */
851 Int line = tycon(t).line;
856 List derivs = snd(cd);
857 List compTypes = NIL;
861 for (i=0; i<tycon(t).arity; ++i) /* build representation for tycon */
862 lhs = ap(lhs,mkOffset(i)); /* applied to full comp. of args */
864 if (isQualType(cs)) { /* allow for possible context */
867 map2Over(depPredExp,line,tyvars,ctxt);
868 h98CheckCtxt(line,"context",TRUE,ctxt,NIL);
871 if (nonNull(cs) && isNull(tl(cs))) /* Single constructor datatype? */
874 for (; nonNull(cs); cs=tl(cs)) { /* For each constructor function: */
876 List sig = dupList(tyvars);
877 List evs = NIL; /* locally quantified vars */
878 List lps = NIL; /* locally bound predicates */
879 List ctxt1 = ctxt; /* constructor function context */
880 List scs = NIL; /* strict components */
881 List fs = NONE; /* selector names */
882 Type type = lhs; /* constructor function type */
883 Int arity = 0; /* arity of constructor function */
884 Int nr2 = 0; /* Number of rank 2 args */
885 Name n; /* name for constructor function */
887 if (whatIs(con)==POLYTYPE) { /* Locally quantified vars */
890 sig = checkQuantVars(line,evs,sig,con);
893 if (isQualType(con)) { /* Local predicates */
896 for (us = typeVarsIn(lps,NIL,NIL,NIL); nonNull(us); us=tl(us))
897 if (!varIsMember(textOf(hd(us)),evs)) {
899 "Variable \"%s\" in constraint is not locally bound",
900 textToStr(textOf(hd(us)))
903 map2Over(depPredExp,line,sig,lps);
908 if (whatIs(con)==LABC) { /* Skeletize constr components */
909 Cell fls = snd(snd(con)); /* get field specifications */
912 for (; nonNull(fls); fls=tl(fls)) { /* for each field spec: */
913 List vs = fst(hd(fls));
914 Type t = snd(hd(fls)); /* - scrutinize type */
915 Bool banged = whatIs(t)==BANG;
916 t = depCompType(line,sig,(banged ? arg(t) : t));
917 while (nonNull(vs)) { /* - add named components */
925 scs = cons(mkInt(arity),scs);
929 scs = rev(scs); /* put strict comps in ascend ord */
931 else { /* Non-labelled constructor */
934 for (; isAp(c); c=fun(c))
936 for (compNo=arity, c=con; isAp(c); c=fun(c)) {
938 if (whatIs(t)==BANG) {
939 scs = cons(mkInt(compNo),scs);
943 arg(c) = depCompType(line,sig,t);
947 if (nonNull(ctxt1)) /* Extract relevant part of context*/
948 ctxt1 = selectCtxt(ctxt1,offsetTyvarsIn(con,NIL));
950 for (i=arity; isAp(con); i--) { /* Calculate type of constructor */
953 fun(con) = typeArrow;
954 if (isPolyOrQualType(cmp)) {
955 if (nonNull(derivs)) {
956 ERRMSG(line) "Cannot derive instances for types" ETHEN
957 ERRTEXT " with polymorphic or qualified components"
963 if (nonNull(derivs)) /* and build list of components */
964 compTypes = cons(cmp,compTypes);
969 if (nr2>0) { /* Add rank 2 annotation */
970 type = ap(RANK2,pair(mkInt(nr2-length(lps)),type));
973 if (nonNull(evs)) { /* Add existential annotation */
974 if (nonNull(derivs)) {
975 ERRMSG(line) "Cannot derive instances for types" ETHEN
976 ERRTEXT " with existentially typed components"
981 "Cannot use selectors with existentially typed components"
984 type = ap(EXIST,pair(mkInt(length(evs)),type));
987 if (nonNull(lps)) { /* Add local preds part to type */
988 type = ap(CDICTS,pair(lps,type));
991 if (nonNull(ctxt1)) { /* Add context part to type */
992 type = ap(QUAL,pair(ctxt1,type));
995 if (nonNull(sig)) { /* Add quantifiers to type */
997 for (; nonNull(ts1); ts1=tl(ts1)) {
1000 type = mkPolyType(sig,type);
1003 n = findName(textOf(con)); /* Allocate constructor fun name */
1005 n = newName(textOf(con),NIL);
1006 } else if (name(n).defn!=PREDEFINED) {
1007 duplicateError(line,name(n).mod,name(n).text,
1008 "constructor function");
1010 name(n).arity = arity; /* Save constructor fun details */
1011 name(n).line = line;
1013 name(n).number = cfunNo(conNo++);
1014 name(n).type = type;
1015 if (tycon(t).what==NEWTYPE) {
1018 "A newtype constructor cannot have class constraints"
1023 "A newtype constructor must have exactly one argument"
1028 "Illegal strictess annotation for newtype constructor"
1031 name(n).defn = nameId;
1033 implementCfun(n,scs);
1034 name(n).hasStrict = nonNull(scs);
1039 sels = addSels(line,n,fs,sels);
1043 if (nonNull(sels)) {
1045 fst(cd) = appendOnto(fst(cd),sels);
1046 selDefns = cons(sels,selDefns);
1049 if (nonNull(derivs)) { /* Generate derived instances */
1050 map3Proc(checkDerive,t,ctxt,compTypes,derivs);
1054 Int userArity(c) /* Find arity for cfun, ignoring */
1055 Name c; { /* CDICTS parameters */
1056 Int a = name(c).arity;
1057 Type t = name(c).type;
1059 if (isPolyType(t)) {
1062 if ((w=whatIs(t))==QUAL) {
1063 w = whatIs(t=snd(snd(t)));
1066 a -= length(fst(snd(t)));
1072 static List local addSels(line,c,fs,ss) /* Add fields to selector list */
1073 Int line; /* line number of constructor */
1074 Name c; /* corresponding constr function */
1075 List fs; /* list of fields (varids) */
1076 List ss; { /* list of existing selectors */
1078 cfunSfuns = cons(pair(c,fs),cfunSfuns);
1079 for (; nonNull(fs); fs=tl(fs), ++sn) {
1081 Text t = textOf(hd(fs));
1083 if (nonNull(varIsMember(t,tl(fs)))) {
1084 ERRMSG(line) "Repeated field name \"%s\" for constructor \"%s\"",
1085 textToStr(t), textToStr(name(c).text)
1089 while (nonNull(ns) && t!=name(hd(ns)).text) {
1094 name(hd(ns)).defn = cons(pair(c,mkInt(sn)),name(hd(ns)).defn);
1096 Name n = findName(t);
1098 ERRMSG(line) "Repeated definition for selector \"%s\"",
1103 name(n).line = line;
1104 name(n).number = SELNAME;
1105 name(n).defn = singleton(pair(c,mkInt(sn)));
1112 static List local selectCtxt(ctxt,vs) /* calculate subset of context */
1119 for (; nonNull(ctxt); ctxt=tl(ctxt)) {
1120 List us = offsetTyvarsIn(hd(ctxt),NIL);
1121 for (; nonNull(us) && cellIsMember(hd(us),vs); us=tl(us)) {
1124 ps = cons(hd(ctxt),ps);
1131 static Void local checkSynonyms(ts) /* Check for mutually recursive */
1132 List ts; { /* synonyms */
1134 for (; nonNull(ts); ts=tl(ts)) { /* build list of all synonyms */
1136 switch (whatIs(tycon(t).what)) {
1138 case RESTRICTSYN : syns = cons(t,syns);
1142 while (nonNull(syns)) { /* then visit each synonym */
1143 syns = visitSyn(NIL,hd(syns),syns);
1147 static List local visitSyn(path,t,syns) /* visit synonym definition to look*/
1148 List path; /* for cycles */
1151 if (cellIsMember(t,path)) { /* every elt in path depends on t */
1152 ERRMSG(tycon(t).line)
1153 "Type synonyms \"%s\" and \"%s\" are mutually recursive",
1154 textToStr(tycon(t).text), textToStr(tycon(hd(path)).text)
1157 List ds = tycon(t).kind;
1159 for (; nonNull(ds); ds=tl(ds)) {
1160 if (cellIsMember(hd(ds),syns)) {
1161 if (isNull(path1)) {
1162 path1 = cons(t,path);
1164 syns = visitSyn(path1,hd(ds),syns);
1168 tycon(t).defn = fullExpand(tycon(t).defn);
1169 return removeCell(t,syns);
1172 /* --------------------------------------------------------------------------
1173 * Expanding out all type synonyms in a type expression:
1174 * ------------------------------------------------------------------------*/
1176 Type fullExpand(t) /* find full expansion of type exp */
1177 Type t; { /* assuming that all relevant */
1178 Cell h = t; /* synonym defns of lower rank have*/
1179 Int n = 0; /* already been fully expanded */
1181 for (args=NIL; isAp(h); h=fun(h), n++) {
1182 args = cons(fullExpand(arg(h)),args);
1184 t = applyToArgs(h,args);
1185 if (isSynonym(h) && n>=tycon(h).arity) {
1186 if (n==tycon(h).arity) {
1187 t = instantiateSyn(tycon(h).defn,t);
1190 while (--n > tycon(h).arity) {
1193 fun(p) = instantiateSyn(tycon(h).defn,fun(p));
1199 static Type local instantiateSyn(t,env) /* instantiate type according using*/
1200 Type t; /* env to determine appropriate */
1201 Type env; { /* values for OFFSET type vars */
1202 switch (whatIs(t)) {
1203 case AP : return ap(instantiateSyn(fun(t),env),
1204 instantiateSyn(arg(t),env));
1206 case OFFSET : return nthArg(offsetOf(t),env);
1212 /* --------------------------------------------------------------------------
1213 * Static analysis of class declarations:
1215 * Performed in a similar manner to that used for type declarations.
1217 * The first part of the static analysis is performed as the declarations
1218 * are read during parsing. The parser ensures that:
1219 * - the class header and all superclass predicates are of the form
1222 * The classDefn() function:
1223 * - ensures that there is no previous definition for class
1224 * - checks that class name has not previously been used as a type constr.
1225 * - make new entry in class table
1226 * - record line number of declaration
1227 * - build list of classes defined in current script for use in later
1228 * stages of static analysis.
1229 * ------------------------------------------------------------------------*/
1231 Void classDefn(line,head,ms,fds) /* process new class definition */
1232 Int line; /* definition line number */
1233 Cell head; /* class header :: ([Supers],Class) */
1234 List ms; /* class definition body */
1235 List fds; { /* functional dependencies */
1236 Text ct = textOf(getHead(snd(head)));
1237 Int arity = argCount;
1239 if (nonNull(findClass(ct))) {
1240 ERRMSG(line) "Repeated definition of class \"%s\"",
1243 } else if (nonNull(findTycon(ct))) {
1244 ERRMSG(line) "\"%s\" used as both class and type constructor",
1248 Class nw = newClass(ct);
1249 cclass(nw).line = line;
1250 cclass(nw).arity = arity;
1251 cclass(nw).head = snd(head);
1252 cclass(nw).supers = fst(head);
1253 cclass(nw).members = ms;
1254 cclass(nw).level = 0;
1255 cclass(nw).fds = fds;
1256 cclass(nw).xfds = NIL;
1257 classDefns = cons(nw,classDefns);
1259 h98DoesntSupport(line,"multiple parameter classes");
1263 /* --------------------------------------------------------------------------
1264 * Further analysis of class declarations:
1266 * Full static analysis of class definitions must be postponed until the
1267 * complete script has been read and all static analysis on type definitions
1268 * has been completed.
1270 * Once this has been achieved, we carry out the following checks on each
1272 * - check that variables in header are distinct
1273 * - replace head by skeleton
1274 * - check superclass declarations, replace by skeletons
1275 * - split body of class into members and declarations
1276 * - make new name entry for each member function
1277 * - record member function number (eventually an offset into dictionary!)
1278 * - no member function has a previous definition ...
1279 * - no member function is mentioned more than once in the list of members
1280 * - each member function type is valid, replace vars by offsets
1281 * - qualify each member function type by class header
1282 * - only bindings for members appear in defaults
1283 * - only function bindings appear in defaults
1284 * - check that extended class hierarchy does not contain any cycles
1285 * ------------------------------------------------------------------------*/
1287 static Void local checkClassDefn(c) /* validate class definition */
1290 Int args = cclass(c).arity - 1;
1291 Cell temp = cclass(c).head;
1295 for (; isAp(temp); temp=fun(temp)) {
1296 if (!isVar(arg(temp))) {
1297 ERRMSG(cclass(c).line) "Type variable required in class head"
1300 if (nonNull(varIsMember(textOf(arg(temp)),tyvars))) {
1301 ERRMSG(cclass(c).line)
1302 "Repeated type variable \"%s\" in class head",
1303 textToStr(textOf(arg(temp)))
1306 tyvars = cons(arg(temp),tyvars);
1309 for (fs=cclass(c).fds; nonNull(fs); fs=tl(fs)) {
1313 /* Check for trivial dependency
1316 ERRMSG(cclass(c).line) "Functional dependency is trivial"
1320 /* Check for duplicated vars on right hand side, and for vars on
1321 * right that also appear on the left:
1323 for (vs=snd(fd); nonNull(vs); vs=tl(vs)) {
1324 if (varIsMember(textOf(hd(vs)),fst(fd))) {
1325 ERRMSG(cclass(c).line)
1326 "Trivial dependency for variable \"%s\"",
1327 textToStr(textOf(hd(vs)))
1330 if (varIsMember(textOf(hd(vs)),tl(vs))) {
1331 ERRMSG(cclass(c).line)
1332 "Repeated variable \"%s\" in functional dependency",
1333 textToStr(textOf(hd(vs)))
1336 hd(vs) = depTypeVar(cclass(c).line,tyvars,textOf(hd(vs)));
1339 /* Check for duplicated vars on left hand side:
1341 for (vs=fst(fd); nonNull(vs); vs=tl(vs)) {
1342 if (varIsMember(textOf(hd(vs)),tl(vs))) {
1343 ERRMSG(cclass(c).line)
1344 "Repeated variable \"%s\" in functional dependency",
1345 textToStr(textOf(hd(vs)))
1348 hd(vs) = depTypeVar(cclass(c).line,tyvars,textOf(hd(vs)));
1352 if (cclass(c).arity==0) {
1355 Int args = cclass(c).arity - 1;
1356 for (temp=cclass(c).head; args>0; temp=fun(temp), args--) {
1357 arg(temp) = mkOffset(args);
1359 arg(temp) = mkOffset(0);
1363 tcDeps = NIL; /* find dependents */
1364 map2Over(depPredExp,cclass(c).line,tyvars,cclass(c).supers);
1365 h98CheckCtxt(cclass(c).line,"class definition",FALSE,cclass(c).supers,NIL);
1366 cclass(c).numSupers = length(cclass(c).supers);
1367 cclass(c).defaults = extractBindings(cclass(c).members); /* defaults*/
1368 ss = extractSigdecls(cclass(c).members);
1369 fs = extractFixdecls(cclass(c).members);
1370 cclass(c).members = pair(ss,fs);
1371 map2Proc(checkMems,c,tyvars,ss);
1373 cclass(c).kinds = tcDeps;
1378 /* --------------------------------------------------------------------------
1379 * Functional dependencies are inherited from superclasses.
1380 * For example, if I've got the following classes:
1382 * class C a b | a -> b
1383 * class C [b] a => D a b
1385 * then C will have the dependency ([a], [b]) as expected, and D will inherit
1386 * the dependency ([b], [a]) from C.
1387 * When doing pairwise improvement, we have to consider not just improving
1388 * when we see a pair of Cs or a pair of Ds in the context, but when we've
1389 * got a C and a D as well. In this case, we only improve when the
1390 * predicate in question matches the type skeleton in the relevant superclass
1391 * constraint. E.g., we improve the pair (C [Int] a, D b Int) (unifying
1392 * a and b), but we don't improve the pair (C Int a, D b Int).
1393 * To implement functional dependency inheritance, we calculate
1394 * the closure of all functional dependencies, and store the result
1395 * in an additional field `xfds' (extended functional dependencies).
1396 * The `xfds' field is a list of functional dependency lists, annotated
1397 * with a list of predicate skeletons constraining when improvement can
1398 * happen against this dependency list. For example, the xfds field
1399 * for C above would be:
1400 * [([C a b], [([a], [b])])]
1401 * and the xfds field for D would be:
1402 * [([C [b] a, D a b], [([b], [a])])]
1403 * Self-improvement (of a C with a C, or a D with a D) is treated as a
1404 * special case of an inherited dependency.
1405 * ------------------------------------------------------------------------*/
1406 static List local inheritFundeps ( Class c, Cell pi, Int o )
1408 Int alpha = newKindedVars(cclass(c).kinds);
1409 List scs = cclass(c).supers;
1412 /* better not fail ;-) */
1413 if (!matchPred(pi,o,cclass(c).head,alpha))
1414 internal("inheritFundeps - predicate failed to match it's own head!");
1415 this = copyPred(pi,o);
1416 for (; nonNull(scs); scs=tl(scs)) {
1417 Class s = getHead(hd(scs));
1419 List sfds = inheritFundeps(s,hd(scs),alpha);
1420 for (; nonNull(sfds); sfds=tl(sfds)) {
1422 xfds = cons(pair(cons(this,fst(h)),snd(h)),xfds);
1426 if (nonNull(cclass(c).fds)) {
1427 List fds = NIL, fs = cclass(c).fds;
1428 for (; nonNull(fs); fs=tl(fs)) {
1429 fds = cons(pair(otvars(this,fst(hd(fs))),
1430 otvars(this,snd(hd(fs)))),fds);
1432 xfds = cons(pair(cons(this,NIL),fds),xfds);
1437 static Void local extendFundeps ( Class c )
1440 emptySubstitution();
1441 alpha = newKindedVars(cclass(c).kinds);
1442 cclass(c).xfds = inheritFundeps(c,cclass(c).head,alpha);
1444 /* we can now check for ambiguity */
1445 map1Proc(checkMems2,c,fst(cclass(c).members));
1449 static Cell local depPredExp(line,tyvars,pred)
1456 for (; isAp(h); args++) {
1457 arg(h) = depTypeExp(line,tyvars,arg(h));
1463 h98DoesntSupport(line,"tag classes");
1464 } else if (args!=1) {
1465 h98DoesntSupport(line,"multiple parameter classes");
1468 if (isQCon(h)) { /* standard class constraint */
1469 Class c = findQualClass(h);
1471 ERRMSG(line) "Undefined class \"%s\"", identToStr(h)
1479 if (args!=cclass(c).arity) {
1480 ERRMSG(line) "Wrong number of arguments for class \"%s\"",
1481 textToStr(cclass(c).text)
1484 if (cellIsMember(c,classDefns) && !cellIsMember(c,tcDeps)) {
1485 tcDeps = cons(c,tcDeps);
1489 else if (isExt(h)) { /* Lacks predicate */
1490 if (args!=1) { /* parser shouldn't let this happen*/
1491 ERRMSG(line) "Wrong number of arguments for lacks predicate"
1498 if (whatIs(h) != IPCELL)
1501 internal("depPredExp");
1506 static Void local checkMems(c,tyvars,m) /* check member function details */
1510 Int line = intOf(fst3(m));
1517 if (isPolyType(t)) {
1523 tyvars = typeVarsIn(t,NIL,xtvs,tyvars);
1524 /* Look for extra type vars. */
1525 checkOptQuantVars(line,xtvs,tyvars);
1527 if (isQualType(t)) { /* Overloaded member signatures? */
1528 map2Over(depPredExp,line,tyvars,fst(snd(t)));
1530 t = ap(QUAL,pair(NIL,t));
1533 fst(snd(t)) = cons(cclass(c).head,fst(snd(t)));/* Add main predicate */
1534 snd(snd(t)) = depTopType(line,tyvars,snd(snd(t)));
1536 for (tvs=tyvars; nonNull(tvs); tvs=tl(tvs)){/* Quantify */
1540 t = mkPolyType(sig,t);
1542 thd3(m) = t; /* Save type */
1543 take(cclass(c).arity,tyvars); /* Delete extra type vars */
1545 if (isAmbiguous(t)) {
1546 ambigError(line,"class declaration",hd(vs),t);
1548 h98CheckType(line,"member type",hd(vs),t);
1551 static Void local checkMems2(c,m) /* check member function details */
1554 Int line = intOf(fst3(m));
1559 static Void local addMembers(c) /* Add definitions of member funs */
1560 Class c; { /* and other parts of class struct.*/
1561 List ms = fst(cclass(c).members);
1562 List fs = snd(cclass(c).members);
1563 List ns = NIL; /* List of names */
1564 Int mno; /* Member function number */
1566 for (mno=0; mno<cclass(c).numSupers; mno++) {
1567 ns = cons(newDSel(c,mno),ns);
1569 cclass(c).dsels = rev(ns); /* Save dictionary selectors */
1571 for (mno=1, ns=NIL; nonNull(ms); ms=tl(ms)) {
1572 Int line = intOf(fst3(hd(ms)));
1573 List vs = rev(snd3(hd(ms)));
1574 Type t = thd3(hd(ms));
1575 for (; nonNull(vs); vs=tl(vs)) {
1576 ns = cons(newMember(line,mno++,hd(vs),t,c),ns);
1579 cclass(c).members = rev(ns); /* Save list of members */
1580 cclass(c).numMembers = length(cclass(c).members);
1582 for (; nonNull(fs); fs=tl(fs)) { /* fixity declarations */
1583 Int line = intOf(fst3(hd(fs)));
1584 List ops = snd3(hd(fs));
1585 Syntax s = intOf(thd3(hd(fs)));
1586 for (; nonNull(ops); ops=tl(ops)) {
1587 Name n = nameIsMember(textOf(hd(ops)),cclass(c).members);
1589 missFixity(line,textOf(hd(ops)));
1590 } else if (name(n).syntax!=NO_SYNTAX) {
1591 dupFixity(line,textOf(hd(ops)));
1597 /* Not actually needed just yet; for the time being, dictionary code will
1598 not be passed through the type checker.
1600 cclass(c).dtycon = addPrimTycon(generateText("Dict.%s",c),
1607 mno = cclass(c).numSupers + cclass(c).numMembers;
1608 /* cclass(c).dcon = addPrimCfun(generateText("Make.%s",c),mno,0,NIL); */
1609 cclass(c).dcon = addPrimCfun(generateText(":D%s",c),mno,0,NIL);
1610 /* implementCfun(cclass(c).dcon,NIL);
1611 Don't manufacture a wrapper fn for dictionary constructors.
1612 Applications of dictionary constructors are always saturated,
1613 and translate.c:stgExpr() special-cases saturated constructor apps.
1616 if (mno==1) { /* Single entry dicts use newtype */
1617 name(cclass(c).dcon).defn = nameId;
1618 if (nonNull(cclass(c).members)) {
1619 name(hd(cclass(c).members)).number = mfunNo(0);
1622 cclass(c).defaults = classBindings("class",c,cclass(c).defaults);
1625 static Name local newMember(l,no,v,t,parent)
1626 Int l; /* Make definition for member fn */
1631 Name m = findName(textOf(v));
1634 m = newName(textOf(v),parent);
1635 } else if (name(m).defn!=PREDEFINED) {
1636 ERRMSG(l) "Repeated definition for member function \"%s\"",
1637 textToStr(name(m).text)
1643 name(m).number = mfunNo(no);
1648 Name newDSel(c,no) /* Make definition for dict selectr*/
1654 /* sprintf(buf,"sc%d.%s",no,"%s"); */
1655 sprintf(buf,"$p%d%s",no+1,"%s");
1656 s = newName(generateText(buf,c),c);
1657 name(s).line = cclass(c).line;
1659 name(s).number = DFUNNAME;
1665 static Text local generateText(sk,c) /* We need to generate names for */
1666 String sk; /* certain objects corresponding */
1667 Class c; { /* to each class. */
1668 String cname = textToStr(cclass(c).text);
1669 char buffer[MAX_GEN+1];
1671 if ((strlen(sk)+strlen(cname))>=MAX_GEN) {
1672 ERRMSG(0) "Please use a shorter name for class \"%s\"", cname
1675 sprintf(buffer,sk,cname);
1676 return findText(buffer);
1679 Int visitClass(c) /* visit class defn to check that */
1680 Class c; { /* class hierarchy is acyclic */
1682 if (isExt(c)) { /* special case for lacks preds */
1686 if (cclass(c).level < 0) { /* already visiting this class? */
1687 ERRMSG(cclass(c).line) "Class hierarchy for \"%s\" is not acyclic",
1688 textToStr(cclass(c).text)
1690 } else if (cclass(c).level == 0) { /* visiting class for first time */
1691 List scs = cclass(c).supers;
1693 cclass(c).level = (-1);
1694 for (; nonNull(scs); scs=tl(scs)) {
1695 Int l = visitClass(getHead(hd(scs)));
1698 cclass(c).level = 1+lev; /* level = 1 + max level of supers */
1700 return cclass(c).level;
1703 /* --------------------------------------------------------------------------
1704 * Process class and instance declaration binding groups:
1705 * ------------------------------------------------------------------------*/
1707 static List local classBindings(where,c,bs)
1708 String where; /* Check validity of bindings bs */
1709 Class c; /* for class c (or an inst of c) */
1710 List bs; { /* sort into approp. member order */
1713 for (; nonNull(bs); bs=tl(bs)) {
1715 Cell body = snd(snd(b));
1718 if (!isVar(fst(b))) { /* Only allow function bindings */
1719 ERRMSG(rhsLine(snd(body)))
1720 "Pattern binding illegal in %s declaration", where
1724 if (isNull(mnm=memberName(c,textOf(fst(b))))) {
1725 ERRMSG(rhsLine(snd(hd(body))))
1726 "No member \"%s\" in class \"%s\"",
1727 textToStr(textOf(fst(b))), textToStr(cclass(c).text)
1731 nbs = numInsert(mfunOf(mnm)-1,b,nbs);
1736 static Name local memberName(c,t) /* return name of member function */
1737 Class c; /* with name t in class c */
1738 Text t; { /* return NIL if not a member */
1739 List ms = cclass(c).members;
1740 for (; nonNull(ms); ms=tl(ms)) {
1741 if (t==name(hd(ms)).text) {
1748 static List local numInsert(n,x,xs) /* insert x at nth position in xs, */
1749 Int n; /* filling gaps with NIL */
1752 List start = isNull(xs) ? cons(NIL,NIL) : xs;
1754 for (xs=start; 0<n--; xs=tl(xs)) {
1755 if (isNull(tl(xs))) {
1756 tl(xs) = cons(NIL,NIL);
1763 /* --------------------------------------------------------------------------
1764 * Calculate set of variables appearing in a given type expression (possibly
1765 * qualified) as a list of distinct values. The order in which variables
1766 * appear in the list is the same as the order in which those variables
1767 * occur in the type expression when read from left to right.
1768 * ------------------------------------------------------------------------*/
1770 List local typeVarsIn(ty,us,ws,vs) /*Calculate list of type variables*/
1771 Cell ty; /* used in type expression, reading*/
1772 List us; /* from left to right ignoring any */
1773 List ws; /* listed in us. */
1774 List vs; { /* ws = explicitly quantified vars */
1775 if (isNull(ty)) return vs;
1776 switch (whatIs(ty)) {
1777 case DICTAP : return typeVarsIn(snd(snd(ty)),us,ws,vs);
1778 case UNBOXEDTUP: return typeVarsIn(snd(ty),us,ws,vs);
1780 case AP : return typeVarsIn(snd(ty),us,ws,
1781 typeVarsIn(fst(ty),us,ws,vs));
1784 case VAROPCELL : if ((nonNull(findBtyvs(textOf(ty)))
1785 && !varIsMember(textOf(ty),ws))
1786 || varIsMember(textOf(ty),us)) {
1789 return maybeAppendVar(ty,vs);
1792 case POLYTYPE : return typeVarsIn(monotypeOf(ty),polySigOf(ty),ws,vs);
1794 case QUAL : { vs = typeVarsIn(fst(snd(ty)),us,ws,vs);
1795 return typeVarsIn(snd(snd(ty)),us,ws,vs);
1798 case BANG : return typeVarsIn(snd(ty),us,ws,vs);
1800 case LABC : { List fs = snd(snd(ty));
1801 for (; nonNull(fs); fs=tl(fs)) {
1802 vs = typeVarsIn(snd(hd(fs)),us,ws,vs);
1809 case QUALIDENT: return vs;
1811 default: fprintf(stderr, " bad tag = %d\n", whatIs(ty));internal("typeVarsIn");
1816 static List local maybeAppendVar(v,vs) /* append variable to list if not */
1817 Cell v; /* already included */
1823 while (nonNull(c)) {
1824 if (textOf(hd(c))==t) {
1832 tl(p) = cons(v,NIL);
1840 /* --------------------------------------------------------------------------
1841 * Static analysis for type expressions is required to:
1842 * - ensure that each type constructor or class used has been defined.
1843 * - replace type variables by offsets, constructor names by Tycons.
1844 * - ensure that the type is well-kinded.
1845 * ------------------------------------------------------------------------*/
1847 static Type local checkSigType(line,where,e,type)
1848 Int line; /* Check validity of type expr in */
1849 String where; /* explicit type signature */
1856 if (isPolyType(type)) {
1857 xtvs = fst(snd(type));
1858 type = monotypeOf(type);
1860 tvs = typeVarsIn(type,NIL,xtvs,NIL);
1862 checkOptQuantVars(line,xtvs,tvs);
1864 if (isQualType(type)) {
1865 map2Over(depPredExp,line,tvs,fst(snd(type)));
1866 snd(snd(type)) = depTopType(line,tvs,snd(snd(type)));
1868 if (isAmbiguous(type)) {
1869 ambigError(line,where,e,type);
1872 type = depTopType(line,tvs,type);
1876 if (length(tvs) >= (OFF_MAX-OFF_MIN+1)) {
1877 ERRMSG(line) "Too many type variables in %s\n", where
1881 for (; nonNull(ts); ts=tl(ts)) {
1884 type = mkPolyType(tvs,type);
1889 kindType(line,"type expression",type);
1893 h98CheckType(line,where,e,type);
1897 static Void local checkOptQuantVars(line,xtvs,tvs)
1899 List xtvs; /* Explicitly quantified vars */
1900 List tvs; { /* Implicitly quantified vars */
1901 if (nonNull(xtvs)) {
1903 for (; nonNull(vs); vs=tl(vs)) {
1904 if (!varIsMember(textOf(hd(vs)),xtvs)) {
1905 ERRMSG(line) "Quantifier does not mention type variable \"%s\"",
1906 textToStr(textOf(hd(vs)))
1910 for (vs=xtvs; nonNull(vs); vs=tl(vs)) {
1911 if (!varIsMember(textOf(hd(vs)),tvs)) {
1912 ERRMSG(line) "Quantified type variable \"%s\" is not used",
1913 textToStr(textOf(hd(vs)))
1916 if (varIsMember(textOf(hd(vs)),tl(vs))) {
1917 ERRMSG(line) "Quantified type variable \"%s\" is repeated",
1918 textToStr(textOf(hd(vs)))
1925 static Type local depTopType(l,tvs,t) /* Check top-level of type sig */
1933 for (; getHead(t1)==typeArrow && argCount==2; ++i) {
1934 arg(fun(t1)) = depCompType(l,tvs,arg(fun(t1)));
1935 if (isPolyOrQualType(arg(fun(t1)))) {
1941 if (nonNull(prev)) {
1942 arg(prev) = depTypeExp(l,tvs,t1);
1944 t = depTypeExp(l,tvs,t1);
1947 t = ap(RANK2,pair(mkInt(nr2),t));
1952 static Type local depCompType(l,tvs,t) /* Check component type for constr */
1956 Int ntvs = length(tvs);
1958 if (isPolyType(t)) {
1959 List vs = fst(snd(t));
1961 tvs = checkQuantVars(l,vs,tvs,t);
1962 nfr = replicate(length(vs),NIL);
1964 if (isQualType(t)) {
1965 map2Over(depPredExp,l,tvs,fst(snd(t)));
1966 snd(snd(t)) = depTypeExp(l,tvs,snd(snd(t)));
1967 if (isAmbiguous(t)) {
1968 ambigError(l,"type component",NIL,t);
1971 t = depTypeExp(l,tvs,t);
1977 return mkPolyType(nfr,t);
1980 static Type local depTypeExp(line,tyvars,type)
1984 switch (whatIs(type)) {
1985 case AP : fst(type) = depTypeExp(line,tyvars,fst(type));
1986 snd(type) = depTypeExp(line,tyvars,snd(type));
1989 case VARIDCELL : return depTypeVar(line,tyvars,textOf(type));
1991 case QUALIDENT : if (isQVar(type)) {
1992 ERRMSG(line) "Qualified type variables not allowed"
1995 /* deliberate fall through */
1996 case CONIDCELL : { Tycon tc = findQualTycon(type);
1999 "Undefined type constructor \"%s\"",
2003 if (cellIsMember(tc,tyconDefns) &&
2004 !cellIsMember(tc,tcDeps)) {
2005 tcDeps = cons(tc,tcDeps);
2011 case EXT : h98DoesntSupport(line,"extensible records");
2016 default : internal("depTypeExp");
2021 static Type local depTypeVar(line,tyvars,tv)
2028 for (; nonNull(tyvars); offset++) {
2029 if (tv==textOf(hd(tyvars))) {
2032 tyvars = tl(tyvars);
2035 Cell vt = findBtyvs(tv);
2039 ERRMSG(line) "Undefined type variable \"%s\"", textToStr(tv)
2042 return mkOffset(found);
2045 static List local checkQuantVars(line,vs,tvs,body)
2047 List vs; /* variables to quantify over */
2048 List tvs; /* variables already in scope */
2049 Cell body; { /* type/constr for scope of vars */
2051 List bvs = typeVarsIn(body,NIL,NIL,NIL);
2053 for (; nonNull(us); us=tl(us)) {
2054 Text u = textOf(hd(us));
2055 if (varIsMember(u,tl(us))) {
2056 ERRMSG(line) "Duplicated quantified variable %s",
2061 if (varIsMember(u,tvs)) {
2062 ERRMSG(line) "Local quantifier for %s hides an outer use",
2067 if (!varIsMember(u,bvs)) {
2068 ERRMSG(line) "Locally quantified variable %s is not used",
2073 tvs = appendOnto(tvs,vs);
2078 /* --------------------------------------------------------------------------
2079 * Check for ambiguous types:
2080 * A type Preds => type is ambiguous if not (TV(P) `subset` TV(type))
2081 * ------------------------------------------------------------------------*/
2083 List offsetTyvarsIn(t,vs) /* add list of offset tyvars in t */
2084 Type t; /* to list vs */
2086 switch (whatIs(t)) {
2087 case AP : return offsetTyvarsIn(fun(t),
2088 offsetTyvarsIn(arg(t),vs));
2090 case OFFSET : if (cellIsMember(t,vs))
2095 case QUAL : return offsetTyvarsIn(snd(t),vs);
2097 case POLYTYPE : return offsetTyvarsIn(monotypeOf(t),vs);
2098 /* slightly inaccurate, but won't matter here */
2101 case RANK2 : return offsetTyvarsIn(snd(snd(t)),vs);
2103 default : return vs;
2107 List zonkTyvarsIn(t,vs)
2110 switch (whatIs(t)) {
2111 case AP : return zonkTyvarsIn(fun(t),
2112 zonkTyvarsIn(arg(t),vs));
2114 case INTCELL : if (cellIsMember(t,vs))
2119 /* this case will lead to a type error --
2120 much better than reporting an internal error ;-) */
2121 /* case OFFSET : internal("zonkTyvarsIn"); */
2123 default : return vs;
2127 static List local otvars(pi,os) /* os is a list of offsets that */
2128 Cell pi; /* refer to the arguments of pi; */
2129 List os; { /* find list of offsets in those */
2130 List us = NIL; /* positions */
2131 for (; nonNull(os); os=tl(os)) {
2132 us = offsetTyvarsIn(nthArg(offsetOf(hd(os)),pi),us);
2137 static List local otvarsZonk(pi,os,o) /* same as above, but zonks */
2141 for (; nonNull(os); os=tl(os)) {
2142 Type t = zonkType(nthArg(offsetOf(hd(os)),pi),o);
2143 us = zonkTyvarsIn(t,us);
2148 static Bool local odiff(us,vs)
2150 while (nonNull(us) && cellIsMember(hd(us),vs)) {
2156 static Bool local osubset(us,vs) /* Determine whether us is subset */
2157 List us, vs; { /* of vs */
2158 while (nonNull(us) && cellIsMember(hd(us),vs)) {
2164 List oclose(fds,vs) /* Compute closure of vs wrt to fds*/
2167 Bool changed = TRUE;
2171 while (nonNull(fds)) {
2173 List next = tl(fds);
2174 if (osubset(fst(fd),vs)) { /* Test if fd applies */
2176 for (; nonNull(os); os=tl(os)) {
2177 if (!cellIsMember(hd(os),vs)) {
2178 vs = cons(hd(os),vs);
2182 } else { /* Didn't apply this time, so keep */
2193 Bool isAmbiguous(type) /* Determine whether type is */
2194 Type type; { /* ambiguous */
2195 if (isPolyType(type)) {
2196 type = monotypeOf(type);
2198 if (isQualType(type)) { /* only qualified types can be */
2199 List ps = fst(snd(type)); /* ambiguous */
2200 List tvps = offsetTyvarsIn(ps,NIL);
2201 List tvts = offsetTyvarsIn(snd(snd(type)),NIL);
2202 List fds = calcFunDeps(ps);
2204 tvts = oclose(fds,tvts); /* Close tvts under fds */
2205 return !osubset(tvps,tvts);
2210 List calcFunDeps(ps)
2213 for (; nonNull(ps); ps=tl(ps)) {/* Calc functional dependencies */
2215 Cell c = getHead(pi);
2217 List xfs = cclass(c).xfds;
2218 for (; nonNull(xfs); xfs=tl(xfs)) {
2219 List fs = snd(hd(xfs));
2220 for (; nonNull(fs); fs=tl(fs)) {
2221 fds = cons(pair(otvars(pi,fst(hd(fs))),
2222 otvars(pi,snd(hd(fs)))),fds);
2228 fds = cons(pair(NIL,offsetTyvarsIn(arg(pi),NIL)),fds);
2235 List calcFunDepsPreds(ps)
2238 for (; nonNull(ps); ps=tl(ps)) {/* Calc functional dependencies */
2240 Cell pi = fst3(pi3);
2241 Cell c = getHead(pi);
2242 Int o = intOf(snd3(pi3));
2244 List xfs = cclass(c).xfds;
2245 for (; nonNull(xfs); xfs=tl(xfs)) {
2246 List fs = snd(hd(xfs));
2247 for (; nonNull(fs); fs=tl(fs)) {
2248 fds = cons(pair(otvarsZonk(pi,fst(hd(fs)),o),
2249 otvarsZonk(pi,snd(hd(fs)),o)),fds);
2255 fds = cons(pair(NIL,zonkTyvarsIn(arg(pi),NIL)),fds);
2262 Void ambigError(line,where,e,type) /* produce error message for */
2263 Int line; /* ambiguity */
2267 ERRMSG(line) "Ambiguous type signature in %s", where ETHEN
2268 ERRTEXT "\n*** ambiguous type : " ETHEN ERRTYPE(type);
2270 ERRTEXT "\n*** assigned to : " ETHEN ERREXPR(e);
2276 /* --------------------------------------------------------------------------
2277 * Kind inference for simple types:
2278 * ------------------------------------------------------------------------*/
2280 static Void local kindConstr(line,alpha,m,c)
2281 Int line; /* Determine kind of constructor */
2285 Cell h = getHead(c);
2289 Printf("kindConstr: alpha=%d, m=%d, c=",alpha,m);
2290 printType(stdout,c);
2294 switch (whatIs(h)) {
2295 case POLYTYPE : if (n!=0) {
2296 internal("kindConstr1");
2298 static String pt = "polymorphic type";
2299 Type t = dropRank1(c,alpha,m);
2300 Kinds ks = polySigOf(t);
2303 for (; isAp(ks); ks=tl(ks)) {
2306 beta = newKindvars(m1);
2307 unkindTypes = cons(pair(mkInt(beta),t),unkindTypes);
2308 checkKind(line,beta,m1,monotypeOf(t),NIL,pt,STAR,0);
2313 case QUAL : if (n!=0) {
2314 internal("kindConstr2");
2316 map3Proc(kindPred,line,alpha,m,fst(snd(c)));
2317 kindConstr(line,alpha,m,snd(snd(c)));
2321 case RANK2 : kindConstr(line,alpha,m,snd(snd(c)));
2325 case EXT : if (n!=2) {
2327 "Illegal use of row in " ETHEN ERRTYPE(c);
2334 case TYCON : if (isSynonym(h) && n<tycon(h).arity) {
2336 "Not enough arguments for type synonym \"%s\"",
2337 textToStr(tycon(h).text)
2343 if (n==0) { /* trivial case, no arguments */
2344 typeIs = kindAtom(alpha,c);
2345 } else { /* non-trivial application */
2346 static String app = "constructor application";
2356 typeIs = kindAtom(alpha,h); /* h :: v1 -> ... -> vn -> w */
2357 shouldKind(line,h,c,app,k,beta);
2359 for (i=n; i>0; --i) { /* ci :: vi for each 1 <- 1..n */
2360 checkKind(line,alpha,m,arg(a),c,app,aVar,beta+i-1);
2363 tyvarType(beta+n); /* inferred kind is w */
2367 static Kind local kindAtom(alpha,c) /* Find kind of atomic constructor */
2370 switch (whatIs(c)) {
2371 case TUPLE : return simpleKind(tupleOf(c)); /*(,)::* -> * -> * */
2372 case OFFSET : return mkInt(alpha+offsetOf(c));
2373 case TYCON : return tycon(c).kind;
2374 case INTCELL : return c;
2376 case VAROPCELL : { Cell vt = findBtyvs(textOf(c));
2382 case EXT : return extKind;
2386 Printf("kindAtom(%d,whatIs(%d)) on ",alpha,whatIs(c));
2387 printType(stdout,c);
2390 internal("kindAtom");
2391 return STAR;/* not reached */
2394 static Void local kindPred(l,alpha,m,pi)/* Check kinds of arguments in pred*/
2400 if (isAp(pi) && isExt(fun(pi))) {
2401 static String lackspred = "lacks predicate";
2402 checkKind(l,alpha,m,arg(pi),NIL,lackspred,ROW,0);
2407 if (isAp(pi) && whatIs(fun(pi)) == IPCELL) {
2408 static String ippred = "iparam predicate";
2409 checkKind(l,alpha,m,arg(pi),NIL,ippred,STAR,0);
2413 { static String predicate = "class constraint";
2414 Class c = getHead(pi);
2415 List as = getArgs(pi);
2416 Kinds ks = cclass(c).kinds;
2418 while (nonNull(ks)) {
2419 checkKind(l,alpha,m,hd(as),NIL,predicate,hd(ks),0);
2426 static Void local kindType(line,wh,type)/* check that (poss qualified) type*/
2427 Int line; /* is well-kinded */
2430 checkKind(line,0,0,type,NIL,wh,STAR,0);
2433 static Void local fixKinds() { /* add kind annotations to types */
2434 for (; nonNull(unkindTypes); unkindTypes=tl(unkindTypes)) {
2435 Pair pr = hd(unkindTypes);
2436 Int beta = intOf(fst(pr));
2437 Cell qts = polySigOf(snd(pr));
2439 if (isNull(hd(qts))) {
2440 hd(qts) = copyKindvar(beta++);
2442 internal("fixKinds");
2444 if (nonNull(tl(qts))) {
2452 Printf("Type expression: ");
2453 printType(stdout,snd(pr));
2455 printKind(stdout,polySigOf(snd(pr)));
2461 /* --------------------------------------------------------------------------
2462 * Kind checking of groups of type constructors and classes:
2463 * ------------------------------------------------------------------------*/
2465 static Void local kindTCGroup(tcs) /* find kinds for mutually rec. gp */
2466 List tcs; { /* of tycons and classes */
2467 emptySubstitution();
2469 mapProc(initTCKind,tcs);
2470 mapProc(kindTC,tcs);
2473 emptySubstitution();
2476 static Void local initTCKind(c) /* build initial kind/arity for c */
2478 if (isTycon(c)) { /* Initial kind of tycon is: */
2479 Int beta = newKindvars(1); /* v1 -> ... -> vn -> vn+1 */
2480 varKind(tycon(c).arity); /* where n is the arity of c. */
2481 bindTv(beta,typeIs,typeOff); /* For data definitions, vn+1 == * */
2482 switch (whatIs(tycon(c).what)) {
2484 case DATATYPE : bindTv(typeOff+tycon(c).arity,STAR,0);
2486 tycon(c).kind = mkInt(beta);
2488 Int n = cclass(c).arity;
2489 Int beta = newKindvars(n);
2490 cclass(c).kinds = NIL;
2493 cclass(c).kinds = pair(mkInt(beta+n),cclass(c).kinds);
2498 static Void local kindTC(c) /* check each part of a tycon/class*/
2499 Cell c; { /* is well-kinded */
2501 static String cfun = "constructor function";
2502 static String tsyn = "synonym definition";
2503 Int line = tycon(c).line;
2504 Int beta = tyvar(intOf(tycon(c).kind))->offs;
2505 Int m = tycon(c).arity;
2506 switch (whatIs(tycon(c).what)) {
2508 case DATATYPE : { List cs = tycon(c).defn;
2509 if (isQualType(cs)) {
2510 map3Proc(kindPred,line,beta,m,
2512 tycon(c).defn = cs = snd(snd(cs));
2514 for (; hasCfun(cs); cs=tl(cs)) {
2515 kindType(line,cfun,name(hd(cs)).type);
2520 default : checkKind(line,beta,m,tycon(c).defn,NIL,
2524 else { /* scan type exprs in class defn to*/
2525 List ms = fst(cclass(c).members);
2526 Int m = cclass(c).arity; /* determine the class signature */
2527 Int beta = newKindvars(m);
2528 kindPred(cclass(c).line,beta,m,cclass(c).head);
2529 map3Proc(kindPred,cclass(c).line,beta,m,cclass(c).supers);
2530 for (; nonNull(ms); ms=tl(ms)) {
2531 Int line = intOf(fst3(hd(ms)));
2532 Type type = thd3(hd(ms));
2533 kindType(line,"member function type signature",type);
2538 static Void local genTC(c) /* generalise kind inferred for */
2539 Cell c; { /* given tycon/class */
2541 tycon(c).kind = copyKindvar(intOf(tycon(c).kind));
2543 Printf("%s :: ",textToStr(tycon(c).text));
2544 printKind(stdout,tycon(c).kind);
2548 Kinds ks = cclass(c).kinds;
2549 for (; nonNull(ks); ks=tl(ks)) {
2550 hd(ks) = copyKindvar(intOf(hd(ks)));
2553 Printf("%s :: ",textToStr(cclass(c).text));
2554 printKinds(stdout,cclass(c).kinds);
2560 /* --------------------------------------------------------------------------
2561 * Static analysis of instance declarations:
2563 * The first part of the static analysis is performed as the declarations
2564 * are read during parsing:
2565 * - make new entry in instance table
2566 * - record line number of declaration
2567 * - build list of instances defined in current script for use in later
2568 * stages of static analysis.
2569 * ------------------------------------------------------------------------*/
2571 Void instDefn(line,head,ms) /* process new instance definition */
2572 Int line; /* definition line number */
2573 Cell head; /* inst header :: (context,Class) */
2574 List ms; { /* instance members */
2575 Inst nw = newInst();
2576 inst(nw).line = line;
2577 inst(nw).specifics = fst(head);
2578 inst(nw).head = snd(head);
2579 inst(nw).implements = ms;
2580 instDefns = cons(nw,instDefns);
2583 /* --------------------------------------------------------------------------
2584 * Further static analysis of instance declarations:
2586 * Makes the following checks:
2587 * - Class part of header has form C (T a1 ... an) where C is a known
2588 * class, and T is a known datatype constructor (or restricted synonym),
2589 * and there is no previous C-T instance, and (T a1 ... an) has a kind
2590 * appropriate for the class C.
2591 * - Each element of context is a valid class expression, with type vars
2592 * drawn from a1, ..., an.
2593 * - All bindings are function bindings
2594 * - All bindings define member functions for class C
2595 * - Arrange bindings into appropriate order for member list
2596 * - No top level type signature declarations
2597 * ------------------------------------------------------------------------*/
2599 Bool allowOverlap = FALSE; /* TRUE => allow overlapping insts */
2600 Name nameListMonad = NIL; /* builder function for List Monad */
2602 static Void local checkInstDefn(in) /* Validate instance declaration */
2604 Int line = inst(in).line;
2605 List tyvars = typeVarsIn(inst(in).head,NIL,NIL,NIL);
2606 List tvps = NIL, tvts = NIL;
2609 if (haskell98) { /* Check for `simple' type */
2611 Cell t = arg(inst(in).head);
2612 for (; isAp(t); t=fun(t)) {
2613 if (!isVar(arg(t))) {
2615 "syntax error in instance head (variable expected)"
2618 if (varIsMember(textOf(arg(t)),tvs)) {
2619 ERRMSG(line) "repeated type variable \"%s\" in instance head",
2620 textToStr(textOf(arg(t)))
2623 tvs = cons(arg(t),tvs);
2627 "syntax error in instance head (constructor expected)"
2632 /* add in the tyvars from the `specifics' so that we don't
2633 prematurely complain about undefined tyvars */
2634 tyvars = typeVarsIn(inst(in).specifics,NIL,NIL,tyvars);
2635 inst(in).head = depPredExp(line,tyvars,inst(in).head);
2638 Type h = getHead(arg(inst(in).head));
2640 ERRMSG(line) "Cannot use type synonym in instance head"
2645 map2Over(depPredExp,line,tyvars,inst(in).specifics);
2647 /* OK, now we start over, and test for ambiguity */
2648 tvts = offsetTyvarsIn(inst(in).head,NIL);
2649 tvps = offsetTyvarsIn(inst(in).specifics,NIL);
2650 fds = calcFunDeps(inst(in).specifics);
2651 tvts = oclose(fds,tvts);
2652 tvts = odiff(tvps,tvts);
2653 if (!isNull(tvts)) {
2654 ERRMSG(line) "Undefined type variable \"%s\"",
2655 textToStr(textOf(nth(offsetOf(hd(tvts)),tyvars)))
2659 h98CheckCtxt(line,"instance definition",FALSE,inst(in).specifics,NIL);
2660 inst(in).numSpecifics = length(inst(in).specifics);
2661 inst(in).c = getHead(inst(in).head);
2662 if (!isClass(inst(in).c)) {
2663 ERRMSG(line) "Illegal predicate in instance declaration"
2667 if (nonNull(cclass(inst(in).c).fds)) {
2668 List fds = cclass(inst(in).c).fds;
2669 for (; nonNull(fds); fds=tl(fds)) {
2670 List as = otvars(inst(in).head, fst(hd(fds)));
2671 List bs = otvars(inst(in).head, snd(hd(fds)));
2672 List fs = calcFunDeps(inst(in).specifics);
2674 if (!osubset(bs,as)) {
2675 ERRMSG(inst(in).line)
2676 "Instance is more general than a dependency allows"
2678 ERRTEXT "\n*** Instance : "
2679 ETHEN ERRPRED(inst(in).head);
2680 ERRTEXT "\n*** For class : "
2681 ETHEN ERRPRED(cclass(inst(in).c).head);
2682 ERRTEXT "\n*** Under dependency : "
2683 ETHEN ERRFD(hd(fds));
2690 kindInst(in,length(tyvars));
2693 if (nonNull(extractSigdecls(inst(in).implements))) {
2695 "Type signature declarations not permitted in instance declaration"
2698 if (nonNull(extractFixdecls(inst(in).implements))) {
2700 "Fixity declarations not permitted in instance declaration"
2703 inst(in).implements = classBindings("instance",
2705 extractBindings(inst(in).implements));
2706 inst(in).builder = newInstImp(in);
2707 if (!preludeLoaded && isNull(nameListMonad) && isAp(inst(in).head)
2708 && fun(inst(in).head)==classMonad && arg(inst(in).head)==typeList) {
2709 nameListMonad = inst(in).builder;
2713 static Void local insertInst(in) /* Insert instance into class */
2715 Class c = inst(in).c;
2716 List ins = cclass(c).instances;
2719 if (nonNull(cclass(c).fds)) { /* Check for conflicts with fds */
2720 List ins1 = cclass(c).instances;
2721 for (; nonNull(ins1); ins1=tl(ins1)) {
2722 List fds = cclass(c).fds;
2723 substitution(RESET);
2724 for (; nonNull(fds); fds=tl(fds)) {
2725 Int alpha = newKindedVars(inst(in).kinds);
2726 Int beta = newKindedVars(inst(hd(ins1)).kinds);
2727 List as = fst(hd(fds));
2729 for (; same && nonNull(as); as=tl(as)) {
2730 Int n = offsetOf(hd(as));
2731 same &= unify(nthArg(n,inst(in).head),alpha,
2732 nthArg(n,inst(hd(ins1)).head),beta);
2734 if (isNull(as) && same) {
2735 for (as=snd(hd(fds)); same && nonNull(as); as=tl(as)) {
2736 Int n = offsetOf(hd(as));
2737 same &= sameType(nthArg(n,inst(in).head),alpha,
2738 nthArg(n,inst(hd(ins1)).head),beta);
2741 ERRMSG(inst(in).line)
2742 "Instances are not consistent with dependencies"
2744 ERRTEXT "\n*** This instance : "
2745 ETHEN ERRPRED(inst(in).head);
2746 ERRTEXT "\n*** Conflicts with : "
2747 ETHEN ERRPRED(inst(hd(ins)).head);
2748 ERRTEXT "\n*** For class : "
2749 ETHEN ERRPRED(cclass(c).head);
2750 ERRTEXT "\n*** Under dependency : "
2751 ETHEN ERRFD(hd(fds));
2761 substitution(RESET);
2762 while (nonNull(ins)) { /* Look for overlap w/ other insts */
2763 Int alpha = newKindedVars(inst(in).kinds);
2764 Int beta = newKindedVars(inst(hd(ins)).kinds);
2765 if (unifyPred(inst(in).head,alpha,inst(hd(ins)).head,beta)) {
2766 Cell pi = copyPred(inst(in).head,alpha);
2767 if (allowOverlap && !haskell98) {
2768 Bool bef = instCompare(in,hd(ins));
2769 Bool aft = instCompare(hd(ins),in);
2770 if (bef && !aft) { /* in comes strictly before hd(ins)*/
2773 if (aft && !bef) { /* in comes strictly after hd(ins) */
2780 if (multiInstRes && nonNull(inst(in).specifics)) {
2784 ERRMSG(inst(in).line) "Overlapping instances for class \"%s\"",
2785 textToStr(cclass(c).text)
2787 ERRTEXT "\n*** This instance : " ETHEN ERRPRED(inst(in).head);
2788 ERRTEXT "\n*** Overlaps with : " ETHEN
2789 ERRPRED(inst(hd(ins)).head);
2790 ERRTEXT "\n*** Common instance : " ETHEN
2798 prev = ins; /* No overlap detected, so move on */
2799 ins = tl(ins); /* to next instance */
2801 substitution(RESET);
2803 if (nonNull(prev)) { /* Insert instance at this point */
2804 tl(prev) = cons(in,ins);
2806 cclass(c).instances = cons(in,ins);
2810 static Bool local instCompare(ia,ib) /* See if ia is an instance of ib */
2812 Int alpha = newKindedVars(inst(ia).kinds);
2813 Int beta = newKindedVars(inst(ib).kinds);
2814 return matchPred(inst(ia).head,alpha,inst(ib).head,beta);
2817 static Name local newInstImp(in) /* Make definition for inst builder*/
2819 Name b = newName(inventText(),in);
2820 name(b).line = inst(in).line;
2821 name(b).arity = inst(in).numSpecifics;
2822 name(b).number = DFUNNAME;
2826 /* --------------------------------------------------------------------------
2827 * Kind checking of instance declaration headers:
2828 * ------------------------------------------------------------------------*/
2830 static Void local kindInst(in,freedom) /* check predicates in instance */
2835 emptySubstitution();
2836 beta = newKindvars(freedom);
2837 kindPred(inst(in).line,beta,freedom,inst(in).head);
2838 if (whatIs(inst(in).specifics)!=DERIVE) {
2839 map3Proc(kindPred,inst(in).line,beta,freedom,inst(in).specifics);
2841 for (inst(in).kinds = NIL; 0<freedom--; ) {
2842 inst(in).kinds = cons(copyKindvar(beta+freedom),inst(in).kinds);
2845 Printf("instance ");
2846 printPred(stdout,inst(in).head);
2848 printKinds(stdout,inst(in).kinds);
2851 emptySubstitution();
2854 /* --------------------------------------------------------------------------
2855 * Process derived instance requests:
2856 * ------------------------------------------------------------------------*/
2858 static List derivedInsts; /* list of derived instances */
2860 static Void local checkDerive(t,p,ts,ct)/* verify derived instance request */
2861 Tycon t; /* for tycon t, with explicit */
2862 List p; /* context p, component types ts */
2863 List ts; /* and named class ct */
2865 Int line = tycon(t).line;
2866 Class c = findQualClass(ct);
2868 ERRMSG(line) "Unknown class \"%s\" in derived instance",
2872 addDerInst(line,c,p,dupList(ts),t,tycon(t).arity);
2875 static Void local addDerInst(line,c,p,cts,t,a) /* Add a derived instance */
2882 Cell head = t; /* Build instance head */
2886 head = ap(head,mkOffset(i));
2892 inst(in).line = line;
2893 inst(in).head = head;
2894 inst(in).specifics = ap(DERIVE,pair(dupList(p),cts));
2895 inst(in).implements = NIL;
2896 inst(in).kinds = mkInt(a);
2897 derivedInsts = cons(in,derivedInsts);
2900 Void addTupInst(c,n) /* Request derived instance of c */
2901 Class c; /* for mkTuple(n) constructor */
2906 cts = cons(mkOffset(m),cts);
2909 addDerInst(0,c,NIL,cts,mkTuple(n),n);
2913 Inst addRecShowInst(c,e) /* Generate instance for ShowRecRow*/
2914 Class c; /* c *must* be ShowRecRow */
2916 Inst in = newInst();
2918 inst(in).head = ap(c,ap2(e,aVar,bVar));
2919 inst(in).kinds = extKind;
2920 inst(in).specifics = cons(ap(classShow,aVar),
2922 cons(ap(c,bVar),NIL)));
2923 inst(in).numSpecifics = 3;
2924 inst(in).builder = implementRecShw(extText(e),in);
2925 cclass(c).instances = appendOnto(cclass(c).instances,singleton(in));
2929 Inst addRecEqInst(c,e) /* Generate instance for EqRecRow */
2930 Class c; /* c *must* be EqRecRow */
2932 Inst in = newInst();
2934 inst(in).head = ap(c,ap2(e,aVar,bVar));
2935 inst(in).kinds = extKind;
2936 inst(in).specifics = cons(ap(classEq,aVar),
2938 cons(ap(c,bVar),NIL)));
2939 inst(in).numSpecifics = 3;
2940 inst(in).builder = implementRecEq(extText(e),in);
2941 cclass(c).instances = appendOnto(cclass(c).instances,singleton(in));
2946 /* --------------------------------------------------------------------------
2947 * Calculation of contexts for derived instances:
2949 * Allowing arbitrary types to appear in contexts makes it rather harder
2950 * to decide what the context for a derived instance should be. For
2953 * data T a = MkT [a] deriving Show,
2955 * we could have either of the following:
2957 * instance (Show [a]) => Show (T a) where ...
2958 * instance (Show a) => Show (T a) where ...
2960 * (assuming, of course, that instance (Show a) => Show [a]). For now, we
2961 * choose to reduce contexts in the hope of detecting errors at an earlier
2962 * stage---in contrast with value definitions, there is no way for a user
2963 * to provide something analogous to a `type signature' by which they might
2964 * be able to control this behaviour themselves. We eliminate tautological
2965 * predicates, but only allow predicates to appear in the final result if
2966 * they have at least one argument with a variable at its head.
2968 * In general, we have to deal with mutually recursive instance declarations.
2969 * We find a solution in the obvious way by iterating to find a fixed point.
2970 * Of course, without restrictions on the form of instance declarations, we
2971 * cannot be sure that this will always terminate!
2973 * For each instance we maintain a pair of the form DERIVE (ctxt,ps).
2974 * Ctxt is a list giving the parts of the context that have been produced
2975 * so far in the form of predicate skeletons. During the calculation of
2976 * derived instances, we attach a dummy NIL value to the end of the list
2977 * which acts as a kind of `variable': other parts of the system maintain
2978 * pointers to this variable, and use it to detect when the context has
2979 * been extended with new elements. Meanwhile, ps is a list containing
2980 * predicates (pi,o) together with (delayed) substitutions of the form
2981 * (o,xs) where o is an offset and xs is one of the context variables
2982 * described above, which may have been partially instantiated.
2983 * ------------------------------------------------------------------------*/
2985 static Bool instsChanged;
2987 static Void local deriveContexts(is) /* Calc contexts for derived insts */
2989 emptySubstitution();
2990 mapProc(initDerInst,is); /* Prepare derived instances */
2992 do { /* Main calculation of contexts */
2993 instsChanged = FALSE;
2994 mapProc(calcInstPreds,is);
2995 } while (instsChanged);
2997 mapProc(tidyDerInst,is); /* Tidy up results */
3000 static Void local initDerInst(in) /* Prepare instance for calculation*/
3001 Inst in; { /* of derived instance context */
3002 Cell spcs = inst(in).specifics;
3003 Int beta = newKindedVars(inst(in).kinds);
3004 if (whatIs(spcs)!=DERIVE) {
3005 internal("initDerInst");
3007 fst(snd(spcs)) = appendOnto(fst(snd(spcs)),singleton(NIL));
3008 for (spcs=snd(snd(spcs)); nonNull(spcs); spcs=tl(spcs)) {
3009 hd(spcs) = ap2(inst(in).c,hd(spcs),mkInt(beta));
3011 inst(in).numSpecifics = beta;
3013 #ifdef DEBUG_DERIVING
3014 Printf("initDerInst: ");
3015 printPred(stdout,inst(in).head);
3017 printContext(stdout,snd(snd(inst(in).specifics)));
3022 static Void local calcInstPreds(in) /* Calculate next approximation */
3023 Inst in; { /* of the context for a derived */
3024 List retain = NIL; /* instance */
3025 List ps = snd(snd(inst(in).specifics));
3026 List spcs = fst(snd(inst(in).specifics));
3027 Int beta = inst(in).numSpecifics;
3029 Int factor = 1+length(ps);
3031 #ifdef DEBUG_DERIVING
3032 Printf("calcInstPreds: ");
3033 printPred(stdout,inst(in).head);
3037 while (nonNull(ps)) {
3040 if (its++ >= factor*cutoff) {
3041 Cell bpi = inst(in).head;
3042 ERRMSG(inst(in).line) "\n*** Cannot derive " ETHEN ERRPRED(bpi);
3043 ERRTEXT " after %d iterations.", its-1 ETHEN
3045 "\n*** This may indicate that the problem is undecidable. However,\n"
3047 "*** you may still try to increase the cutoff limit using the -c\n"
3049 "*** option and then try again. (The current setting is -c%d)\n",
3053 if (isInt(fst(p))) { /* Delayed substitution? */
3055 for (; nonNull(hd(qs)); qs=tl(qs)) {
3056 ps = cons(pair(hd(qs),fst(p)),ps);
3058 retain = cons(pair(fst(p),qs),retain);
3061 else if (isExt(fun(fst(p)))) { /* Lacks predicate */
3062 Text l = extText(fun(fst(p)));
3063 Type t = arg(fst(p));
3064 Int o = intOf(snd(p));
3069 h = getDerefHead(t,o);
3070 while (isExt(h) && argCount==2 && l!=extText(h)) {
3073 h = getDerefHead(t,o);
3075 if (argCount==0 && isOffset(h)) {
3076 maybeAddPred(ap(fun(fun(p)),h),o,beta,spcs);
3077 } else if (argCount!=0 || h!=typeNoRow) {
3078 Cell bpi = inst(in).head;
3079 Cell pi = copyPred(fun(p),intOf(snd(p)));
3080 ERRMSG(inst(in).line) "Cannot derive " ETHEN ERRPRED(bpi);
3081 ERRTEXT " because predicate " ETHEN ERRPRED(pi);
3082 ERRTEXT " does not hold\n"
3087 else { /* Class predicate */
3089 Int o = intOf(snd(p));
3090 Inst in1 = findInstFor(pi,o);
3092 List qs = inst(in1).specifics;
3093 Int off = mkInt(typeOff);
3094 if (whatIs(qs)==DERIVE) { /* Still being derived */
3095 for (qs=fst(snd(qs)); nonNull(hd(qs)); qs=tl(qs)) {
3096 ps = cons(pair(hd(qs),off),ps);
3098 retain = cons(pair(off,qs),retain);
3099 } else { /* Previously def'd inst */
3100 for (; nonNull(qs); qs=tl(qs)) {
3101 ps = cons(pair(hd(qs),off),ps);
3104 } else { /* No matching instance */
3106 while (isAp(qi) && isOffset(getDerefHead(arg(qi),o))) {
3110 Cell bpi = inst(in).head;
3111 pi = copyPred(pi,o);
3112 ERRMSG(inst(in).line) "An instance of " ETHEN ERRPRED(pi);
3113 ERRTEXT " is required to derive " ETHEN ERRPRED(bpi);
3117 maybeAddPred(pi,o,beta,spcs);
3122 snd(snd(inst(in).specifics)) = retain;
3125 static Void local maybeAddPred(pi,o,beta,ps)
3126 Cell pi; /* Add predicate pi to the list ps,*/
3127 Int o; /* setting the instsChanged flag if*/
3128 Int beta; /* pi is not already a member and */
3129 List ps; { /* using beta to adjust vars */
3130 Cell c = getHead(pi);
3131 for (; nonNull(ps); ps=tl(ps)) {
3132 if (isNull(hd(ps))) { /* reached the `dummy' end of list?*/
3133 hd(ps) = copyAdj(pi,o,beta);
3134 tl(ps) = pair(NIL,NIL);
3135 instsChanged = TRUE;
3137 } else if (c==getHead(hd(ps)) && samePred(pi,o,hd(ps),beta)) {
3143 static Cell local copyAdj(c,o,beta) /* Copy (c,o), replacing vars with */
3144 Cell c; /* offsets relative to beta. */
3147 switch (whatIs(c)) {
3148 case AP : { Cell l = copyAdj(fst(c),o,beta);
3149 Cell r = copyAdj(snd(c),o,beta);
3153 case OFFSET : { Int vn = o+offsetOf(c);
3154 Tyvar *tyv = tyvar(vn);
3156 return copyAdj(tyv->bound,tyv->offs,beta);
3159 if (vn<0 || vn>=(OFF_MAX-OFF_MIN+1)) {
3160 internal("copyAdj");
3162 return mkOffset(vn);
3168 static Void local tidyDerInst(in) /* Tidy up results of derived inst */
3169 Inst in; { /* calculations */
3170 Int o = inst(in).numSpecifics;
3171 List ps = tl(rev(fst(snd(inst(in).specifics))));
3173 copyPred(inst(in).head,o);
3174 inst(in).specifics = simpleContext(ps,o);
3175 h98CheckCtxt(inst(in).line,"derived instance",FALSE,inst(in).specifics,in);
3176 inst(in).numSpecifics = length(inst(in).specifics);
3178 #ifdef DEBUG_DERIVING
3179 Printf("Derived instance: ");
3180 printContext(stdout,inst(in).specifics);
3182 printPred(stdout,inst(in).head);
3187 /* --------------------------------------------------------------------------
3188 * Generate code for derived instances:
3189 * ------------------------------------------------------------------------*/
3191 static Void local addDerivImp(in)
3194 Type t = getHead(arg(inst(in).head));
3195 Class c = inst(in).c;
3198 } else if (c==classOrd) {
3200 } else if (c==classEnum) {
3201 imp = deriveEnum(t);
3202 } else if (c==classIx) {
3204 } else if (c==classShow) {
3205 imp = deriveShow(t);
3206 } else if (c==classRead) {
3207 imp = deriveRead(t);
3208 } else if (c==classBounded) {
3209 imp = deriveBounded(t);
3211 ERRMSG(inst(in).line) "Cannot derive instances of class \"%s\"",
3212 textToStr(cclass(inst(in).c).text)
3216 kindInst(in,intOf(inst(in).kinds));
3218 inst(in).builder = newInstImp(in);
3219 inst(in).implements = classBindings("derived instance",
3225 /* --------------------------------------------------------------------------
3226 * Default definitions; only one default definition is permitted in a
3227 * given script file. If no default is supplied, then a standard system
3228 * default will be used where necessary.
3229 * ------------------------------------------------------------------------*/
3231 Void defaultDefn(line,defs) /* Handle default types definition */
3234 if (defaultLine!=0) {
3235 ERRMSG(line) "Multiple default declarations are not permitted in" ETHEN
3236 ERRTEXT "a single script file.\n"
3239 defaultDefns = defs;
3243 static Void local checkDefaultDefns() { /* check that default types are */
3244 List ds = NIL; /* well-kinded instances of Num */
3246 if (defaultLine!=0) {
3247 map2Over(depTypeExp,defaultLine,NIL,defaultDefns);
3248 emptySubstitution();
3250 map2Proc(kindType,defaultLine,"default type",defaultDefns);
3252 emptySubstitution();
3253 mapOver(fullExpand,defaultDefns);
3255 defaultDefns = stdDefaults;
3258 if (isNull(classNum)) {
3259 classNum = findClass(findText("Num"));
3262 for (ds=defaultDefns; nonNull(ds); ds=tl(ds)) {
3263 if (isNull(provePred(NIL,NIL,ap(classNum,hd(ds))))) {
3265 "Default types must be instances of the Num class"
3272 /* --------------------------------------------------------------------------
3273 * Foreign import declarations are Hugs' equivalent of GHC's ccall mechanism.
3274 * They are used to "import" C functions into a module.
3275 * They are usually not written by hand but, rather, generated automatically
3276 * by GreenCard, IDL compilers or whatever. We support foreign import
3277 * (static) and foreign import dynamic. In the latter case, extName==NIL.
3279 * Foreign export declarations generate C wrappers for Hugs functions.
3280 * Hugs only provides "foreign export dynamic" because it's not obvious
3281 * what "foreign export static" would mean in an interactive setting.
3282 * ------------------------------------------------------------------------*/
3284 Void foreignImport(line,callconv,extName,intName,type)
3285 /* Handle foreign imports */
3291 Text t = textOf(intName);
3292 Name n = findName(t);
3293 Int l = intOf(line);
3297 } else if (name(n).defn!=PREDEFINED) {
3298 ERRMSG(l) "Redeclaration of foreign \"%s\"", textToStr(t)
3302 name(n).defn = extName;
3303 name(n).type = type;
3304 name(n).callconv = callconv;
3305 foreignImports = cons(n,foreignImports);
3308 static Void local checkForeignImport(p) /* Check foreign import */
3310 emptySubstitution();
3311 name(p).type = checkSigType(name(p).line,
3312 "foreign import declaration",
3315 /* We don't expand synonyms here because we don't want the IO
3316 * part to be expanded.
3317 * name(p).type = fullExpand(name(p).type);
3319 implementForeignImport(p);
3322 Void foreignExport(line,callconv,extName,intName,type)
3323 /* Handle foreign exports */
3329 Text t = textOf(intName);
3330 Name n = findName(t);
3331 Int l = intOf(line);
3335 } else if (name(n).defn!=PREDEFINED) {
3336 ERRMSG(l) "Redeclaration of foreign \"%s\"", textToStr(t)
3340 name(n).defn = NIL; /* nothing to say */
3341 name(n).type = type;
3342 name(n).callconv = callconv;
3343 foreignExports = cons(n,foreignExports);
3346 static Void local checkForeignExport(p) /* Check foreign export */
3348 emptySubstitution();
3349 name(p).type = checkSigType(name(p).line,
3350 "foreign export declaration",
3353 implementForeignExport(p);
3358 /* --------------------------------------------------------------------------
3359 * Static analysis of patterns:
3361 * Patterns are parsed as ordinary (atomic) expressions. Static analysis
3362 * makes the following checks:
3363 * - Patterns are well formed (according to pattern syntax), including the
3364 * special case of (n+k) patterns.
3365 * - All constructor functions have been defined and are used with the
3366 * correct number of arguments.
3367 * - No variable name is used more than once in a pattern.
3369 * The list of pattern variables occuring in each pattern is accumulated in
3370 * a global list `patVars', which must be initialised to NIL at appropriate
3371 * points before using these routines to check for valid patterns. This
3372 * mechanism enables the pattern checking routine to be mapped over a list
3373 * of patterns, ensuring that no variable occurs more than once in the
3374 * complete pattern list (as is required on the lhs of a function defn).
3375 * ------------------------------------------------------------------------*/
3377 static List patVars; /* List of vars bound in pattern */
3379 static Cell local checkPat(line,p) /* Check valid pattern syntax */
3382 switch (whatIs(p)) {
3384 case VAROPCELL : addToPatVars(line,p);
3387 case INFIX : return checkPat(line,tidyInfix(line,snd(p)));
3389 case AP : return checkMaybeCnkPat(line,p);
3394 case CONOPCELL : return checkApPat(line,0,p);
3399 case FLOATCELL : break;
3400 case INTCELL : break;
3402 case ASPAT : addToPatVars(line,fst(snd(p)));
3403 snd(snd(p)) = checkPat(line,snd(snd(p)));
3406 case LAZYPAT : snd(p) = checkPat(line,snd(p));
3409 case FINLIST : map1Over(checkPat,line,snd(p));
3412 case CONFLDS : depConFlds(line,p,TRUE);
3415 case ESIGN : snd(snd(p)) = checkPatType(line,
3419 fst(snd(p)) = checkPat(line,fst(snd(p)));
3422 default : ERRMSG(line) "Illegal pattern syntax"
3428 static Cell local checkMaybeCnkPat(l,p)/* Check applicative pattern with */
3429 Int l; /* the possibility of n+k pattern */
3431 Cell h = getHead(p);
3433 if (argCount==2 && isVar(h) && textOf(h)==textPlus) { /* n+k */
3434 Cell v = arg(fun(p));
3435 if (!isInt(arg(p))) {
3436 ERRMSG(l) "Second argument in (n+k) pattern must be an integer"
3439 if (intOf(arg(p))<=0) {
3440 ERRMSG(l) "Integer k in (n+k) pattern must be > 0"
3443 fst(fun(p)) = ADDPAT;
3444 intValOf(fun(p)) = intOf(arg(p));
3445 arg(p) = checkPat(l,v);
3448 return checkApPat(l,0,p);
3451 static Cell local checkApPat(line,args,p)
3452 Int line; /* check validity of application */
3453 Int args; /* of constructor to arguments */
3455 switch (whatIs(p)) {
3456 case AP : fun(p) = checkApPat(line,args+1,fun(p));
3457 arg(p) = checkPat(line,arg(p));
3460 case TUPLE : if (tupleOf(p)!=args) {
3461 ERRMSG(line) "Illegal tuple pattern"
3467 case EXT : h98DoesntSupport(line,"extensible records");
3469 ERRMSG(line) "Illegal record pattern"
3475 case QUALIDENT : if (!isQCon(p)) {
3477 "Illegal use of qualified variable in pattern"
3480 /* deliberate fall through */
3482 case CONOPCELL : p = conDefined(line,p);
3483 checkCfunArgs(line,p,args);
3486 case NAME : checkIsCfun(line,p);
3487 checkCfunArgs(line,p,args);
3490 default : ERRMSG(line) "Illegal pattern syntax"
3496 static Void local addToPatVars(line,v) /* Add variable v to list of vars */
3497 Int line; /* in current pattern, checking */
3498 Cell v; { /* for repeated variables. */
3503 for (; nonNull(n); p=n, n=tl(n)) {
3504 if (textOf(hd(n))==t) {
3505 ERRMSG(line) "Repeated variable \"%s\" in pattern",
3512 patVars = cons(v,NIL);
3514 tl(p) = cons(v,NIL);
3518 static Name local conDefined(line,nm) /* check that nm is the name of a */
3519 Int line; /* previously defined constructor */
3520 Cell nm; { /* function. */
3521 Name n = findQualName(nm);
3523 ERRMSG(line) "Undefined constructor function \"%s\"", identToStr(nm)
3526 checkIsCfun(line,n);
3530 static Void local checkIsCfun(line,c) /* Check that c is a constructor fn */
3534 ERRMSG(line) "\"%s\" is not a constructor function",
3535 textToStr(name(c).text)
3540 static Void local checkCfunArgs(line,c,args)
3541 Int line; /* Check constructor applied with */
3542 Cell c; /* correct number of arguments */
3544 Int a = userArity(c);
3547 "Constructor \"%s\" must have exactly %d argument%s in pattern",
3548 textToStr(name(c).text), a, ((a==1)?"":"s")
3553 static Cell local checkPatType(l,wh,e,t)/* Check type appearing in pattern */
3558 List tvs = typeVarsIn(t,NIL,NIL,NIL);
3559 h98DoesntSupport(l,"pattern type annotations");
3560 for (; nonNull(tvs); tvs=tl(tvs)) {
3561 Int beta = newKindvars(1);
3562 hd(btyvars) = cons(pair(hd(tvs),mkInt(beta)), hd(btyvars));
3564 t = checkSigType(l,"pattern type",e,t);
3565 if (isPolyOrQualType(t) || whatIs(t)==RANK2) {
3566 ERRMSG(l) "Illegal syntax in %s type annotation", wh
3572 static Cell local applyBtyvs(pat) /* Record bound type vars in pat */
3574 List bts = hd(btyvars);
3577 pat = ap(BIGLAM,pair(bts,pat));
3578 for (; nonNull(bts); bts=tl(bts)) {
3579 snd(hd(bts)) = copyKindvar(intOf(snd(hd(bts))));
3585 /* --------------------------------------------------------------------------
3586 * Maintaining lists of bound variables and local definitions, for
3587 * dependency and scope analysis.
3588 * ------------------------------------------------------------------------*/
3590 static List bounds; /* list of lists of bound vars */
3591 static List bindings; /* list of lists of binds in scope */
3592 static List depends; /* list of lists of dependents */
3594 /* bounds :: [[Var]] -- var equality used on Vars */
3595 /* bindings :: [[([Var],?)]] -- var equality used on Vars */
3596 /* depends :: [[Var]] -- pointer equality used on Vars */
3598 #define saveBvars() hd(bounds) /* list of bvars in current scope */
3599 #define restoreBvars(bs) hd(bounds)=bs /* restore list of bound variables */
3601 static Cell local bindPat(line,p) /* add new bound vars for pattern */
3605 p = checkPat(line,p);
3606 hd(bounds) = revOnto(patVars,hd(bounds));
3610 static Void local bindPats(line,ps) /* add new bound vars for patterns */
3614 map1Over(checkPat,line,ps);
3615 hd(bounds) = revOnto(patVars,hd(bounds));
3618 /* --------------------------------------------------------------------------
3619 * Before processing value and type signature declarations, all data and
3620 * type definitions have been processed so that:
3621 * - all valid type constructors (with their arities) are known.
3622 * - all valid constructor functions (with their arities and types) are
3625 * The result of parsing a list of value declarations is a list of Eqns:
3626 * Eqn ::= (SIGDECL,(Line,[Var],type))
3627 * | (FIXDECL,(Line,[Op],SyntaxInt))
3629 * The ordering of the equations in this list is the reverse of the original
3630 * ordering in the script parsed. This is a consequence of the structure of
3631 * the parser ... but also turns out to be most convenient for the static
3634 * As the first stage of the static analysis of value declarations, each
3635 * list of Eqns is converted to a list of Bindings. As part of this
3637 * - The ordering of the list of Bindings produced is the same as in the
3639 * - When a variable (function) is defined over a number of lines, all
3640 * of the definitions should appear together and each should give the
3641 * same arity to the variable being defined.
3642 * - No variable can have more than one definition.
3643 * - For pattern bindings:
3644 * - Each lhs is a valid pattern/function lhs, all constructor functions
3645 * have been defined and are used with the correct number of arguments.
3646 * - Each lhs contains no repeated pattern variables.
3647 * - Each equation defines at least one variable (e.g. True = False is
3649 * - Types appearing in type signatures are well formed:
3650 * - Type constructors used are defined and used with correct number
3652 * - type variables are replaced by offsets, type constructor names
3654 * - Every variable named in a type signature declaration is defined by
3655 * one or more equations elsewhere in the script.
3656 * - No variable has more than one type declaration.
3657 * - Similar properties for fixity declarations.
3659 * ------------------------------------------------------------------------*/
3661 #define bindingAttr(b) fst(snd(b)) /* type(s)/fixity(ies) for binding */
3662 #define fbindAlts(b) snd(snd(b)) /* alternatives for function binding*/
3664 static List local extractSigdecls(es) /* Extract the SIGDECLS from list */
3665 List es; { /* of equations */
3666 List sigdecls = NIL; /* :: [(Line,[Var],Type)] */
3668 for(; nonNull(es); es=tl(es)) {
3669 if (fst(hd(es))==SIGDECL) { /* type-declaration? */
3670 Pair sig = snd(hd(es));
3671 Int line = intOf(fst3(sig));
3672 List vs = snd3(sig);
3673 for(; nonNull(vs); vs=tl(vs)) {
3674 if (isQualIdent(hd(vs))) {
3675 ERRMSG(line) "Type signature for qualified variable \"%s\" is not allowed",
3680 sigdecls = cons(sig,sigdecls); /* discard SIGDECL tag*/
3686 static List local extractFixdecls(es) /* Extract the FIXDECLS from list */
3687 List es; { /* of equations */
3688 List fixdecls = NIL; /* :: [(Line,SyntaxInt,[Op])] */
3690 for(; nonNull(es); es=tl(es)) {
3691 if (fst(hd(es))==FIXDECL) { /* fixity declaration?*/
3692 fixdecls = cons(snd(hd(es)),fixdecls); /* discard FIXDECL tag*/
3698 static List local extractBindings(ds) /* extract untyped bindings from */
3699 List ds; { /* given list of equations */
3700 Cell lastVar = NIL; /* = var def'd in last eqn (if any)*/
3701 Int lastArity = 0; /* = number of args in last defn */
3702 List bs = NIL; /* :: [Binding] */
3704 for(; nonNull(ds); ds=tl(ds)) {
3706 if (fst(d)==FUNBIND) { /* Function bindings */
3707 Cell rhs = snd(snd(d));
3708 Int line = rhsLine(rhs);
3709 Cell lhs = fst(snd(d));
3710 Cell v = getHead(lhs);
3711 Cell newAlt = pair(getArgs(lhs),rhs);
3713 internal("FUNBIND");
3715 if (nonNull(lastVar) && textOf(v)==textOf(lastVar)) {
3716 if (argCount!=lastArity) {
3717 ERRMSG(line) "Equations give different arities for \"%s\"",
3718 textToStr(textOf(v))
3721 fbindAlts(hd(bs)) = cons(newAlt,fbindAlts(hd(bs)));
3725 lastArity = argCount;
3726 notDefined(line,bs,v);
3727 bs = cons(pair(v,pair(NIL,singleton(newAlt))),bs);
3730 } else if (fst(d)==PATBIND) { /* Pattern bindings */
3731 Cell rhs = snd(snd(d));
3732 Int line = rhsLine(rhs);
3733 Cell pat = fst(snd(d));
3734 while (whatIs(pat)==ESIGN) {/* Move type annotations to rhs */
3735 Cell p = fst(snd(pat));
3736 fst(snd(pat)) = rhs;
3737 snd(snd(d)) = rhs = pat;
3738 fst(snd(d)) = pat = p;
3741 if (isVar(pat)) { /* Convert simple pattern bind to */
3742 notDefined(line,bs,pat);/* a function binding */
3743 bs = cons(pair(pat,pair(NIL,singleton(pair(NIL,rhs)))),bs);
3745 List vs = getPatVars(line,pat,NIL);
3747 ERRMSG(line) "No variables defined in lhs pattern"
3750 map2Proc(notDefined,line,bs,vs);
3751 bs = cons(pair(vs,pair(NIL,snd(d))),bs);
3759 static List local getPatVars(line,p,vs) /* Find list of variables bound in */
3760 Int line; /* pattern p */
3763 switch (whatIs(p)) {
3765 vs = getPatVars(line,arg(p),vs);
3768 return vs; /* Ignore head of application */
3770 case CONFLDS : { List pfs = snd(snd(p));
3771 for (; nonNull(pfs); pfs=tl(pfs)) {
3772 if (isVar(hd(pfs))) {
3773 vs = addPatVar(line,hd(pfs),vs);
3775 vs = getPatVars(line,snd(hd(pfs)),vs);
3781 case FINLIST : { List ps = snd(p);
3782 for (; nonNull(ps); ps=tl(ps)) {
3783 vs = getPatVars(line,hd(ps),vs);
3788 case ESIGN : return getPatVars(line,fst(snd(p)),vs);
3793 case INFIX : return getPatVars(line,snd(p),vs);
3795 case ASPAT : return addPatVar(line,fst(snd(p)),
3796 getPatVars(line,snd(snd(p)),vs));
3799 case VAROPCELL : return addPatVar(line,p,vs);
3809 case WILDCARD : return vs;
3811 default : internal("getPatVars");
3816 static List local addPatVar(line,v,vs) /* Add var to list of previously */
3817 Int line; /* encountered variables */
3820 if (varIsMember(textOf(v),vs)) {
3821 ERRMSG(line) "Repeated use of variable \"%s\" in pattern binding",
3822 textToStr(textOf(v))
3828 static List local eqnsToBindings(es,ts,cs,ps)
3829 List es; /* Convert list of equations to */
3830 List ts; /* list of typed bindings */
3833 List bs = extractBindings(es);
3834 map1Proc(addSigdecl,bs,extractSigdecls(es));
3835 map4Proc(addFixdecl,bs,ts,cs,ps,extractFixdecls(es));
3839 static Void local notDefined(line,bs,v)/* check if name already defined in */
3840 Int line; /* list of bindings */
3843 if (nonNull(findBinding(textOf(v),bs))) {
3844 ERRMSG(line) "\"%s\" multiply defined", textToStr(textOf(v))
3849 static Cell local findBinding(t,bs) /* look for binding for variable t */
3850 Text t; /* in list of bindings bs */
3852 for (; nonNull(bs); bs=tl(bs)) {
3853 if (isVar(fst(hd(bs)))) { /* function-binding? */
3854 if (textOf(fst(hd(bs)))==t) {
3857 } else if (nonNull(varIsMember(t,fst(hd(bs))))){/* pattern-binding?*/
3864 static Cell local getAttr(bs,v) /* Locate type/fixity attribute */
3865 List bs; /* for variable v in bindings bs */
3868 Cell b = findBinding(t,bs);
3870 if (isNull(b)) { /* No binding */
3872 } else if (isVar(fst(b))) { /* func binding? */
3873 if (isNull(bindingAttr(b))) {
3874 bindingAttr(b) = pair(NIL,NIL);
3876 return bindingAttr(b);
3877 } else { /* pat binding? */
3879 List as = bindingAttr(b);
3882 bindingAttr(b) = as = replicate(length(vs),NIL);
3885 while (nonNull(vs) && t!=textOf(hd(vs))) {
3891 internal("getAttr");
3892 } else if (isNull(hd(as))) {
3893 hd(as) = pair(NIL,NIL);
3899 static Void local addSigdecl(bs,sigdecl)/* add type information to bindings*/
3900 List bs; /* :: [Binding] */
3901 Cell sigdecl; { /* :: (Line,[Var],Type) */
3902 Int l = intOf(fst3(sigdecl));
3903 List vs = snd3(sigdecl);
3904 Type type = checkSigType(l,"type declaration",hd(vs),thd3(sigdecl));
3906 for (; nonNull(vs); vs=tl(vs)) {
3908 Pair attr = getAttr(bs,v);
3910 ERRMSG(l) "Missing binding for variable \"%s\" in type signature",
3911 textToStr(textOf(v))
3913 } else if (nonNull(fst(attr))) {
3914 ERRMSG(l) "Repeated type signature for \"%s\"",
3915 textToStr(textOf(v))
3922 static Void local addFixdecl(bs,ts,cs,ps,fixdecl)
3928 Int line = intOf(fst3(fixdecl));
3929 List ops = snd3(fixdecl);
3930 Cell sy = thd3(fixdecl);
3932 for (; nonNull(ops); ops=tl(ops)) {
3934 Text t = textOf(op);
3935 Cell attr = getAttr(bs,op);
3936 if (nonNull(attr)) { /* Found name in binding? */
3937 if (nonNull(snd(attr))) {
3941 } else { /* Look in tycons, classes, prims */
3946 for (; isNull(n) && nonNull(ts1); ts1=tl(ts1)) { /* tycons */
3948 if (tycon(tc).what==DATATYPE || tycon(tc).what==NEWTYPE) {
3949 n = nameIsMember(t,tycon(tc).defn);
3952 for (; isNull(n) && nonNull(cs1); cs1=tl(cs1)) { /* classes */
3953 n = nameIsMember(t,cclass(hd(cs1)).members);
3955 for (; isNull(n) && nonNull(ps1); ps1=tl(ps1)) { /* prims */
3956 n = nameIsMember(t,hd(ps1));
3961 } else if (name(n).syntax!=NO_SYNTAX) {
3964 name(n).syntax = intOf(sy);
3969 static Void local dupFixity(line,t) /* Report repeated fixity decl */
3973 "Repeated fixity declaration for operator \"%s\"", textToStr(t)
3977 static Void local missFixity(line,t) /* Report missing op for fixity */
3981 "Cannot find binding for operator \"%s\" in fixity declaration",
3986 /* --------------------------------------------------------------------------
3987 * Dealing with infix operators:
3989 * Expressions involving infix operators or unary minus are parsed as
3990 * elements of the following type:
3992 * data InfixExp = Only Exp | Neg InfixExp | Infix InfixExp Op Exp
3994 * (The algorithms here do not assume that negation can be applied only once,
3995 * i.e., that - - x is a syntax error, as required by the Haskell report.
3996 * Instead, that restriction is captured by the grammar itself, given above.)
3998 * There are rules of precedence and grouping, expressed by two functions:
4000 * prec :: Op -> Int; assoc :: Op -> Assoc (Assoc = {L, N, R})
4002 * InfixExp values are rearranged accordingly when a complete expression
4003 * has been read using a simple shift-reduce parser whose result may be taken
4004 * to be a value of the following type:
4006 * data Exp = Atom Int | Negate Exp | Apply Op Exp Exp | Error String
4008 * The machine on which this parser is based can be defined as follows:
4010 * tidy :: InfixExp -> [(Op,Exp)] -> Exp
4011 * tidy (Only a) [] = a
4012 * tidy (Only a) ((o,b):ss) = tidy (Only (Apply o a b)) ss
4013 * tidy (Infix a o b) [] = tidy a [(o,b)]
4014 * tidy (Infix a o b) ((p,c):ss)
4015 * | shift o p = tidy a ((o,b):(p,c):ss)
4016 * | red o p = tidy (Infix a o (Apply p b c)) ss
4017 * | ambig o p = Error "ambiguous use of operators"
4018 * tidy (Neg e) [] = tidy (tidyNeg e) []
4019 * tidy (Neg e) ((o,b):ss)
4020 * | nshift o = tidy (Neg (underNeg o b e)) ss
4021 * | nred o = tidy (tidyNeg e) ((o,b):ss)
4022 * | nambig o = Error "illegal use of negation"
4024 * At each stage, the parser can either shift, reduce, accept, or error.
4025 * The transitions when dealing with juxtaposed operators o and p are
4026 * determined by the following rules:
4028 * shift o p = (prec o > prec p)
4029 * || (prec o == prec p && assoc o == L && assoc p == L)
4031 * red o p = (prec o < prec p)
4032 * || (prec o == prec p && assoc o == R && assoc p == R)
4034 * ambig o p = (prec o == prec p)
4035 * && (assoc o == N || assoc p == N || assoc o /= assoc p)
4037 * The transitions when dealing with juxtaposed unary minus and infix
4038 * operators are as follows. The precedence of unary minus (infixl 6) is
4039 * hardwired in to these definitions, as it is to the definitions of the
4040 * Haskell grammar in the official report.
4042 * nshift o = (prec o > 6)
4043 * nred o = (prec o < 6) || (prec o == 6 && assoc o == L)
4044 * nambig o = prec o == 6 && (assoc o == R || assoc o == N)
4046 * An InfixExp of the form (Neg e) means negate the last thing in
4047 * the InfixExp e; we can force this negation using:
4049 * tidyNeg :: OpExp -> OpExp
4050 * tidyNeg (Only e) = Only (Negate e)
4051 * tidyNeg (Infix a o b) = Infix a o (Negate b)
4052 * tidyNeg (Neg e) = tidyNeg (tidyNeg e)
4054 * On the other hand, if we want to sneak application of an infix operator
4055 * under a negation, then we use:
4057 * underNeg :: Op -> Exp -> OpExp -> OpExp
4058 * underNeg o b (Only e) = Only (Apply o e b)
4059 * underNeg o b (Neg e) = Neg (underNeg o b e)
4060 * underNeg o b (Infix e p f) = Infix e p (Apply o f b)
4062 * As a concession to efficiency, we lower the number of calls to syntaxOf
4063 * by keeping track of the values of sye, sys throughout the process. The
4064 * value APPLIC is used to indicate that the syntax value is unknown.
4065 * ------------------------------------------------------------------------*/
4067 static Cell local tidyInfix(line,e) /* Convert infixExp to Exp */
4069 Cell e; { /* :: OpExp */
4070 Cell s = NIL; /* :: [(Op,Exp)] */
4071 Syntax sye = APPLIC; /* Syntax of op in e (init unknown)*/
4072 Syntax sys = APPLIC; /* Syntax of op in s (init unknown)*/
4075 while (fst(d)!=ONLY) { /* Attach fixities to operators */
4079 fun(fun(d)) = attachFixity(line,fun(fun(d)));
4085 switch (whatIs(e)) {
4086 case ONLY : e = snd(e);
4087 while (nonNull(s)) {
4088 Cell next = arg(fun(s));
4090 fun(fun(s)) = snd(fun(fun(s)));
4096 case NEG : if (nonNull(s)) {
4097 if (sys==APPLIC) { /* calculate sys */
4098 sys = intOf(fst(fun(fun(s))));
4101 if (precOf(sys)==UMINUS_PREC && /* nambig */
4102 assocOf(sys)!=UMINUS_ASSOC) {
4104 "Ambiguous use of unary minus with \""
4105 ETHEN ERREXPR(snd(fun(fun(s))));
4110 if (precOf(sys)>UMINUS_PREC) { /* nshift */
4114 while (whatIs(e1)==NEG)
4116 arg(fun(t)) = arg(e1);
4117 fun(fun(t)) = snd(fun(fun(t)));
4124 /* Intentional fall-thru for nreduce and isNull(s) */
4126 { Cell prev = e; /* e := tidyNeg e */
4127 Cell temp = arg(prev);
4129 for (; whatIs(temp)==NEG; nneg++) {
4130 fun(prev) = nameNegate;
4134 if (isInt(arg(temp))) { /* special cases */
4135 if (nneg&1) /* for literals */
4136 arg(temp) = mkInt(-intOf(arg(temp)));
4138 else if (isFloat(arg(temp))) {
4140 arg(temp) = floatNegate(arg(temp));
4141 //mkFloat(-floatOf(arg(temp)));
4144 fun(prev) = nameNegate;
4145 arg(prev) = arg(temp);
4152 default : if (isNull(s)) {/* Move operation onto empty stack */
4153 Cell next = arg(fun(e));
4160 else { /* deal with pair of operators */
4162 if (sye==APPLIC) { /* calculate sys and sye */
4163 sye = intOf(fst(fun(fun(e))));
4166 sys = intOf(fst(fun(fun(s))));
4169 if (precOf(sye)==precOf(sys) && /* ambig */
4170 (assocOf(sye)!=assocOf(sys) ||
4171 assocOf(sye)==NON_ASS)) {
4172 ERRMSG(line) "Ambiguous use of operator \""
4173 ETHEN ERREXPR(snd(fun(fun(e))));
4174 ERRTEXT "\" with \""
4175 ETHEN ERREXPR(snd(fun(fun(s))));
4180 if (precOf(sye)>precOf(sys) || /* shift */
4181 (precOf(sye)==precOf(sys) &&
4182 assocOf(sye)==LEFT_ASS &&
4183 assocOf(sys)==LEFT_ASS)) {
4184 Cell next = arg(fun(e));
4192 Cell next = arg(fun(s));
4193 arg(fun(s)) = arg(e);
4194 fun(fun(s)) = snd(fun(fun(s)));
4205 static Pair local attachFixity(line,op) /* Attach fixity to operator in an */
4206 Int line; /* infix expression */
4208 Syntax sy = DEF_OPSYNTAX;
4210 switch (whatIs(op)) {
4212 case VARIDCELL : if ((sy=lookupSyntax(textOf(op)))==NO_SYNTAX) {
4213 Name n = findName(textOf(op));
4215 ERRMSG(line) "Undefined variable \"%s\"",
4216 textToStr(textOf(op))
4225 case CONIDCELL : sy = syntaxOf(op = conDefined(line,op));
4228 case QUALIDENT : { Name n = findQualName(op);
4234 "Undefined qualified variable \"%s\"",
4244 return pair(mkInt(sy),op); /* Pair fixity with (possibly) */
4245 /* translated operator */
4248 static Syntax local lookupSyntax(t) /* Try to find fixity for var in */
4249 Text t; { /* enclosing bindings */
4250 List bounds1 = bounds;
4251 List bindings1 = bindings;
4253 while (nonNull(bindings1)) {
4254 if (nonNull(varIsMember(t,hd(bounds1)))) {
4255 return DEF_OPSYNTAX;
4257 Cell b = findBinding(t,hd(bindings1));
4259 Cell a = fst(snd(b));
4260 if (isVar(fst(b))) { /* Function binding */
4261 if (nonNull(a) && nonNull(snd(a))) {
4262 return intOf(snd(a));
4264 } else { /* Pattern binding */
4266 while (nonNull(vs) && nonNull(a)) {
4267 if (t==textOf(hd(vs))) {
4268 if (nonNull(hd(a)) && isInt(snd(hd(a)))) {
4269 return intOf(snd(hd(a)));
4277 return DEF_OPSYNTAX;
4280 bounds1 = tl(bounds1);
4281 bindings1 = tl(bindings1);
4286 /* --------------------------------------------------------------------------
4287 * To facilitate dependency analysis, lists of bindings are temporarily
4288 * augmented with an additional field, which is used in two ways:
4289 * - to build the `adjacency lists' for the dependency graph. Represented by
4290 * a list of pointers to other bindings in the same list of bindings.
4291 * - to hold strictly positive integer values (depth first search numbers) of
4292 * elements `on the stack' during the strongly connected components search
4293 * algorithm, or a special value mkInt(0), once the binding has been added
4294 * to a particular strongly connected component.
4296 * Using this extra field, the type of each list of declarations during
4297 * dependency analysis is [Binding'] where:
4299 * Binding' ::= (Var, (Attr, (Dep, [Alt]))) -- function binding
4300 * | ([Var], ([Attr], (Dep, (Pat,Rhs)))) -- pattern binding
4302 * ------------------------------------------------------------------------*/
4304 #define depVal(d) (fst(snd(snd(d)))) /* Access to dependency information*/
4306 static List local dependencyAnal(bs) /* Separate lists of bindings into */
4307 List bs; { /* mutually recursive groups in */
4308 /* order of dependency */
4309 mapProc(addDepField,bs); /* add extra field for dependents */
4310 mapProc(depBinding,bs); /* find dependents of each binding */
4311 bs = bscc(bs); /* sort to strongly connected comps*/
4312 mapProc(remDepField,bs); /* remove dependency info field */
4316 static List local topDependAnal(bs) /* Like dependencyAnal(), but at */
4317 List bs; { /* top level, reporting on progress*/
4321 setGoal("Dependency analysis",(Target)(length(bs)));
4323 mapProc(addDepField,bs); /* add extra field for dependents */
4324 for (xs=bs; nonNull(xs); xs=tl(xs)) {
4325 emptySubstitution();
4327 soFar((Target)(i++));
4329 bs = bscc(bs); /* sort to strongly connected comps */
4330 mapProc(remDepField,bs); /* remove dependency info field */
4335 static Void local addDepField(b) /* add extra field to binding to */
4336 Cell b; { /* hold list of dependents */
4337 snd(snd(b)) = pair(NIL,snd(snd(b)));
4340 static Void local remDepField(bs) /* remove dependency field from */
4341 List bs; { /* list of bindings */
4342 mapProc(remDepField1,bs);
4345 static Void local remDepField1(b) /* remove dependency field from */
4346 Cell b; { /* single binding */
4347 snd(snd(b)) = snd(snd(snd(b)));
4350 static Void local clearScope() { /* initialise dependency scoping */
4356 static Void local withinScope(bs) /* Enter scope of bindings bs */
4358 bounds = cons(NIL,bounds);
4359 bindings = cons(bs,bindings);
4360 depends = cons(NIL,depends);
4363 static Void local leaveScope() { /* Leave scope of last withinScope */
4364 List bs = hd(bindings); /* Remove fixity info from binds */
4365 Bool toplevel = isNull(tl(bindings));
4366 for (; nonNull(bs); bs=tl(bs)) {
4368 if (isVar(fst(b))) { /* Variable binding */
4369 Cell a = fst(snd(b));
4372 saveSyntax(fst(b),snd(a));
4374 fst(snd(b)) = fst(a);
4376 } else { /* Pattern binding */
4378 List as = fst(snd(b));
4379 while (nonNull(vs) && nonNull(as)) {
4380 if (isPair(hd(as))) {
4382 saveSyntax(hd(vs),snd(hd(as)));
4384 hd(as) = fst(hd(as));
4391 bounds = tl(bounds);
4392 bindings = tl(bindings);
4393 depends = tl(depends);
4396 static Void local saveSyntax(v,sy) /* Save syntax of top-level var */
4397 Cell v; /* in corresponding Name */
4399 Name n = findName(textOf(v));
4400 if (isNull(n) || name(n).syntax!=NO_SYNTAX) {
4401 internal("saveSyntax");
4404 name(n).syntax = intOf(sy);
4408 /* --------------------------------------------------------------------------
4409 * As a side effect of the dependency analysis we also make the following
4411 * - Each lhs is a valid pattern/function lhs, all constructor functions
4412 * have been defined and are used with the correct number of arguments.
4413 * - No lhs contains repeated pattern variables.
4414 * - Expressions used on the rhs of an eqn should be well formed. This
4416 * - Checking for valid patterns (including repeated vars) in lambda,
4417 * case, and list comprehension expressions.
4418 * - Recursively checking local lists of equations.
4419 * - No free (i.e. unbound) variables are used in the declaration list.
4420 * ------------------------------------------------------------------------*/
4422 static Void local depBinding(b) /* find dependents of binding */
4424 Cell defpart = snd(snd(snd(b))); /* definition part of binding */
4428 if (isVar(fst(b))) { /* function-binding? */
4429 mapProc(depAlt,defpart);
4430 if (isNull(fst(snd(b)))) { /* Save dep info if no type sig */
4431 fst(snd(b)) = pair(ap(IMPDEPS,hd(depends)),NIL);
4432 } else if (isNull(fst(fst(snd(b))))) {
4433 fst(fst(snd(b))) = ap(IMPDEPS,hd(depends));
4435 } else { /* pattern-binding? */
4436 Int line = rhsLine(snd(defpart));
4439 fst(defpart) = checkPat(line,fst(defpart));
4440 depRhs(snd(defpart));
4442 if (nonNull(hd(btyvars))) {
4444 "Sorry, no type variables are allowed in pattern binding type annotations"
4448 fst(defpart) = applyBtyvs(fst(defpart));
4450 depVal(b) = hd(depends);
4453 static Void local depDefaults(c) /* dependency analysis on defaults */
4454 Class c; { /* from class definition */
4455 depClassBindings(cclass(c).defaults);
4458 static Void local depInsts(in) /* dependency analysis on instance */
4459 Inst in; { /* bindings */
4460 depClassBindings(inst(in).implements);
4463 static Void local depClassBindings(bs) /* dependency analysis on list of */
4464 List bs; { /* bindings, possibly containing */
4465 for (; nonNull(bs); bs=tl(bs)) { /* NIL bindings ... */
4466 if (nonNull(hd(bs))) { /* No need to add extra field for */
4467 mapProc(depAlt,snd(hd(bs)));/* dependency information... */
4472 static Void local depAlt(a) /* Find dependents of alternative */
4474 List obvs = saveBvars(); /* Save list of bound variables */
4476 bindPats(rhsLine(snd(a)),fst(a)); /* add new bound vars for patterns */
4477 depRhs(snd(a)); /* find dependents of rhs */
4478 fst(a) = applyBtyvs(fst(a));
4479 restoreBvars(obvs); /* restore original list of bvars */
4482 static Void local depRhs(r) /* Find dependents of rhs */
4484 switch (whatIs(r)) {
4485 case GUARDED : mapProc(depGuard,snd(r));
4488 case LETREC : fst(snd(r)) = eqnsToBindings(fst(snd(r)),NIL,NIL,NIL);
4489 withinScope(fst(snd(r)));
4490 fst(snd(r)) = dependencyAnal(fst(snd(r)));
4491 hd(depends) = fst(snd(r));
4492 depRhs(snd(snd(r)));
4496 case RSIGN : snd(snd(r)) = checkPatType(rhsLine(fst(snd(r))),
4498 rhsExpr(fst(snd(r))),
4500 depRhs(fst(snd(r)));
4503 default : snd(r) = depExpr(intOf(fst(r)),snd(r));
4508 static Void local depGuard(g) /* find dependents of single guarded*/
4509 Cell g; { /* expression */
4510 depPair(intOf(fst(g)),snd(g));
4513 static Cell local depExpr(line,e) /* find dependents of expression */
4516 //Printf( "\n\n"); print(e,100); Printf("\n");
4517 //printExp(stdout,e);
4518 switch (whatIs(e)) {
4521 case VAROPCELL : return depVar(line,e);
4524 case CONOPCELL : return conDefined(line,e);
4526 case QUALIDENT : if (isQVar(e)) {
4527 return depQVar(line,e);
4528 } else { /* QConOrConOp */
4529 return conDefined(line,e);
4532 case INFIX : return depExpr(line,tidyInfix(line,snd(e)));
4535 case RECSEL : break;
4537 case AP : if (isAp(e) && isAp(fun(e)) && isExt(fun(fun(e)))) {
4538 return depRecord(line,e);
4544 arg(a) = depExpr(line,arg(a));
4547 fun(a) = depExpr(line,fun(a));
4551 case AP : depPair(line,e);
4565 case INTCELL : break;
4567 case COND : depTriple(line,snd(e));
4570 case FINLIST : map1Over(depExpr,line,snd(e));
4573 case LETREC : fst(snd(e)) = eqnsToBindings(fst(snd(e)),NIL,NIL,NIL);
4574 withinScope(fst(snd(e)));
4575 fst(snd(e)) = dependencyAnal(fst(snd(e)));
4576 hd(depends) = fst(snd(e));
4577 snd(snd(e)) = depExpr(line,snd(snd(e)));
4581 case LAMBDA : depAlt(snd(e));
4584 case DOCOMP : /* fall-thru */
4585 case COMP : depComp(line,snd(e),snd(snd(e)));
4588 case ESIGN : fst(snd(e)) = depExpr(line,fst(snd(e)));
4589 snd(snd(e)) = checkSigType(line,
4595 case CASE : fst(snd(e)) = depExpr(line,fst(snd(e)));
4596 map1Proc(depCaseAlt,line,snd(snd(e)));
4599 case CONFLDS : depConFlds(line,e,FALSE);
4602 case UPDFLDS : depUpdFlds(line,e);
4606 case WITHEXP : depWith(line,e);
4610 case ASPAT : ERRMSG(line) "Illegal `@' in expression"
4613 case LAZYPAT : ERRMSG(line) "Illegal `~' in expression"
4616 case WILDCARD : ERRMSG(line) "Illegal `_' in expression"
4620 case EXT : ERRMSG(line) "Illegal application of record"
4624 default : internal("depExpr");
4629 static Void local depPair(line,e) /* find dependents of pair of exprs*/
4632 fst(e) = depExpr(line,fst(e));
4633 snd(e) = depExpr(line,snd(e));
4636 static Void local depTriple(line,e) /* find dependents of triple exprs */
4639 fst3(e) = depExpr(line,fst3(e));
4640 snd3(e) = depExpr(line,snd3(e));
4641 thd3(e) = depExpr(line,thd3(e));
4644 static Void local depComp(l,e,qs) /* find dependents of comprehension*/
4649 fst(e) = depExpr(l,fst(e));
4653 switch (whatIs(q)) {
4654 case FROMQUAL : { List obvs = saveBvars();
4655 snd(snd(q)) = depExpr(l,snd(snd(q)));
4657 fst(snd(q)) = bindPat(l,fst(snd(q)));
4659 fst(snd(q)) = applyBtyvs(fst(snd(q)));
4664 case QWHERE : snd(q) = eqnsToBindings(snd(q),NIL,NIL,NIL);
4665 withinScope(snd(q));
4666 snd(q) = dependencyAnal(snd(q));
4667 hd(depends) = snd(q);
4672 case DOQUAL : /* fall-thru */
4673 case BOOLQUAL : snd(q) = depExpr(l,snd(q));
4680 static Void local depCaseAlt(line,a) /* Find dependents of case altern. */
4683 List obvs = saveBvars(); /* Save list of bound variables */
4685 fst(a) = bindPat(line,fst(a)); /* Add new bound vars for pats */
4686 depRhs(snd(a)); /* Find dependents of rhs */
4687 fst(a) = applyBtyvs(fst(a));
4688 restoreBvars(obvs); /* Restore original list of bvars */
4691 static Cell local depVar(line,e) /* Register occurrence of variable */
4694 List bounds1 = bounds;
4695 List bindings1 = bindings;
4696 List depends1 = depends;
4700 while (nonNull(bindings1)) {
4701 n = varIsMember(t,hd(bounds1)); /* look for t in bound variables */
4705 n = findBinding(t,hd(bindings1)); /* look for t in var bindings */
4707 if (!cellIsMember(n,hd(depends1))) {
4708 hd(depends1) = cons(n,hd(depends1));
4710 return (isVar(fst(n)) ? fst(n) : e);
4713 bounds1 = tl(bounds1);
4714 bindings1 = tl(bindings1);
4715 depends1 = tl(depends1);
4718 if (isNull(n=findName(t))) { /* check global definitions */
4719 ERRMSG(line) "Undefined variable \"%s\"", textToStr(t)
4723 /* Later phases of the system cannot cope if we resolve references
4724 * to unprocessed objects too early. This is the main reason that
4725 * we cannot cope with recursive modules at the moment.
4730 static Cell local depQVar(line,e)/* register occurrence of qualified variable */
4733 Name n = findQualName(e);
4734 if (isNull(n)) { /* check global definitions */
4735 ERRMSG(line) "Undefined qualified variable \"%s\"", identToStr(e)
4738 if (name(n).mod != currentModule) {
4741 if (fst(e) == VARIDCELL) {
4742 e = mkVar(qtextOf(e));
4744 e = mkVarop(qtextOf(e));
4746 return depVar(line,e);
4749 static Void local depConFlds(line,e,isP)/* check construction using fields */
4753 Name c = conDefined(line,fst(snd(e)));
4754 if (isNull(snd(snd(e))) ||
4755 nonNull(cellIsMember(c,depFields(line,e,snd(snd(e)),isP)))) {
4758 ERRMSG(line) "Constructor \"%s\" does not have selected fields in ",
4759 textToStr(name(c).text)
4764 if (!isP && isPair(name(c).defn)) { /* Check that banged fields defined*/
4765 List scs = fst(name(c).defn); /* List of strict components */
4766 Type t = name(c).type;
4767 Int a = userArity(c);
4768 List fs = snd(snd(e));
4770 if (isPolyType(t)) { /* Find tycon that c belongs to */
4773 if (isQualType(t)) {
4776 if (whatIs(t)==CDICTS) {
4785 for (ss=tycon(t).defn; hasCfun(ss); ss=tl(ss)) {
4787 /* Now we know the tycon t that c belongs to, and the corresponding
4788 * list of selectors for that type, ss. Now we have to check that
4789 * each of the fields identified by scs appears in fs, using ss to
4790 * cross reference, and convert integers to selector names.
4792 for (; nonNull(scs); scs=tl(scs)) {
4793 Int i = intOf(hd(scs));
4795 for (; nonNull(ss1); ss1=tl(ss1)) {
4796 List cns = name(hd(ss1)).defn;
4797 for (; nonNull(cns); cns=tl(cns)) {
4798 if (fst(hd(cns))==c) {
4802 if (nonNull(cns) && intOf(snd(hd(cns)))==i) {
4807 internal("depConFlds");
4811 for (; nonNull(fs1) && s!=fst(hd(fs1)); fs1=tl(fs1)) {
4814 ERRMSG(line) "Construction does not define strict field"
4816 ERRTEXT "\nExpression : " ETHEN ERREXPR(e);
4817 ERRTEXT "\nField : " ETHEN ERREXPR(s);
4826 static Void local depUpdFlds(line,e) /* check update using fields */
4829 if (isNull(thd3(snd(e)))) {
4830 ERRMSG(line) "Empty field list in update"
4833 fst3(snd(e)) = depExpr(line,fst3(snd(e)));
4834 snd3(snd(e)) = depFields(line,e,thd3(snd(e)),FALSE);
4837 static List local depFields(l,e,fs,isP) /* check field binding list */
4845 for (; nonNull(fs); fs=tl(fs)) { /* for each field binding */
4849 if (isVar(fb)) { /* expand var to var = var */
4850 h98DoesntSupport(l,"missing field bindings");
4851 fb = hd(fs) = pair(fb,fb);
4854 s = findQualName(fst(fb)); /* check for selector */
4855 if (nonNull(s) && isSfun(s)) {
4858 ERRMSG(l) "\"%s\" is not a selector function/field name",
4859 textToStr(textOf(fst(fb)))
4863 if (isNull(ss)) { /* for first named selector */
4864 List scs = name(s).defn; /* calculate list of constructors */
4865 for (; nonNull(scs); scs=tl(scs)) {
4866 cs = cons(fst(hd(scs)),cs);
4868 ss = singleton(s); /* initialize selector list */
4869 } else { /* for subsequent selectors */
4870 List ds = cs; /* intersect constructor lists */
4871 for (cs=NIL; nonNull(ds); ) {
4872 List scs = name(s).defn;
4873 while (nonNull(scs) && fst(hd(scs))!=hd(ds)) {
4886 if (cellIsMember(s,ss)) { /* check for repeated uses */
4887 ERRMSG(l) "Repeated field name \"%s\" in field list",
4888 textToStr(name(s).text)
4894 if (isNull(cs)) { /* Are there any matching constrs? */
4895 ERRMSG(l) "No constructor has all of the fields specified in "
4901 snd(fb) = (isP ? checkPat(l,snd(fb)) : depExpr(l,snd(fb)));
4907 static Void local depWith(line,e) /* check with using fields */
4910 fst(snd(e)) = depExpr(line,fst(snd(e)));
4911 snd(snd(e)) = depDwFlds(line,e,snd(snd(e)));
4914 static List local depDwFlds(l,e,fs)/* check field binding list */
4920 for (; nonNull(c); c=tl(c)) { /* for each field binding */
4921 snd(hd(c)) = depExpr(l,snd(hd(c)));
4928 static Cell local depRecord(line,e) /* find dependents of record and */
4929 Int line; /* sort fields into approp. order */
4930 Cell e; { /* to make construction and update */
4931 List exts = NIL; /* more efficient. */
4934 h98DoesntSupport(line,"extensible records");
4935 do { /* build up list of extensions */
4936 Text t = extText(fun(fun(r)));
4937 String s = textToStr(t);
4940 while (nonNull(nx) && strcmp(textToStr(extText(fun(fun(nx)))),s)>0) {
4944 if (nonNull(nx) && t==extText(fun(fun(nx)))) {
4945 ERRMSG(line) "Repeated label \"%s\" in record ", s
4951 exts = cons(fun(r),exts);
4953 tl(prev) = cons(fun(r),nx);
4955 extField(r) = depExpr(line,extField(r));
4957 } while (isAp(r) && isAp(fun(r)) && isExt(fun(fun(r))));
4958 r = depExpr(line,r);
4959 return revOnto(exts,r);
4964 /* --------------------------------------------------------------------------
4965 * Several parts of this program require an algorithm for sorting a list
4966 * of values (with some added dependency information) into a list of strongly
4967 * connected components in which each value appears before its dependents.
4969 * Each of these algorithms is obtained by parameterising a standard
4970 * algorithm in "scc.c" as shown below.
4971 * ------------------------------------------------------------------------*/
4973 #define SCC2 tcscc /* make scc algorithm for Tycons */
4974 #define LOWLINK tclowlink
4975 #define DEPENDS(c) (isTycon(c) ? tycon(c).kind : cclass(c).kinds)
4976 #define SETDEPENDS(c,v) if(isTycon(c)) tycon(c).kind=v; else cclass(c).kinds=v
4983 #define SCC bscc /* make scc algorithm for Bindings */
4984 #define LOWLINK blowlink
4985 #define DEPENDS(t) depVal(t)
4986 #define SETDEPENDS(c,v) depVal(c)=v
4993 /* --------------------------------------------------------------------------
4994 * Main static analysis:
4995 * ------------------------------------------------------------------------*/
4997 Void checkExp() { /* Top level static check on Expr */
4998 staticAnalysis(RESET);
4999 clearScope(); /* Analyse expression in the scope */
5000 withinScope(NIL); /* of no local bindings */
5001 inputExpr = depExpr(0,inputExpr);
5003 staticAnalysis(RESET);
5006 #if EXPLAIN_INSTANCE_RESOLUTION
5007 Void checkContext(void) { /* Top level static check on Expr */
5010 staticAnalysis(RESET);
5011 clearScope(); /* Analyse expression in the scope */
5012 withinScope(NIL); /* of no local bindings */
5014 for (vs = NIL; nonNull(qs); qs=tl(qs)) {
5015 vs = typeVarsIn(hd(qs),NIL,NIL,vs);
5017 map2Proc(depPredExp,0,vs,inputContext);
5019 staticAnalysis(RESET);
5023 Void checkDefns ( Module thisModule ) { /* Top level static analysis */
5024 Text modName = module(thisModule).text;
5026 staticAnalysis(RESET);
5028 setCurrModule(thisModule);
5030 /* Resolve module references */
5031 mapProc(checkQualImport, module(thisModule).qualImports);
5032 mapProc(checkUnqualImport,unqualImports);
5033 /* Add "import Prelude" if there`s no explicit import */
5034 if (modName == textPrelPrim || modName == textPrelude) {
5036 } else if (isNull(cellAssoc(modulePrelude,unqualImports))
5037 && isNull(cellRevAssoc(modulePrelude,module(thisModule).qualImports))) {
5038 unqualImports = cons(pair(modulePrelude,DOTDOT),unqualImports);
5040 /* Every module implicitly contains "import qualified Prelude"
5042 module(thisModule).qualImports
5043 =cons(pair(mkCon(textPrelude),modulePrelude),
5044 module(thisModule).qualImports);
5046 mapProc(checkImportList, unqualImports);
5048 /* Note: there's a lot of side-effecting going on here, so
5049 don't monkey about with the order of operations here unless
5050 you know what you are doing */
5051 if (!combined) linkPreludeTC(); /* Get prelude tycons and classes */
5053 mapProc(checkTyconDefn,tyconDefns); /* validate tycon definitions */
5054 checkSynonyms(tyconDefns); /* check synonym definitions */
5055 mapProc(checkClassDefn,classDefns); /* process class definitions */
5056 mapProc(kindTCGroup,tcscc(tyconDefns,classDefns)); /* attach kinds */
5057 mapProc(visitClass,classDefns); /* check class hierarchy */
5058 mapProc(extendFundeps,classDefns); /* finish class definitions */
5059 /* (convenient if we do this after */
5060 /* calling `visitClass' so that we */
5061 /* know the class hierarchy is */
5064 mapProc(addMembers,classDefns); /* add definitions for member funs */
5066 if (!combined) linkPreludeCM(); /* Get prelude cfuns and mfuns */
5068 instDefns = rev(instDefns); /* process instance definitions */
5069 mapProc(checkInstDefn,instDefns);
5071 setCurrModule(thisModule);
5072 mapProc(addRSsigdecls,typeInDefns); /* add sigdecls for RESTRICTSYN */
5073 valDefns = eqnsToBindings(valDefns,tyconDefns,classDefns,/*primDefns*/NIL);
5074 mapProc(allNoPrevDef,valDefns); /* check against previous defns */
5075 mapProc(addDerivImp,derivedInsts); /* Add impls for derived instances */
5076 deriveContexts(derivedInsts); /* Calculate derived inst contexts */
5077 instDefns = appendOnto(instDefns,derivedInsts);
5078 checkDefaultDefns(); /* validate default definitions */
5080 mapProc(allNoPrevDef,valDefns); /* check against previous defns */
5082 if (!combined) linkPrimNames(); /* link primitive names */
5084 mapProc(checkForeignImport,foreignImports); /* check foreign imports */
5085 mapProc(checkForeignExport,foreignExports); /* check foreign exports */
5086 foreignImports = NIL;
5087 foreignExports = NIL;
5089 /* Every top-level name has now been created - so we can build the */
5090 /* export list. Note that this has to happen before dependency */
5091 /* analysis so that references to Prelude.foo will be resolved */
5092 /* when compiling the prelude. */
5093 module(thisModule).exports
5094 = checkExports ( module(thisModule).exports, thisModule );
5096 mapProc(checkTypeIn,typeInDefns); /* check restricted synonym defns */
5099 withinScope(valDefns);
5100 valDefns = topDependAnal(valDefns); /* top level dependency ordering */
5101 mapProc(depDefaults,classDefns); /* dep. analysis on class defaults */
5102 mapProc(depInsts,instDefns); /* dep. analysis on inst defns */
5105 /* ToDo: evalDefaults should match current evaluation module */
5106 evalDefaults = defaultDefns; /* Set defaults for evaluator */
5108 staticAnalysis(RESET);
5114 static Void local addRSsigdecls(pr) /* add sigdecls from TYPE ... IN ..*/
5116 List vs = snd(pr); /* get list of variables */
5117 for (; nonNull(vs); vs=tl(vs)) {
5118 if (fst(hd(vs))==SIGDECL) { /* find a sigdecl */
5119 valDefns = cons(hd(vs),valDefns); /* add to valDefns */
5120 hd(vs) = hd(snd3(snd(hd(vs)))); /* and replace with var */
5125 static Void local allNoPrevDef(b) /* ensure no previous bindings for*/
5126 Cell b; { /* variables in new binding */
5127 if (isVar(fst(b))) {
5128 noPrevDef(rhsLine(snd(hd(snd(snd(b))))),fst(b));
5130 Int line = rhsLine(snd(snd(snd(b))));
5131 map1Proc(noPrevDef,line,fst(b));
5135 static Void local noPrevDef(line,v) /* ensure no previous binding for */
5136 Int line; /* new variable */
5138 Name n = findName(textOf(v));
5141 n = newName(textOf(v),NIL);
5142 name(n).defn = PREDEFINED;
5143 } else if (name(n).defn!=PREDEFINED) {
5144 duplicateError(line,name(n).mod,name(n).text,"variable");
5146 name(n).line = line;
5149 static Void local duplicateErrorAux(line,mod,t,kind)/* report duplicate defn */
5154 if (mod == currentModule) {
5155 ERRMSG(line) "Repeated definition for %s \"%s\"", kind,
5159 ERRMSG(line) "Definition of %s \"%s\" clashes with import", kind,
5165 static Void local checkTypeIn(cvs) /* Check that vars in restricted */
5166 Pair cvs; { /* synonym are defined */
5170 for (; nonNull(vs); vs=tl(vs)) {
5171 if (isNull(findName(textOf(hd(vs))))) {
5172 ERRMSG(tycon(c).line)
5173 "No top level binding of \"%s\" for restricted synonym \"%s\"",
5174 textToStr(textOf(hd(vs))), textToStr(tycon(c).text)
5180 /* --------------------------------------------------------------------------
5181 * Haskell 98 compatibility tests:
5182 * ------------------------------------------------------------------------*/
5184 Bool h98Pred(allowArgs,pi) /* Check syntax of Hask98 predicate*/
5187 return isClass(getHead(pi)) && argCount==1 &&
5188 isOffset(getHead(arg(pi))) && (argCount==0 || allowArgs);
5191 Cell h98Context(allowArgs,ps) /* Check syntax of Hask98 context */
5194 for (; nonNull(ps); ps=tl(ps)) {
5195 if (!h98Pred(allowArgs,hd(ps))) {
5202 Void h98CheckCtxt(line,wh,allowArgs,ps,in)
5203 Int line; /* Report illegal context/predicate*/
5209 Cell pi = h98Context(allowArgs,ps);
5211 ERRMSG(line) "Illegal Haskell 98 class constraint in %s",wh ETHEN
5213 ERRTEXT "\n*** Instance : " ETHEN ERRPRED(inst(in).head);
5215 ERRTEXT "\n*** Constraint : " ETHEN ERRPRED(pi);
5216 if (nonNull(ps) && nonNull(tl(ps))) {
5217 ERRTEXT "\n*** Context : " ETHEN ERRCONTEXT(ps);
5225 Void h98CheckType(line,wh,e,t) /* Check for Haskell 98 type */
5234 if (isQualType(t)) {
5235 Cell pi = h98Context(TRUE,fst(snd(t)));
5237 ERRMSG(line) "Illegal Haskell 98 class constraint in %s",wh
5239 ERRTEXT "\n*** Expression : " ETHEN ERREXPR(e);
5240 ERRTEXT "\n*** Type : " ETHEN ERRTYPE(ty);
5248 Void h98DoesntSupport(line,wh) /* Report feature missing in H98 */
5252 ERRMSG(line) "Haskell 98 does not support %s", wh
5257 /* --------------------------------------------------------------------------
5258 * Static Analysis control:
5259 * ------------------------------------------------------------------------*/
5261 Void staticAnalysis(what)
5264 case RESET : cfunSfuns = NIL;
5277 case MARK : mark(daSccs);
5292 case POSTPREL: break;
5294 case PREPREL : staticAnalysis(RESET);
5296 extKind = pair(STAR,pair(ROW,ROW));
5301 /*-------------------------------------------------------------------------*/