![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to parse.sml CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [Research Unix] / researchv10no / cmd / sml / src / parse|
Return to parse.sml CVS log | Up to [Research Unix] / researchv10no / cmd / sml / src / parse |
1.1 root 1: (* parse.sml *)
2:
3: structure Parse : PARSE =
4: struct
5:
6: structure BareAbsyn = BareAbsyn
7:
8: exception Eof
9:
10: fun interdec (lex as {nextToken, prompt, advance}: Lex.lexer ) =
11: let
12:
13: open ErrorMsg Symbol PrintUtil Lex
14: open Token
15: open Access Basics BasicTypes TypesUtil Absyn
16: open Env
17: open EnvAccess
18: open ModUtil
19: open SigMatch
20: open FirstSets
21: open Misc
22:
23: infix -->
24:
25: (* constants *)
26:
27: val maxTypSpecs = 100 (*maximum number of type specs in a signature *)
28: val maxStrSpecs = 100 (*maximum number of structure specs in a signature *)
29:
30: (* utility functions *)
31:
32: fun at tok = if !nextToken = tok then (advance(); true) else false
33:
34: fun checkToken tok =
35: if at(tok)
36: then ()
37: else complain("expected "^Token.tokenName tok^
38: ", found "^Token.tokenName(!nextToken))
39:
40: fun getSymbol () = case !nextToken of
41: Token.ID s => (advance(); s)
42: | Token.ASTERISK => (advance(); ASTERISKsym)
43: | Token.EQUAL => (advance(); EQUALsym)
44: | Token.TYVAR s => (advance(); s)
45: | Token.IDDOT s => (advance(); s)
46: | tok => ErrorMsg.impossible("getSymbol: " ^
47: Token.tokenName tok)
48: fun expop () =
49: case !nextToken
50: of EQUAL => lookFIX(EQUALsym)
51: | ASTERISK => lookFIX(ASTERISKsym)
52: | ID s => lookFIX(s)
53: | _ => NONfix
54:
55: fun patop () =
56: case !nextToken
57: of ASTERISK => lookFIX (ASTERISKsym)
58: | ID s => lookFIX(s)
59: | _ => NONfix
60:
61: fun ident() =
62: case !nextToken
63: of ID s => (advance();s)
64: | ASTERISK => (advance();ASTERISKsym)
65: | EQUAL => (advance();EQUALsym)
66: | tok => (complain("expected identifier, found " ^ tokenName tok);
67: bogusID)
68:
69: fun nonfix_ident() =
70: if (case !nextToken of
71: ID s => lookFIX(s)=NONfix
72: | ASTERISK => lookFIX(ASTERISKsym)=NONfix
73: | _ => false)
74: then getSymbol()
75: else (complain("expected nonfix-identifier, found "
76: ^ tokenName(!nextToken));
77: bogusID)
78:
79: fun opid() =
80: case !nextToken
81: of ID s => nonfix_ident()
82: | ASTERISK => nonfix_ident()
83: | OP => (advance();
84: case !nextToken
85: of ID s => getSymbol()
86: | ASTERISK => getSymbol()
87: | EQUAL => getSymbol()
88: | tok => (complain ("op not followed by identifier, found "
89: ^ tokenName tok); bogusID))
90: | tok => (complain("expected identifier or OP, found " ^ tokenName tok);
91: bogusID)
92:
93: fun getSTR id = lookSTR id
94: handle Unbound =>
95: (complain("unbound structure name: " ^ name id);
96: bogusSTR)
97:
98: fun getEXN id = lookCON(id) handle Unbound => unboundEXN id
99:
100: fun rightAssoc(elem:(unit->'a), tok:token, cons:('a*'b->'b), single:('a->'b))
101: : 'b =
102: let fun ra() =
103: let val e1 = elem()
104: in if at(tok) then cons(e1,ra()) else single e1
105: end
106: in ra()
107: end;
108:
109: fun leftAssoc(elem, tok, cons, single) =
110: let fun la e = if at tok then la(cons(e,elem())) else single e
111: in la(elem())
112: end
113:
114: fun precedence(elem,g,checkop) =
115: let fun parse(f, bp, e) =
116: case checkop()
117: of INfix(lbp,rbp) =>
118: if lbp > bp
119: then let val id = getSymbol()
120: val rhs = parse ((fn x=>g(id,e,x)),rbp,elem())
121: in parse(f,bp,rhs)
122: end
123: else f e
124: | _ => f e
125: in parse((fn x=>x), ~100, elem())
126: end
127:
128: fun andList(elem) =
129: let val e1 = elem()
130: in (if at(AND) then e1 :: andList(elem) else [e1])
131: end
132:
133: fun andListProtect(elem) = andList (fn () => protect(protectScope,elem))
134:
135: (* parsing functions *)
136:
137: (* qualified id interpretation *)
138:
139: fun symPath() =
140: case !nextToken
141: of IDDOT s => getSymbol() :: symPath()
142: | ID s => [getSymbol()]
143: | ASTERISK => [getSymbol()]
144: | EQUAL => [getSymbol()]
145: | _ => (complain "incomplete qualified identifier"; [bogusID])
146:
147: fun qid(lookLast) = lookPath(symPath(),lookLast)
148:
149: (* record labels *)
150:
151: fun selector() =
152: let fun sel1 id =
153: let val v = namedLvar id
154: val tyref = ref UNDEFty
155: val v1 = VALvar{name=[id],access=LVAR(v),typ=tyref}
156: val v2 = VALvar{name=[id],access=PATH[v],typ=tyref}
157: in FNexp[RULE(RECORDpat{fields=[(id,VARpat v1)],
158: flex=true,
159: typ=ref UNDEFty, pats=ref nil},
160: VARexp(ref v2))]
161: end
162: in case !nextToken
163: of ID _ => sel1(ident())
164: | INT i => let val s = makestring i
165: in if i < 1
166: then complain ("nonpositive integer label in selector,\
167: \ found " ^ s)
168: else ();
169: sel1(Symbol.symbol(s))
170: end
171: before advance()
172: | _ => (complain "illegal selector function"; bogusExp)
173: end
174:
175: fun labels(parseOne, separator, dotsOK, abbrev) =
176: if (case !nextToken
177: of ID _ => true
178: | INT _ => true
179: | DOTDOTDOT => true
180: | _ => false)
181: then let fun lablist () =
182: case !nextToken
183: of ID _ => field(ident(),abbrev)
184: | INT i => let val s = makestring i
185: in advance();
186: if i < 1
187: then complain ("nonpositive integer label, \
188: \found " ^ s)
189: else ();
190: field(Symbol.symbol(s),
191: (fn id =>
192: condemn("numeric label abbreviations allowed only in patterns: " ^
193: Symbol.name id)))
194: end
195: | DOTDOTDOT => nil
196: | tok => (complain("expected label, found " ^
197: tokenName tok); nil)
198: and field(id,abbrev) =
199: (id,
200: if at(separator) then parseOne()
201: else if !nextToken = COMMA orelse
202: !nextToken = COLON orelse
203: !nextToken = AS orelse
204: !nextToken = RBRACE then abbrev(id)
205: else condemn("expected " ^ Token.tokenName separator ^
206: " after label, found " ^
207: tokenName(!nextToken)),
208: ref 0)
209: :: (if at(COMMA) then lablist() else nil)
210: val l = lablist()
211: val dots = at(DOTDOTDOT)
212: val sl = sort3 l
213: in if length l > length sl
214: then complain "duplicate label in record"
215: else ();
216: if dots andalso not dotsOK
217: then complain "use of ... outside pattern" else ();
218: checkToken(RBRACE);
219: (l,sl,dots)
220: end
221: else (checkToken(RBRACE); (nil,nil,false))
222:
223: exception Clausal of symbol * pat (* for returning clausal patterns from pat *)
224:
225:
226: (* types *)
227:
228: fun noAbbrev(_) =
229: (complain "expected colon after label in record type, found comma";
230: UNDEFty)
231: fun ty() =
232: rightAssoc(ty1,ARROW,
233: (fn (t,ts) => CONty(arrowTycon, [t,ts])),
234: (fn t => t))
235: and ty1() =
236: case rightAssoc(ty2,ASTERISK,op::,single)
237: of [t] => t
238: | l => tupleTy l
239: and ty2() =
240: (* incorporates tyapp and aty nonterminals *)
241: let fun qid_s(t) =
242: case !nextToken
243: of ID _ =>
244: qid_s(CONty(!lookArTYC(getSymbol(),1), [t]))
245: | IDDOT _ =>
246: qid_s(CONty(!lookPathArTYC(symPath(),1), [t]))
247: | _ => t
248: in qid_s(case !nextToken
249: of LPAREN =>
250: let val t1 = (advance(); ty())
251: in if at(RPAREN)
252: then t1
253: else if at(COMMA)
254: then let val tys = t1 :: ty_pc()
255: val arity = length tys
256: in checkToken(RPAREN);
257: case !nextToken
258: of ID s =>
259: CONty(!lookArTYC(ident(),arity),
260: tys)
261: | IDDOT s =>
262: CONty(!lookPathArTYC(symPath(),arity),
263: tys)
264: | tok => condemn("expected type \
265: \constructor, found "
266: ^ tokenName tok)
267: end
268: else (complain("expected RPAREN or COMMA in type\
269: \args, found " ^ tokenName(!nextToken));
270: t1)
271: end
272: | ID s => CONty(!lookArTYC(ident(),0),[])
273: | IDDOT s => CONty(!lookPathArTYC(symPath(),0),[])
274: | Token.TYVAR s => VARty(lookTyvar(getSymbol()))
275: | LBRACE =>
276: (advance();
277: let val (l,sl,_) = labels(ty,COLON,false, noAbbrev)
278: in recordTy(map (fn (id,ty,_) => (id, ty)) sl)
279: end)
280: | tok => condemn("expected a type expression, found token "
281: ^ tokenName tok))
282: end
283: and ty_pc() = rightAssoc(ty,COMMA,op::,single)
284:
285:
286: fun markexp f x = if !System.Control.Debug.debugging
287: then let val one = (!ErrorMsg.fileName,!ErrorMsg.lineNum)
288: val e = f x
289: val two = (!ErrorMsg.fileName,!ErrorMsg.lineNum)
290: in case e
291: of MARKexp _ => e
292: | e' => if one=two then MARKexp(e',one,one)
293: else MARKexp(e',one,two)
294: end
295: else f x
296:
297: fun markdec f x = if !System.Control.Debug.debugging
298: then let val one = (!ErrorMsg.fileName,!ErrorMsg.lineNum)
299: val e = f x
300: val two = (!ErrorMsg.fileName,!ErrorMsg.lineNum)
301: in case e
302: of MARKdec _ => e
303: | e' => if one=two then MARKdec(e',one,one)
304: else MARKdec(e',one,two)
305: end
306: else f x
307:
308:
309: (* expressions -- including local declarations *)
310:
311: fun exp (stamps: Stampset.stampsets) =
312: case !nextToken
313: of FN => (advance(); FNexp(match(stamps)))
314: | CASE => CASEexp((advance(); exp(stamps)),
315: (checkToken(OF); match(stamps)))
316: | WHILE => WHILEexp((advance(); exp(stamps)),
317: (checkToken(DO); markexp exp stamps))
318: | IF => IFexp((advance(); exp(stamps)), (checkToken(THEN); markexp exp stamps),
319: (checkToken(ELSE); markexp exp stamps))
320: | RAISE => RAISEexp(advance(); exp(stamps))
321: | _ => let val e = exp1(stamps)
322: in if !nextToken = HANDLE
323: then (advance(); HANDLEexp(e,HANDLER(FNexp(match(stamps)))))
324: else e
325: end
326:
327: and match (stamps) = rightAssoc((fn () => rule stamps),BAR,op::,single)
328:
329: and rule (stamps) =
330: let val bl = ref nil : (symbol * var) list ref
331: in protect(protectScope,
332: (fn () => RULE(pat(bl,true)
333: handle Clausal(id,_) =>
334: condemn("undefined op in pattern: "^name id),
335: (checkToken(DARROW);
336: if !nextToken=EQUAL then advance() else ();
337: (* Capitalization convention
338: app checkBinding (!bl);
339: *)
340: bindVARs(!bl); markexp exp stamps))))
341: end
342:
343: and exp_ps (stamps) = rightAssoc((fn () => exp stamps),SEMICOLON,op::,single)
344:
345: and exp1 (stamps) = leftAssoc((fn () => markexp exp2 stamps),
346: ORELSE,ORELSEexp,(fn x=>x))
347:
348: and exp2 (stamps) = leftAssoc((fn () => markexp exp3 stamps),
349: ANDALSO,ANDALSOexp,(fn x=>x))
350:
351: (* N.B. above markexp's will cause too much marking, but this is harmless*)
352:
353: and exp3(stamps) =
354: let val e = precedence((fn () => markexp exp5 stamps),
355: (fn(id,a,b)=>APPexp(markexp lookID(id),
356: markexp TUPLEexp[a,b])), expop)
357: in if at(COLON) then CONSTRAINTexp(e,ty()) else e
358: end
359:
360: and exp5 (stamps) =
361: let fun loop e =
362: if firstAexp lookFIX (!nextToken)
363: then loop(markexp APPexp(e,markexp aexp stamps))
364: else e
365: in loop(markexp aexp stamps)
366: end
367:
368: (* note that IF WHILE CASE RAISE FN are matched below, but
369: are not in firstAexp. This is intentional *)
370:
371: and aexp (stamps) =
372: case !nextToken
373: of ID _ => lookID(nonfix_ident())
374: | OP => lookID(opid())
375: | IDDOT s => qid(lookIDinStr)
376: | INT i => INTexp(i) before advance()
377: | REAL s => REALexp(s) before advance()
378: | STRING s => STRINGexp(s) before advance()
379: | HASH => (advance(); selector())
380: | LBRACE => (advance(); exp_brace(stamps))
381: | LPAREN => (advance(); exp_paren(stamps))
382: | LBRACKET => (advance(); exp_bracket(stamps))
383: | LET =>
384: protect(protectScope,
385: (fn()=>(advance();
386: (LETexp(ldecs([],stamps),
387: (checkToken(IN); SEQexp(exp_ps(stamps)))))
388: before checkToken(END))))
389: | FN => exp(stamps)
390: | CASE => exp(stamps)
391: | WHILE => exp(stamps)
392: | IF => exp(stamps)
393: | RAISE => exp(stamps)
394: | tok => (complain ("atomic expression expected, found " ^
395: tokenName tok);
396: bogusExp)
397:
398: and exp_brace (stamps) =
399: let val (l,sl,_) =
400: labels((fn () => exp stamps),EQUAL,false,
401: (fn x => (complain "illegal record-name element abbreviation";
402: bogusExp)))
403: fun assign (i,(_,_,r)::tl) = (r:=i; assign(i+1,tl))
404: | assign (n,nil) = ()
405: in assign(0,sl);
406: RECORDexp(map (fn (id,e,ref n) => (LABEL{name=id,number=n},e)) l)
407: end
408:
409: and exp_paren (stamps) =
410: if at(RPAREN)
411: then unitExp (* TUPLEexp(nil) *)
412: else let val e = exp(stamps)
413: in case !nextToken
414: of RPAREN => (advance(); e)
415: | COMMA =>
416: (advance();
417: TUPLEexp(e::exp_pc(stamps)) before checkToken(RPAREN))
418: | SEMICOLON =>
419: (advance();
420: SEQexp(e::exp_ps(stamps)) before checkToken(RPAREN))
421: | tok => (complain ("expected comma, right paren, or\
422: \ semicolon, found " ^ tokenName tok); e)
423: end
424:
425: and exp_bracket (stamps) =
426: if at(RBRACKET)
427: then LISTexp(nil)
428: else LISTexp(exp(stamps) ::
429: if !nextToken = RBRACKET
430: then (advance(); nil)
431: else (checkToken(COMMA);
432: exp_pc(stamps) before checkToken(RBRACKET)))
433:
434: and exp_pc (stamps) = rightAssoc((fn () => exp stamps),COMMA,op::,single)
435:
436: and pat (bl: (symbol * var) list ref, full: bool) =
437: (* full false means parse atomic pattern *)
438: let fun restrictLAYEREDpat(x as (VARpat _, _)) = LAYEREDpat x
439: | restrictLAYEREDpat(y,z) =
440: (complain "pattern to left of AS must be a variable"; z)
441:
442: fun pat0 () = rightAssoc(pat1,AS,restrictLAYEREDpat,(fn x=>x))
443:
444: and pat1 () =
445: let val e = precedence(
446: pat2,
447: (fn(id,a,b)=>
448: APPpat(lookCON id, TUPLEpat[a,b])
449: handle Unbound =>
450: raise Clausal(id, TUPLEpat[a,b])),
451: patop)
452: in if at(COLON) then CONSTRAINTpat(e,ty()) else e
453: end
454:
455: and pat2 () =
456: let fun useCon(dcon as DATACON{const,name,...}) =
457: case (const,firstApat lookFIX (!nextToken))
458: of (true,false) => CONpat(dcon)
459: | (false,true) => APPpat(dcon,apat())
460: | (_,x) => (complain("improper use of constructor "^
461: Symbol.name(name)^" in pattern");
462: (if x then (apat(); ()) else ());
463: WILDpat)
464: fun simpleId(id) =
465: useCon(lookCON id)
466: handle Unbound =>
467: if firstApat lookFIX (!nextToken)
468: then raise Clausal(id, apat())
469: else VARpat(newVAR(bl,id))
470: in case !nextToken
471: of ID s => (if lookFIX(s) = NONfix
472: then ()
473: else complain("pattern starts with infix: "
474: ^ name(s));
475: simpleId(getSymbol()))
476: | OP => simpleId(opid())
477: | IDDOT s => useCon(qid lookCONinStr)
478: | _ => apat()
479: end
480:
481: and pat_id(id) =
482: (case lookCON id
483: of dcon as DATACON{const=true,...} => CONpat(dcon)
484: | _ => (complain("nonconstant data constructor: " ^ name(id));
485: WILDpat))
486: handle Unbound => VARpat(newVAR(bl,id))
487:
488: and apat() =
489: case !nextToken
490: of OP => pat_id(opid())
491: | ID s => pat_id(nonfix_ident())
492: | IDDOT s => CONpat(qid(lookCONinStr))
493: | INT i => INTpat(i) before advance()
494: | REAL s => REALpat(s) before advance()
495: | STRING s => STRINGpat(s) before advance()
496: | WILD => (advance(); WILDpat)
497: | LPAREN => (advance(); pat_paren())
498: | LBRACKET => (advance(); pat_bracket())
499: | LBRACE => (advance(); pat_brace())
500: | tok => (complain("expected an atomic pattern, found "
501: ^ tokenName tok); WILDpat)
502:
503: and pat_paren () =
504: if at(RPAREN)
505: then unitPat
506: else let val p = pat0()
507: in case !nextToken of
508: RPAREN => (advance(); p)
509: | COMMA =>
510: (advance();
511: TUPLEpat(p::pat_pc()) before checkToken(RPAREN))
512: | tok => (complain ("expected right paren or comma\
513: \ (in pattern), found " ^ tokenName tok);
514: p)
515: end
516:
517: and pat_bracket () =
518: LISTpat(if at(RBRACKET)
519: then nil
520: else pat_pc() before checkToken(RBRACKET))
521:
522: (* bug: we allow {a,b,c} to stand for {a=a,b=b,c=c} but we don't
523: allow {a as zzz} to stand for {a=a as zzz}
524: *)
525:
526: and pat_id_as id =
527: let val e = pat_id id
528: val e' = if at(COLON) then CONSTRAINTpat(e,ty()) else e
529: in if at(AS) then LAYEREDpat(e',pat0()) else e'
530: end
531:
532: and pat_brace () =
533: let val (_,sl,dots) = labels(pat0,EQUAL,true,pat_id_as)
534: in RECORDpat{
535: fields = map (fn(id,pat,_) => (id,pat)) sl,
536: flex = dots,
537: typ = ref UNDEFty,
538: pats = ref nil}
539: end
540:
541: and pat_pc() = rightAssoc(pat0,COMMA,op::,single)
542:
543: in if full then pat0() else apat()
544: end
545:
546: (* variable bindings *)
547:
548: and recdec x = VALRECdec(rvb_pa x)
549: and valdec x = VALdec(vb_pa x)
550: and vb x = markdec (if at(REC) then recdec else valdec) x
551:
552: and vb_pa (stamps) =
553: let val bl = ref nil : (symbol * var) list ref
554: fun vb () =
555: protect(protectTyvars(NONE),
556: (fn () =>
557: let val pat = pat(bl,true)
558: handle Clausal(id,_) =>
559: condemn("undefined op in pattern: "^name id)
560: and exp = (checkToken(EQUAL); exp(stamps))
561: and tvs = currentTyvars()
562: in case (pat,exp)
563: of (CONSTRAINTpat(VARpat(VALvar{name as [n],typ,...}), ty),
564: VARexp(ref(VALvar{access as INLINE _,...})))
565: => let val _::rest = !bl
566: val w = VALvar{name=name,typ=typ,access=access}
567: in bl := (n,w) :: rest;
568: VB{pat=CONSTRAINTpat(VARpat w, ty),
569: exp=exp,tyvars=tvs}
570: end
571:
572: | (VARpat(VALvar{name as [n],typ,...}),
573: VARexp(ref(VALvar{access as INLINE _,...})))
574: => let val _::rest = !bl
575: val w = VALvar{name=name,typ=typ,access=access}
576: in bl := (n,w) :: rest;
577: VB{pat=VARpat w, exp=exp, tyvars=tvs}
578: end
579: | _ => VB{pat=pat,exp=exp,tyvars=tvs}
580: end))
581: in andListProtect(vb)
582: before bindVARs(!bl)
583: end
584:
585: and rvb_pa (stamps) =
586: let val bl = ref nil : (symbol * var) list ref
587: fun rvb () = protect(protectTyvars(NONE),
588: (fn () => (* record bug *)
589: let val var=newVAR(bl,opid())
590: and resultty=constraint_op()
591: and e = (checkToken(EQUAL); exp stamps)
592: and tvs=currentTyvars()
593: in case e of FNexp _ => ()
594: | MARKexp(FNexp _,_,_) => ()
595: | _ => complain "fn expression required in val rec declaration";
596: RVB{var = var, resultty = resultty, exp = e, tyvars = tvs}
597: end))
598: in protect(protectPatchList, (fn()=>
599: protect(protectScope, (fn()=>
600: (openRec(); andListProtect(rvb)) ))
601: before bindVARs(!bl) ))
602: end
603:
604: and fb_pa (stamps) =
605: let val bl = ref nil : (symbol * var) list ref
606: fun fb () = protect(protectTyvars(NONE),
607: (fn () =>
608: let val funSymbol: symbol option ref = ref NONE
609: val clauses=rightAssoc((fn () => clause funSymbol stamps),
610: BAR,op::,single)
611: val CLAUSE{pats=p1,...}::_ = clauses
612: val len = length p1
613: in if exists (fn CLAUSE{pats,...} => length pats <> len) clauses
614: then complain "not all clauses have the same number of patterns"
615: else ();
616: FB{var = let val SOME id = !funSymbol in newVAR(bl,id) end,
617: clauses = clauses,
618: tyvars = currentTyvars()}
619: end))
620: in protect(protectPatchList, fn()=>
621: protect(protectScope, fn()=>
622: (openRec(); markdec (FUNdec o andListProtect) fb))
623: before bindVARs(!bl))
624: end
625:
626: and clause funsym stamps =
627: let val bl = ref nil : (symbol * var) list ref
628: fun pat_p () = if firstApat lookFIX (!nextToken)
629: then (pat(bl,false) (* atomic pattern *)
630: handle Clausal(id,_) =>
631: condemn("undefined op in pattern: "^name id))
632: :: pat_p ()
633: else nil
634: in (pat(bl,true); condemn("no defined function in clausal lhs"))
635: handle Clausal(id,pat1) =>
636: (case !funsym
637: of NONE => funsym := SOME id
638: | SOME f => if Symbol.eq(id,f) then ()
639: else complain "identifiers in clauses don't match";
640: let val pats = pat1::pat_p()
641: val resultty = constraint_op()
642: val exp = protect(protectScope,
643: (fn()=>(checkToken(EQUAL);
644: if !nextToken=DARROW then advance() else ();
645: bindVARs(!bl); markexp exp stamps)))
646: in CLAUSE{pats=pats, resultty=resultty, exp=exp}
647: end)
648: end
649:
650: and constraint () = (checkToken(COLON); ty())
651:
652: and constraint_op() =
653: if at(COLON)
654: then SOME(ty())
655: else NONE
656:
657: and tb(notwith,path,stamps: Stampset.stampsets) =
658: let fun tb1() =
659: let fun equalargs([],[]) = true
660: | equalargs(tv::rest,VARty(tv')::rest') =
661: tv = tv' andalso equalargs(rest,rest')
662: | equalargs _ = false
663: val args = tyvars()
664: val name = ident()
665: val _ = checkToken(EQUAL)
666: val typ = protect(protectTyvars(SOME args), ty)
667: val _ = TypesUtil.bindTyvars args;
668: val binding =
669: case typ
670: of CONty(tycref as ref(TYCON{stamp,arity,eq,path=path',kind}),
671: args') =>
672: if Stampset.tycFixed(stamp) andalso equalargs(args,args')
673: then case kind
674: of UNDEFtyc _ =>
675: (tycref :=
676: TYCON{stamp=stamp,arity=arity,eq=eq,
677: path=path',
678: kind=UNDEFtyc(SOME(name::path))};
679: tycref)
680: | _ => ref(TYCON{stamp=stamp,arity=arity,eq=eq,
681: path=name::path,kind=kind})
682: else ref(mkDEFtyc(name::path,
683: TYFUN{arity=length args, body=typ},
684: if notwith
685: then if isEqType typ then YES else NO
686: else MAYBE,
687: stamps))
688: | _ => ref(mkDEFtyc(name::path,
689: TYFUN{arity=length args, body=typ},
690: if notwith
691: then if isEqType typ then YES else NO
692: else MAYBE,
693: stamps))
694: in bindTYC(name,binding);
695: TB{tyc=binding,def=typ}
696: end
697: in TYPEdec(andList(tb1))
698: end
699:
700: and tyvars() =
701: case !nextToken
702: of Token.TYVAR s => [mkTyvar(mkUBOUND(s))] before advance()
703: | LPAREN =>
704: (advance();
705: tyvar_pc() before
706: checkToken(RPAREN))
707: | _ => nil
708:
709: and tyvar_pc() = rightAssoc(tyvar,COMMA,op::,single)
710:
711: and tyvar() = mkTyvar(mkUBOUND(
712: case !nextToken
713: of Token.TYVAR s => (advance(); s)
714: | tok => (complain ("expected type variable, found "
715: ^ tokenName tok); bogusID)))
716:
717: and db(path,stamps) =
718: let val (datatycs,withtycs) =
719: protect(protectDb(), (fn()=>
720: (andList(db1(ty,path,stamps)),
721: if at(WITHTYPE)
722: then let val TYPEdec x = tb(false,path,stamps) in x end
723: else nil)))
724: val checkeq = defineEqTycon (fn x => x)
725: in app (fn (ref tyc) => checkeq tyc) datatycs;
726: app (fn TB{tyc,...} => checkeq(!tyc)) withtycs;
727: DATATYPEdec{datatycs=datatycs,withtycs=withtycs}
728: end
729:
730: and db1(parsety,path,stamps) () =
731: let val args = tyvars()
732: val name = ident()
733: val arity = length args
734: val rangeType = CONty(!lookArTYC(name,arity), map VARty args)
735: fun constr() =
736: let val sym = (if at OP
737: then warn "unnecessary op in datatype declaration"
738: else ();
739: ident())
740: val const = not(at(OF))
741: val typ = if const then rangeType
742: else CONty(arrowTycon, [parsety(), rangeType])
743: in (sym,const,typ)
744: end
745: in protect(protectTyvars(SOME args),
746: (fn()=>
747: let val dcl = (checkToken(EQUAL); rightAssoc(constr,BAR,op::,single))
748: val sdcl = sort3 dcl
749: val sign = ConRep.boxed(sdcl)
750: fun binddcons ((sym,const,typ)::restdcl,rep::restsign) =
751: let val dcon =
752: DATACON{name = sym, const = const, rep = rep, sign = sign,
753: typ = if arity > 0
754: then ref(POLYty
755: {sign=mkPolySign arity,
756: tyfun=TYFUN{arity=arity,body=typ}})
757: else ref typ}
758: in bindCON(sym, dcon);
759: dcon :: binddcons(restdcl,restsign)
760: end
761: | binddcons ([],[]) = []
762: | binddcons _ = impossible "Parse.db1.fn.binddcons"
763: in if length sdcl < length dcl
764: then complain "duplicate constructor name" else ();
765: TypesUtil.bindTyvars args;
766: let val tycref = ref(mkDATAtyc(name::path,arity,
767: binddcons(sdcl,sign),MAYBE,stamps))
768: in bindTYC(name,tycref);
769: tycref
770: end
771: end))
772: end
773:
774: and ab(path,stamps) =
775: let val mAbstype = openScope()
776: val DATATYPEdec{datatycs,withtycs} = db(path,stamps)
777: val withtycons = map (fn TB{tyc,...} => tyc) withtycs
778: val abstycs = makeAbstract(datatycs,withtycons)
779: val mWith = (openScope(); current())
780: val body = (checkToken(WITH); ldecs(path,stamps))
781: fun bind tyc = bindTYC(tycName(!tyc), tyc)
782: in checkToken(END);
783: splice(mAbstype,mWith);
784: app bind datatycs (* abstycs *);
785: app bind withtycons;
786: ABSTYPEdec{abstycs=datatycs,withtycs=withtycs,body=body}
787: end
788:
789: and eb() = EXCEPTIONdec(andList(eb1))
790:
791: and eb1() =
792: let val name = ident()
793: (* Capitalization convention
794: val _ = if looksLikeExn name then ()
795: else warn "Exception name should be capitalized"
796: *)
797: in case !nextToken
798: of OF =>
799: (advance();
800: let val etype = ty()
801: val exn = DATACON{name = name,
802: const = false,
803: typ = ref(etype --> exnTy),
804: rep = VARIABLE(LVAR(namedLvar(name))),
805: sign = []}
806: in bindCON(name,exn);
807: EBgen{exn=exn,etype=SOME etype}
808: end)
809: | EQUAL =>
810: (advance();
811: let val edef as DATACON{const,typ,rep,sign,...} =
812: case !nextToken
813: of IDDOT s => qid lookEXNinStr
814: | ID s => getEXN(getSymbol())
815: | tok =>
816: (complain("expected exception name, found token"
817: ^ tokenName tok);
818: unboundEXN(bogusID))
819: val exn = DATACON{name=name,const=const,typ=ref(!typ),sign=sign,
820: rep=VARIABLE(LVAR(namedLvar(name)))}
821: in bindCON(name,exn);
822: EBdef{exn=exn,edef=edef}
823: end)
824: | _ =>
825: let val exn = DATACON{name = name,
826: const = true,
827: typ = ref exnTy,
828: rep = VARIABLE(LVAR(namedLvar(name))),
829: sign = []}
830: in bindCON(name,exn);
831: EBgen{exn=exn,etype=NONE}
832: end
833: end
834:
835:
836: and ebx() = EXCEPTIONdec(andList(eb1x))
837:
838: and eb1x() =
839: let val name = ident()
840: val etype = constraint_op()
841: val (const,typ) = case etype
842: of NONE => (true,exnTy)
843: | SOME t => if isUnitTy(t)
844: then (true,exnTy)
845: else (false,t-->exnTy)
846: val edef = if at(EQUAL)
847: then SOME(case !nextToken
848: of IDDOT _ => qid lookEXNinStr
849: | ID s => getEXN(getSymbol())
850: | _ => unboundEXN(bogusExnID) )
851: else NONE
852: val exn = case edef
853: of NONE =>
854: DATACON{name=name, const=const, typ=ref typ,
855: rep=VARIABLE(LVAR(namedLvar(name))),
856: sign=[]}
857: | SOME(DATACON{name=n,const,typ,rep,sign}) =>
858: DATACON{name=name,const=const,typ=ref(!typ),rep=rep,
859: sign=sign} (* changes only name *)
860: in bindCON(name, exn);
861: case edef
862: of NONE => EBgen{exn=exn,etype=etype}
863: | SOME exn' => EBdef{exn=exn,edef=exn'}
864: end
865:
866: and ldec(path,stamps) =
867: case !nextToken
868: of VAL =>
869: (advance(); vb(stamps))
870: | FUN =>
871: (advance(); fb_pa(stamps))
872: | TYPE =>
873: (advance(); tb(true,path,stamps))
874: | DATATYPE =>
875: (advance(); db(path,stamps))
876: | ABSTYPE =>
877: (advance(); ab(path,stamps))
878: | EXCEPTION =>
879: (advance(); eb())
880: | Token.LOCAL =>
881: let val envLocal = openScope()
882: val ld1 = (advance(); ldecs([],stamps))
883: val envIn = (checkToken(IN); openScope(); current())
884: val ld2 = ldecs(path,stamps)
885: in checkToken(END);
886: splice(envLocal,envIn);
887: markdec LOCALdec(ld1,ld2)
888: end
889: | Token.OPEN => (* confusion with Env.OPEN when Env not constrained *)
890: let val strs = (advance(); qid_p())
891: in app openStructureVar strs;
892: markdec OPENdec strs
893: end
894: | INFIX =>
895: let val prec = case (advance(); optprec()) of SOME n=>n|NONE=>0
896: in app (fn i => bindFIX(i,FIXvar{name=i,binding=infixleft prec})) (ops());
897: SEQdec(nil)
898: end
899: | INFIXR =>
900: let val prec = case (advance(); optprec()) of SOME n=>n|NONE=>0
901: in app (fn i => bindFIX(i,FIXvar{name=i,binding=infixright prec})) (ops());
902: SEQdec(nil)
903: end
904: | NONFIX =>
905: (advance();
906: app (fn i => bindFIX(i,FIXvar{name=i,binding=NONfix})) (ops()); SEQdec(nil))
907: | OVERLOAD =>
908: let val id = (advance(); ident())
909: val scheme = (checkToken(COLON);
910: protect(protectScope, (fn () => (* localize tyvars *)
911: protect(protectTyvars(NONE), (fn () =>
912: let val body = ty() (* generalize type variables *)
913: val tvs = currentTyvars()
914: in TypesUtil.bindTyvars tvs;
915: TYFUN{arity=length(tvs),body=body}
916: end)))))
917: fun option() =
918: let val VARexp(ref (v as VALvar{typ,...})) = exp(stamps)
919: in {indicator = TypesUtil.matchScheme(scheme,!typ),
920: variant = v}
921: end
922: val l = (checkToken(AS); andList(option))
923: in bindVAR(id,OVLDvar{name=id,options=ref l,scheme=scheme});
924: SEQdec nil
925: end
926: | tok => (complain ("expected a declaration, found " ^
927: tokenName tok); vb(stamps))
928:
929: and ldecs(path_stamps) =
930: let fun ldecs() =
931: if firstLdec(!nextToken)
932: then ldec(path_stamps) :: (at(SEMICOLON); ldecs())
933: else []
934: in case ldecs() of [dec] => dec | seq => SEQdec seq
935: end
936:
937: and optprec() = case !nextToken of INT i => (advance();SOME(i)) | _ => NONE
938:
939: and qid_p(): structureVar list = (* error if no identifier's ? *)
940: case !nextToken
941: of ID s => getSTR(ident()) :: qid_p()
942: | IDDOT _ => qid(lookSTRinStr)::qid_p()
943: | _ => nil
944:
945: and ops() =
946: let fun ops1() =
947: case !nextToken
948: of ID s => (s) :: (advance(); ops1())
949: | EQUAL => (EQUALsym) :: (advance(); ops1())
950: | ASTERISK => (ASTERISKsym) :: (advance(); ops1())
951: | _ => nil
952: in case ops1()
953: of [] => (complain("operator or identifier expected, found "
954: ^ tokenName (!nextToken)); [])
955: | l => l
956: end
957:
958:
959: (* signatures *)
960:
961: fun addzeros(0,l) = l
962: | addzeros(n,l) = addzeros(n-1,0::l)
963:
964: fun sigbody(depth: int, stamps: Stampset.stampsets) : Structure =
965: let val tComps = array(maxTypSpecs,NULLtyc)
966: and tCount = ref 0
967: fun tNext x = (update(tComps,!tCount,x);
968: INDtyc(!tCount before inc tCount))
969: val sComps = array(maxStrSpecs,NULLstr)
970: and sCount = ref 2 (* slots 0,1 reserved for parent, fct param (if any) *)
971: fun sNext x = (update(sComps,!sCount,x);
972: INDstr(!sCount before inc sCount))
973: val tempenv = REL{t=tComps,s=sComps}
974: fun pairs (nil : spath list list) : (spath*spath) list = nil
975: | pairs ((a::b::r) :: s) = (a,b) :: pairs((b::r) :: s)
976: | pairs ( _ :: s ) = pairs s
977: val strSharing : spath list list ref = ref nil
978: val typeSharing : spath list list ref = ref nil
979:
980: val slot = ref 0
981: fun nextSlot() = (!slot before inc slot)
982:
983: val table = newTable()
984: val tables = ref [table]
985:
986: (* includeSig used to implement include specs *)
987:
988: fun includeSig({strStamps=strStamps0, tycStamps=tycStamps0}: Stampset.stampsets,
989: STRstr{kind=SIGkind{bindings,stamps={strStamps,tycStamps},...},
990: env=REL{s=senv,t=tenv},...}) =
991: let val transStrStamp = Stampset.join(strStamps0,strStamps)
992: val transTycStamp = Stampset.join(tycStamps0,tycStamps)
993: val sOffset = !sCount - 2 (* offset for structure indices *)
994: val tOffset = !tCount (* offset for tycon indices *)
995:
996: (* adjustPath(depth: int, path: int list) *)
997: fun adjustPath(0,[i]) = [i+tOffset]
998: | adjustPath(0,i::r) = (i+sOffset) :: r
999: | adjustPath(0,[]) = impossible "sigBody.includeSig.adjustPath"
1000: | adjustPath(d,0::(r as _::_)) = 0 :: adjustPath(d-1,r)
1001: | adjustPath(d,p) = p
1002:
1003: fun adjustType(depth,ty) =
1004: let fun adjust(CONty(ref(RELtyc(p)),args)) =
1005: CONty(ref(RELtyc(adjustPath(depth,p))), map adjust args)
1006: | adjust(CONty(reftyc,args)) =
1007: CONty(reftyc, map adjust args)
1008: | adjust(POLYty{sign,tyfun=TYFUN{arity,body}}) =
1009: POLYty{sign=sign,
1010: tyfun=TYFUN{arity=arity,body=adjust body}}
1011: | adjust ty = ty
1012: in adjust ty
1013: end
1014:
1015: fun transTBinding depth binding =
1016: case binding
1017: of VARbind(VALvar{name,typ,access}) =>
1018: VARbind(VALvar{name=name,access=access,
1019: typ=ref(adjustType(depth,!typ))})
1020: | CONbind(DATACON{name,typ,const,rep,sign}) =>
1021: CONbind(DATACON{name=name, const=const, sign=sign, rep=rep,
1022: typ=ref(adjustType(depth,!typ))})
1023: | _ => binding
1024:
1025: fun transLBinding table binding =
1026: case binding
1027: of VARbind(VALvar{name=[n],typ,access}) =>
1028: IntStrMap.map table (NameSpace.varKey n)
1029: | CONbind(DATACON{name,typ,const,rep,sign}) =>
1030: IntStrMap.map table (NameSpace.conKey name)
1031: | _ => binding
1032:
1033: fun newTyc(tyc as TYCON{stamp,kind,...}) =
1034: if Stampset.tycFixed(stamp)
1035: then tyc
1036: else (case kind
1037: of ABStyc => setTycStamp(transTycStamp(stamp),tyc)
1038: | DATAtyc _ => setTycStamp(transTycStamp(stamp),tyc)
1039: | _ => tyc)
1040: | newTyc _ = impossible "Parse.includeSig.newTyc"
1041:
1042: fun newEnv(depth,REL{s,t}) =
1043: REL{s=mapSubstrs(newStr depth,s), t=ArrayExt.map(newTyc,t,0)}
1044: | newEnv _ = impossible "Parse.includeSig.newEnv"
1045:
1046: and newStr depth (str as STRstr{stamp,sign,table,env,
1047: kind=SIGkind{stamps,share,bindings}}) =
1048: if Stampset.strFixed(stamp)
1049: then str
1050: else let val newenv as REL{s,t} = newEnv(depth+1,env)
1051: val newtable =
1052: IntStrMap.transform (transTBinding depth) table
1053: val new =
1054: STRstr{stamp=transStrStamp(stamp),
1055: table=newtable,
1056: kind=SIGkind{stamps=stamps,share=share,
1057: bindings=map
1058: (transLBinding newtable)
1059: bindings},
1060: env=newenv, sign=sign}
1061: in ArrayExt.app(ModUtil.resetParent new, s, 2);
1062: new
1063: end
1064: | newStr _ (INDstr i) = impossible("sigbody.newStr INDstr "^
1065: makestring i)
1066: | newStr _ (SHRstr _) = impossible "sigbody.newStr SHRstr"
1067: | newStr _ (NULLstr) = impossible "sigbody.newStr NULLstr"
1068: | newStr _ _ = impossible "sigbody.newStr STRkind"
1069:
1070: fun adjustBinding binding =
1071: case binding
1072: of VARbind(VALvar{name=[n],typ,...}) =>
1073: bindVAR(n,VALvar{name=[n],typ=ref(adjustType(0,!typ)),
1074: access=SLOT(nextSlot())})
1075: | CONbind(DATACON{name,typ,const,rep as VARIABLE(SLOT _),sign}) =>
1076: bindCON(name,DATACON{name=name,
1077: const=const,
1078: sign=sign,
1079: typ=ref(adjustType(0,!typ)),
1080: rep=VARIABLE(SLOT(nextSlot()))})
1081: | CONbind(DATACON{name,typ,const,rep,sign}) =>
1082: bindCON(name,DATACON{name=name,
1083: const=const,
1084: sign=sign,
1085: typ=ref(adjustType(0,!typ)),
1086: rep=rep})
1087: | TYCbind(ref(INDtyc i)) =>
1088: let val tyc = tenv sub i
1089: val name = tycName tyc
1090: in bindTYC(name,ref(tNext(newTyc(tyc))))
1091: end
1092: | STRbind(STRvar{name as [n],binding=INDstr i,...}) =>
1093: bindSTR(n,STRvar{name=name,
1094: binding=sNext(newStr 1 (senv sub i)),
1095: access=SLOT(nextSlot())})
1096: | FIXbind(fixvar as FIXvar{name,...}) =>
1097: bindFIX(name,fixvar)
1098: | _ => impossible "sigBody.adjustBinding"
1099:
1100: in map adjustBinding bindings
1101: end (* includeSig *)
1102: | includeSig _ = impossible "Parse.includeSig - bad arg"
1103:
1104: (* the following four functions help implement the open spec.
1105: lookPathSTRinSig looks like it belongs in EnvAccess *)
1106:
1107: fun lookPathSTRinSig (spath as first::rest) : Structure * int list =
1108: let fun complainUnbound() =
1109: (complain "unbound structure in signature";
1110: print " name: "; printSequence "." printSym spath;
1111: newline();
1112: raise Syntax)
1113: (* second arg of get is expected to be a signature *)
1114: fun get([id],STRstr{table,env as REL{s,...},...}) =
1115: (case lookSTRinTable(table,id)
1116: handle UnboundTable => complainUnbound()
1117: of STRvar{binding=INDstr i,...} => (s sub i, [i])
1118: | STRvar{binding=SHRstr(p as i::r),...} =>
1119: (getEpath(r,s sub i), p) (* not possible? *)
1120: | _ => impossible "lookPathSTRinSig.get")
1121: | get(id::rest,STRstr{table,env=REL{s,...},...}) =
1122: let val STRvar{binding=INDstr k,...} =
1123: lookSTRinTable(table,id)
1124: handle UnboundTable => complainUnbound()
1125: val (str,p) = get(rest, s sub k)
1126: in (str, k::p)
1127: end
1128: | get([],str) = (str,[])
1129: | get(p,NULLstr) =
1130: impossible "sigbody.lookPathSTRinSig.get - NULLstr"
1131: | get(p,INDstr _) =
1132: impossible "sigbody.lookPathSTRinSig.get - INDstr"
1133: | get(p,SHRstr _) =
1134: impossible "sigbody.lookPathSTRinSig.get - SHRstr"
1135: | get _ = impossible "sigbody.lookPathSTRinSig.get - bad args"
1136: fun lookInStr(str) =
1137: (case rest
1138: of [] => str
1139: | _ =>
1140: let val STRvar{binding,...} =
1141: lookPathinStr(str, [], spath, lookSTRinStr)
1142: in binding
1143: end,
1144: [1])
1145: val leadStr = lookSTR0 first
1146: handle Unbound => complainUnbound()
1147: in case leadStr
1148: of (STRvar{binding=INDstr i,...},{path as h::r,strenv=REL{s,...}}) =>
1149: if h < 0 (* indicates signature component *)
1150: then let val (str,p) = get(rest, s sub i)
1151: in (str,path@(i::p))
1152: end
1153: else lookInStr(s sub i)
1154: | (STRvar{binding=SHRstr(i::r),...},{strenv=REL{s,...},...}) =>
1155: lookInStr(getEpath(r, s sub i))
1156: | (STRvar{binding as STRstr _,...},_) => lookInStr binding
1157: | _ => impossible "sigbody.lookPathSTRinSig - leadStr"
1158: end
1159: | lookPathSTRinSig _ = impossible "sigbody.lookPathSTRinSig - bad arg"
1160:
1161: fun openStrIds(): spath list =
1162: case !nextToken
1163: of ID _ => [ident()] :: openStrIds()
1164: | IDDOT _ => symPath()::openStrIds()
1165: | _ => nil
1166:
1167: fun openStrInSig(p:spath) =
1168: case lookPathSTRinSig p
1169: of (STRstr{table,env,...},p) => openOld({path=p,strenv=env},table)
1170: | _ => impossible "openStrInSig -- bad arg"
1171:
1172: fun mergeTables tables =
1173: let val bottom::rest = rev tables
1174: in revfold
1175: (fn (table,acc) => (IntStrMap.app (IntStrMap.add acc) table; acc))
1176: rest bottom
1177: end
1178:
1179: fun spec_s() =
1180: if firstSpec(!nextToken)
1181: then (spec() @ (at(SEMICOLON); spec_s()))
1182: else nil
1183:
1184: and spec() =
1185: case !nextToken
1186: of STRUCTURE => (advance(); strspec())
1187: | DATATYPE => (advance(); dtyspec())
1188: | TYPE => (advance(); tyspec NO)
1189: | EQTYPE => (advance(); tyspec YES)
1190: | VAL => (advance(); valspec())
1191: | EXCEPTION => (advance(); exnspec())
1192: | INFIX => (advance(); infixspec(infixleft))
1193: | INFIXR => (advance(); infixspec(infixright))
1194: | NONFIX =>
1195: (advance();
1196: app (fn i => bindFIX(i,FIXvar{name=i,binding=NONfix})) (ops());
1197: nil)
1198: | SHARING => (advance(); sharespec())
1199: | INCLUDE => (advance(); includespec())
1200: | Token.LOCAL => (advance(); localspec())
1201: | Token.OPEN => (advance(); openspec())
1202: | tok => condemn("expected a spec (component of signature)\
1203: \ found " ^ tokenName tok)
1204:
1205:
1206: and localspec() =
1207: (spec_s(); checkToken(IN); spec_s() before checkToken(END))
1208:
1209: and openspec() =
1210: let val strpaths = openStrIds()
1211: val newtable = newTable()
1212: in case strpaths
1213: of [] => complain "no structure ids in open spec"
1214: | _ =>
1215: (app openStrInSig strpaths;
1216: openNew({path=[~depth],strenv=tempenv},newtable);
1217: tables := newtable :: !tables);
1218: [] (* no bindings returned *)
1219: end
1220:
1221: and includespec() =
1222: let val name = ident()
1223: val SIGvar{binding,...} = lookSIG name
1224: in includeSig(stamps,binding)
1225: end
1226:
1227: and strspec() =
1228: rightAssoc(strspec1,AND,op :: , single)
1229:
1230: and strspec1() =
1231: let val name = ident()
1232: val _ = checkToken(COLON)
1233: val sgn =
1234: case !nextToken
1235: of ID s =>
1236: let val name = s before advance()
1237: val SIGvar{binding,...} = lookSIG(name)
1238: in ModUtil.shiftSigStamps(stamps,binding)
1239: end
1240: | Token.SIG =>
1241: (advance();
1242: sigbody(depth+1,stamps)
1243: before checkToken(END))
1244: | tok => condemn("expected a signature or signature-identifier, \
1245: \found: "^tokenName tok)
1246: in bindSTR(name,STRvar{name=[name],access=SLOT(nextSlot()),
1247: binding=sNext(sgn)})
1248: end
1249:
1250: and dtyspec() =
1251: let val dtycs =
1252: (protect(protectDb(), fn() =>
1253: map (fn (r as ref tyc) =>
1254: (r := tNext tyc; (TYCbind r, tyc)))
1255: (rightAssoc(db1(ty,[],stamps),AND,op ::,single))))
1256: val tycbinds = map (fn (x,_) => x) dtycs
1257: val tycons = map (fn (_,y) => y) dtycs
1258: fun collectdcons(tyc::rest,dcbinds) =
1259: let val TYCON{kind=DATAtyc(dcons),...} = tyc
1260: fun binddcons(DATACON{name,...}::rest',dcbs) =
1261: binddcons(rest',
1262: (let val (b,_) = Env.look(NameSpace.conKey(name))
1263: in b::dcbs
1264: end
1265: handle Unbound => dcbs))
1266: | binddcons([],dcbs) = dcbs
1267: in collectdcons(rest,binddcons(dcons,dcbinds))
1268: end
1269: | collectdcons([],dcbinds) = dcbinds
1270: in app (defineEqTycon (tyconInContext tempenv)) tycons;
1271: tycbinds @ collectdcons(tycons,[])
1272: end
1273:
1274: and tyspec eq =
1275: rightAssoc(tyspec1 eq, AND, op ::, single)
1276:
1277: and tyspec1 eq () =
1278: let val arity = length(tyvars())
1279: val name = ident()
1280: val tycref = ref(tNext(mkABStyc([name],arity,eq,stamps)))
1281: in bindTYC(name, tycref)
1282: end
1283:
1284: and valspec() =
1285: rightAssoc(valspec1,AND,op ::,single)
1286:
1287: and valspec1() =
1288: let val name =
1289: (if at OP
1290: then warn "unnecessary op in val specification"
1291: else ();
1292: case !nextToken
1293: of ID s => getSymbol()
1294: | ASTERISK => getSymbol()
1295: | EQUAL => getSymbol()
1296: | tok =>
1297: (complain("val spec: expected identifier, found "
1298: ^ tokenName tok); bogusID))
1299: val _ = checkToken(COLON)
1300: val typ =
1301: protect(protectScope, (fn () =>
1302: (* localize type variables *)
1303: protect(protectTyvars(NONE), (fn () =>
1304: let val body = ty()
1305: val tvs = currentTyvars()
1306: in case tvs
1307: of [] => body
1308: | _ =>
1309: let val sign = TypesUtil.bindTyvars1 tvs
1310: in POLYty
1311: {sign = sign,
1312: tyfun = TYFUN{arity = length tvs,
1313: body = body}}
1314: end
1315: end))))
1316: in bindVAR(name,VALvar{name=[name],typ=ref typ,access=SLOT(nextSlot())})
1317: end
1318:
1319: and exnspec() =
1320: rightAssoc(exnspec1,AND,op ::,single)
1321:
1322: and exnspec1() =
1323: let val name = ident()
1324: val (const,typ) =
1325: if at(OF) then
1326: (false,
1327: protect(protectScope, (fn () =>
1328: (* localize type variables *)
1329: protect(protectTyvars(NONE), (fn () =>
1330: let val body = ty()
1331: val tvs = currentTyvars()
1332: in case length tvs
1333: of 0 => body --> exnTy
1334: | n =>
1335: (TypesUtil.bindTyvars tvs;
1336: POLYty
1337: {sign = mkPolySign n,
1338: tyfun = TYFUN{arity = n,
1339: body = body --> exnTy}})
1340: end)))))
1341: else (true,exnTy)
1342: in bindCON(name, DATACON{name=name, const=const, typ= ref typ,
1343: rep=VARIABLE(SLOT(nextSlot())),
1344: sign=[]})
1345: end
1346:
1347: and infixspec(mkinfix) =
1348: let val prec = case optprec() of SOME n=>n|NONE=>0
1349: in app (fn i => bindFIX(i,FIXvar{name=i,binding=mkinfix prec}))
1350: (ops());
1351: nil
1352: end
1353:
1354: and sharespec() =
1355: (rightAssoc(sharespec1,AND,discard,discard); nil)
1356:
1357: and sharespec1() =
1358: case !nextToken
1359: of TYPE => (advance(); typeSharing := patheqn() :: !typeSharing)
1360: | ID s => strSharing := patheqn() :: !strSharing
1361: | IDDOT _ => strSharing := patheqn() :: !strSharing
1362: | tok => condemn("unexpected token after \"sharing\": "
1363: ^tokenName tok)
1364:
1365: and patheqn() : spath list =
1366: rightAssoc(symPath,EQUAL,op ::,single)
1367:
1368: val stamp = Stampset.newStamp(#strStamps stamps)
1369: val _ = openStr()
1370: val _ = openNew({path=[~depth],strenv=tempenv},table)
1371: val savedlookArTYC = !lookArTYC
1372: val savedlookPathArTYC = !lookPathArTYC
1373: val bindings = protect(
1374: ((fn () => (lookArTYC := lookArTYCinSig depth;
1375: lookPathArTYC :=
1376: lookPathArTYCinSig depth)),
1377: (fn () => (lookArTYC := savedlookArTYC;
1378: lookPathArTYC := savedlookPathArTYC))),
1379: spec_s)
1380: val _ = closeStr()
1381: val table = mergeTables(!tables)
1382: val senv = ArrayExt.copy(sComps,!sCount)
1383: val env = REL{s=senv, t=ArrayExt.copy(tComps,!tCount)}
1384: val sShare = pairs(!strSharing)
1385: val tShare = pairs(!typeSharing)
1386: val shareSpec =
1387: if null sShare andalso null tShare
1388: then {s=[],t=[]}
1389: else Sharing.doSharing(table,env,stamps,{s=sShare,t=tShare})
1390: val result =
1391: STRstr{stamp=stamp,
1392: sign=Stampset.newStamp(Stampset.sigStamps),
1393: table=table,
1394: env=env,
1395: kind=SIGkind{share=shareSpec,
1396: bindings=bindings,
1397: stamps=stamps}}
1398: in ArrayExt.app((ModUtil.setParent result),senv,2);
1399: result
1400: end (* fun sigbody *)
1401:
1402: fun sign () : Structure =
1403: case !nextToken
1404: of ID s =>
1405: let val name = s before advance()
1406: val SIGvar{binding,...} = lookSIG(name)
1407: in binding
1408: end
1409: | Token.SIG =>
1410: (advance();
1411: sigbody(1,Stampset.newStampsets())
1412: before checkToken(END))
1413: | tok => condemn("expected a signature or signature-identifier, \
1414: \found: "^tokenName tok)
1415:
1416: fun sigconstraint () =
1417: (checkToken(COLON);
1418: sign())
1419:
1420: fun sigconstraint_op () =
1421: if !nextToken = COLON
1422: then (advance(); SOME(sign()))
1423: else NONE
1424:
1425: (* signature bindings *)
1426:
1427: fun sigb() =
1428: let fun sigb1() =
1429: let val name = ident()
1430: in checkToken(EQUAL);
1431: let val sigvar = SIGvar{name=name,binding=sign()}
1432: in bindSIG(name, sigvar);
1433: sigvar
1434: end
1435: end
1436: in rightAssoc(sigb1,AND,op ::,single)
1437: end
1438:
1439: (* structure expressions *)
1440:
1441: fun str(abs: bool, constraint: Structure option, path: spath,
1442: stamps: Stampset.stampsets, param: Structure)
1443: : strexp * Structure * thinning =
1444: case !nextToken
1445: of IDDOT _ =>
1446: let val strVar as STRvar{binding,...} = qid(lookSTRinStr)
1447: in case constraint
1448: of NONE => (VARstr strVar, binding, NONE)
1449: | SOME sgn =>
1450: let val (str,thin) =
1451: SigMatch.match(abs,path,stamps,sgn,binding,param)
1452: in (VARstr strVar, str, thin)
1453: end
1454: end
1455: | Token.STRUCT =>
1456: (advance();
1457: let val _ = openStr()
1458: val body = sdecs(path,stamps)
1459: in (case constraint
1460: of NONE =>
1461: let val (thin,table) = BuildMod.buildStrTable ()
1462: in (STRUCTstr{body=body,locations=thin},
1463: mkSTR(path,table,DIR,stamps),
1464: NONE)
1465: end
1466: | SOME sgn =>
1467: let val (str,thin) =
1468: SigMatch.realize(abs,path,stamps,
1469: Stampset.newStamp(#strStamps stamps),
1470: sgn,param)
1471: in closeStr();
1472: (STRUCTstr{body=body,locations=thin}, str, NONE)
1473: end)
1474: before checkToken(END)
1475: end)
1476: | ID s =>
1477: let val id = getSymbol()
1478: in if at(LPAREN) (* functor application *)
1479: then let val fctVar as FCTvar{binding=fct,...} = lookFCT id
1480: val (argexp,argstr) =
1481: (* parse arg without using parameter sig *)
1482: (if !nextToken = RPAREN
1483: then (STRUCTstr{body=[],locations=[]},nullStr)
1484: else if firstSdec(!nextToken)
1485: then let val _ = openStr()
1486: val body = sdecs([anonParamName],stamps)
1487: val (thin,table) = BuildMod.buildStrTable ()
1488: in (STRUCTstr{body=body,locations=thin},
1489: mkSTR([anonParamName],table,
1490: DIR,stamps))
1491: end
1492: else let val FUNCTOR{paramName,...} = fct
1493: val (strexp,str,_) =
1494: str(false,NONE,[paramName],stamps,NULLstr)
1495: in (strexp,str)
1496: end)
1497: before checkToken(RPAREN)
1498: val (result,thin1) =
1499: Functor.applyFunctor(fct,argstr,path,stamps)
1500: val strexp = APPstr{oper=fctVar,
1501: argexp=argexp,
1502: argthin=thin1}
1503: in case constraint
1504: of NONE => (strexp,result,NONE)
1505: | SOME sgn =>
1506: let val (thinned,thin2) =
1507: SigMatch.match(abs,path,stamps,sgn,result,param)
1508: in (strexp,thinned,thin2)
1509: end
1510: end
1511: else let val strVar as STRvar{binding,...} = getSTR id
1512: in case constraint
1513: of NONE => (VARstr strVar, binding, NONE)
1514: | SOME sgn =>
1515: let val (str,thin) =
1516: SigMatch.match(abs,path,stamps,sgn,binding,param)
1517: in (VARstr strVar, str, thin)
1518: end
1519: end
1520: end
1521: | LET => protect(protectScope,
1522: (fn()=>(advance();
1523: let val locals = sdecs(path,stamps)
1524: val _ = checkToken(IN)
1525: val (bodyexp,bodystr,thin) =
1526: str(abs,constraint,path,stamps,param)
1527: val _ = checkToken(END)
1528: in (LETstr(SEQdec(locals),bodyexp),bodystr,thin)
1529: end)))
1530: | tok => condemn("expected a structure-expression, found " ^
1531: tokenName tok)
1532:
1533: and sdecs(args as (path: spath, stamps: Stampset.stampsets))
1534: : dec list =
1535: let fun sdec() : dec =
1536: if at(STRUCTURE)
1537: then markdec STRdec(strb(false,path,stamps))
1538: else if at(ABSTRACTION)
1539: then markdec ABSdec(strb(true,path,stamps))
1540: else if at(SIGNATURE) (* monster structure hack *)
1541: then (warn "signature found inside structure";
1542: SIGdec(sigb()))
1543: else if at(Token.FUNCTOR) (* monster structure hack *)
1544: then (warn "functor found inside structure";
1545: markdec FCTdec(fctb()))
1546: else if at Token.LOCAL
1547: then let val envLocal = openScope()
1548: val ld1 = sdecs args
1549: val envIn = (checkToken(IN); openScope(); current())
1550: val ld2 = sdecs args
1551: in checkToken(END);
1552: splice(envLocal,envIn);
1553: markdec LOCALdec(SEQdec ld1,SEQdec ld2)
1554: end
1555: else let val dec = ldec(path,stamps)
1556: in Typecheck.decType(dec);
1557: dec
1558: end
1559: in if firstSdec(!nextToken)
1560: then sdec() :: (at(SEMICOLON); sdecs(args))
1561: else nil
1562: end
1563:
1564: (* structure bindings *)
1565:
1566: and strb(abstract:bool,path:spath,stamps:Stampset.stampsets) =
1567: let fun strb1() =
1568: let val name = ident()
1569: val constraint =
1570: if abstract
1571: then SOME(sigconstraint())
1572: else sigconstraint_op()
1573: val _ = checkToken(EQUAL)
1574: val (strexp,str,thin) =
1575: str(abstract,constraint,name::path,stamps,NULLstr)
1576: val strVar = STRvar{access=LVAR(namedLvar(name)),
1577: name=[name],
1578: binding=str}
1579: in (name, strVar,
1580: STRB{strvar=strVar, def=strexp, constraint=constraint, thin=thin})
1581: end
1582: in map (fn (name,strVar,strSyn) => (bindSTR(name,strVar); strSyn))
1583: (rightAssoc(strb1, AND, op ::, single))
1584: end
1585:
1586:
1587: (* functor bindings *)
1588:
1589: and fctb() =
1590: map (fn (name,fctVar,fctSyn) => (bindFCT(name,fctVar); fctSyn))
1591: (rightAssoc(fctb1, AND, op ::, single))
1592:
1593: and fctb1() =
1594: let val name = ident()
1595: val mEntry = openScope()
1596: val (pname,paccess,param,spreadParams) =
1597: (checkToken(LPAREN);
1598: (case !nextToken
1599: of RPAREN => (anonParamName,LVAR(namedLvar(anonParamName)),nullSig,
1600: false)
1601: | ID s => let val tenv = array(0, NULLtyc)
1602: val senv = array(2, NULLstr)
1603: val _ = openNew({path=[~1], strenv=REL{t=tenv,s=senv}},
1604: newTable())
1605: val name = ident()
1606: val access = LVAR(namedLvar(name))
1607: val _ = checkToken(COLON)
1608: val param = sign()
1609: in update(senv,1,param);
1610: bindSTR(name,STRvar{name=[name],
1611: access=access,
1612: binding=INDstr(1)});
1613: (name,access,param,false)
1614: end
1615: | tok => if firstSpec(tok)
1616: then let val plvar = namedLvar(anonParamName)
1617: val param as STRstr{env,table,...} =
1618: sigbody(2,Stampset.newStampsets())
1619: in openOld({path=[~1,1],strenv=env},table);
1620: (anonParamName,LVAR(plvar),param,true)
1621: end
1622: else condemn ("expected functor parameter spec, found "
1623: ^tokenName tok))
1624: before checkToken(RPAREN))
1625: val resSign =
1626: if !nextToken = COLON
1627: then (advance(); SOME(sign()))
1628: else NONE
1629: val _ = if spreadParams
1630: then let val STRstr{table,env,...} = param
1631: and LVAR plvar = paccess
1632: in resetEnv(mEntry);
1633: openOld({path=[plvar],strenv=env},table)
1634: end
1635: else ()
1636: val _ = checkToken(EQUAL)
1637: val bodystamps = Stampset.newStampsets()
1638: val (bodyexp,bodystr,thin) = str(false,resSign,[],bodystamps,param)
1639: val openBody =
1640: case bodystr
1641: of STRstr{stamp=bodystamp,env=DIR,...} =>
1642: Stampset.member(bodystamp,(#strStamps bodystamps))
1643: | _ => false
1644: val paramVis =
1645: case resSign
1646: of SOME _ => true
1647: | NONE => openBody
1648: val body =
1649: if openBody
1650: then Functor.abstractBody(bodystr,param,bodystamps,
1651: Stampset.newStamp(Stampset.sigStamps))
1652: else bodystr
1653: val paramvar = STRvar{name = [pname], access = paccess, binding = param}
1654: val fctv = FCTvar{name=name,
1655: access=LVAR(namedLvar(name)),
1656: binding=FUNCTOR{paramName=pname,
1657: param=param,
1658: body=body,
1659: paramVis=paramVis,
1660: stamps=bodystamps}}
1661: val fb = FCTB{fctvar=fctv, param=paramvar, def=bodyexp, thin=thin,
1662: constraint=resSign}
1663: in resetEnv(mEntry);
1664: (name,fctv,fb)
1665: end
1666:
1667:
1668: (* top level declarations *)
1669:
1670: fun importdec()=
1671: let fun loop() =
1672: (case !nextToken of
1673: SEMICOLON => []
1674: | STRING s => (advance(); s :: loop())
1675: | _ => condemn("string constant (file name) expected, found " ^
1676: tokenName (!nextToken))
1677: )
1678: val files = loop()
1679: in case files of
1680: [] => condemn("string constant (file name) expected, found " ^
1681: tokenName (!nextToken))
1682: | _ => files
1683: end
1684:
1685: val globalStamps = Stampset.globalStamps
1686: val itsym = Symbol.symbol "it"
1687:
1688: fun inner_interdec() =
1689: (prompt := !System.Control.secondaryPrompt;
1690: case !nextToken
1691: of SIGNATURE => (advance(); SIGdec(sigb()))
1692: | Token.FUNCTOR => (advance(); markdec FCTdec(fctb()))
1693: | STRUCTURE =>
1694: (advance(); markdec STRdec(strb(false,[],globalStamps)))
1695: | ABSTRACTION =>
1696: (advance(); markdec STRdec(strb(true,[],globalStamps)))
1697: | IMPORT=>(advance(); IMPORTdec(importdec()))
1698: | EOF => raise Eof
1699: | tok => let val dec =
1700: if firstLdec(!nextToken)
1701: then ldec([],Stampset.globalStamps)
1702: else if firstExp lookFIX (!nextToken)
1703: then (markdec (fn() => VALdec[VB
1704: (protect(protectTyvars(NONE),(fn() =>
1705: {exp=exp(Stampset.globalStamps),
1706: pat=let val v = newVAR(ref nil,itsym)
1707: in bindVAR(itsym,v);
1708: VARpat v
1709: end,
1710: tyvars=currentTyvars()})))]) ())
1711: else condemn("declaration or expression expected, found " ^
1712: tokenName tok)
1713: in Typecheck.decType(dec); dec
1714: end)
1715:
1716: in inner_interdec()
1717: end (* fun interdec *)
1718:
1719: end (* structure Parse *)
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.