1 (* Copyright 1989 by AT&T Bell Laboratories *)
2 open ErrorMsg Symbol Access Basics BasicTypes TypesUtil Absyn
3 open EnvAccess Misc CoreLang Signs Strs TyvarSet
4 fun fire a b c = (a(); b c)
5 fun markexp (e as MARKexp _, _, _) = e
6 | markexp(e,a,b) = if !System.Control.markabsyn
7 then MARKexp(e,a,b) else e
8 fun markdec((d as MARKdec _, e), _, _) = (d,e)
9 | markdec((d,e),a,b) = if !System.Control.markabsyn
10 then (MARKdec(d,a,b),e) else (d,e)
13 let val (d,e) = markdec d
17 fun markdec'' (([d],e),a,b) = markdec'((d,e),a,b)
18 | markdec'' ((s,e),a,b) = markdec'((SEQdec s, e),a,b)
20 fun markstr(f,a,b) $ = case f $
21 of s as (MARKstr _,x,y) => s
22 | s as (t,x,y) => if !System.Control.markabsyn
23 then (MARKstr(t,a,b),x,y) else s
26 val op \/ = union_tyvars
28 fun V(_,vars) = vars and E(e,_) = e
30 fun sequence (do1,do2) (env,a2,a3,a4) =
31 let val (r1,env1) = do1 (env,a2,a3,a4)
32 val (r2,env2) = do2 (Env.atop(env1,env),a2,a3,a4)
33 in (r1 @ r2, Env.atop(env2,env1))
36 fun sequence' (do1,do2) env =
37 let val (r1,env1) = do1 env
38 val (r2,env2) = do2 (Env.atop(env1,env))
39 in (r1 @ r2, Env.atop(env2,env1))
42 fun seqdec (d,e) = ([d],e)
47 | ID of string | TYVAR of string
48 | INT of int | INT0 of int | REAL of string | STRING of string
49 | ABSTRACTION | ABSTYPE | AND
50 | ARROW | AS | BAR | CASE | DATATYPE | DOTDOTDOT | ELSE | END | EQUAL
51 | EQTYPE | EXCEPTION | DO | DOT | DARROW | FN | FUN | FUNCTOR | HANDLE | HASH
52 | IF | IN | INCLUDE | INFIX | INFIXR | LET | LOCAL | NONFIX | OF | OP
53 | OPEN | OVERLOAD | QUERY | RAISE | REC | SHARING | SIG | SIGNATURE | STRUCT
54 | STRUCTURE | THEN | TYPE | VAL | WHILE | WILD | WITH | WITHTYPE | ASTERISK
55 | COLON | COMMA | LBRACE | LBRACKET | LPAREN | RBRACE | RBRACKET | RPAREN
56 | ORELSE | ANDALSO | IMPORT
58 %nonterm ident of string
62 | opid of symbol enved
63 | qid of ((string->symbol) -> symbol list)
64 | qid_p0 of symbol list list
66 | tycon of symbol list
67 | tlabel of (symbol * ty) enved uvars
68 | tlabels of (symbol * ty) list enved uvars
69 | ty' of ty enved uvars
70 | tuple_ty of ty list enved uvars
71 | ty of ty enved uvars
72 | ty0_pc of ty list enved uvars
73 | match of rule list evstamped uvars
74 | rule of rule evstamped uvars
75 | elabel of (symbol * exp) evstamped uvars
76 | elabels of (symbol * exp) list evstamped uvars
77 | exp_ps of exp list evstamped uvars
78 | exp of exp evstamped uvars
79 | app_exp of exp precStack evstamped uvars
80 | aexp of exp evstamped uvars
81 | exp_list of exp list evstamped uvars
82 | exp_2c of exp list evstamped uvars
83 | pat of pat enved uvars
84 | pat' of pat enved uvars
85 | pat'' of pat enved uvars
86 | apat of (pat * fixity * complainer) enved uvars
87 | apat' of (pat * fixity * complainer) enved uvars
88 | apat'' of pat enved uvars
89 | plabel of (symbol * pat) enved uvars
90 | plabels of ((symbol * pat) list * bool) enved uvars
91 | pat_2c of pat list enved uvars
92 | pat_list of pat list enved uvars
93 | vb of vb list evstamped
94 | constraint of ty option enved uvars
95 | rvb of rawrvb list enved
96 | fb' of rawclause list enved uvars
97 | fb of rawclause list list enved uvars
98 | apats of (pat * fixity * complainer) list enved uvars
99 | clause' of (symbol * pat list) enved uvars
100 | clause of rawclause enved uvars
101 | tb of bool -> tb list withenv epathvstamped
102 | tyvars of tyvar list
103 | tyvar_pc of tyvar list
104 | db of (symbol * int * datacon list withenv epathed) list
105 | constrs of (Basics.env * ty -> (symbol * bool * ty) list) uvars
106 | constr of (Basics.env * ty -> symbol * bool * ty) uvars
107 | eb of eb list withenv epathvstamped uvars
108 | qid_p of structureVar list enved
110 | ldec of dec withenv epathvstamped uvars
111 | exp_pa of exp list evstamped
112 | ldecs of dec withenv epathvstamped uvars
116 | strspec of spectype
117 | tyspec of eqprop -> spectype
118 | valspec of spectype
119 | exnspec of spectype
120 | sharespec of spectype
121 | patheqn of (string->symbol) -> symbol list list
122 | sign of bool (* toplevel? *) * bool (* functor param? *) *
123 Structure (*param*) -> signtype
124 | sigconstraint_op of (Basics.env * Structure) -> Structure option
125 | sigb of signatureVar list withenv enved
127 | sdecs of dec list withenv epathnstamped
128 | sdecs' of dec list withenv epathnstamped
129 | sdec of dec withenv epathnstamped
130 | strb of bool -> (symbol*structureVar*strb) list epathstamped
131 | fparam of functorFormal
132 | fctb of (symbol * functorVar * fctb) list enved
133 | importdec of string list
134 | interdec of dec withenv enved
137 %arg (error) : pos * pos -> ErrorMsg.severity -> string -> unit
158 %keyword ABSTRACTION ABSTYPE AND AS CASE DATATYPE DOTDOTDOT ELSE END
159 EQTYPE EXCEPTION DO DARROW FN FUN FUNCTOR HANDLE
160 IF IN INCLUDE INFIX INFIXR LET LOCAL NONFIX OF OP
161 OPEN OVERLOAD RAISE REC SHARING SIG SIGNATURE STRUCT
162 STRUCTURE THEN TYPE VAL WHILE WITH WITHTYPE
163 ORELSE ANDALSO IMPORT
165 %subst EQUAL for DARROW | DARROW for EQUAL | ANDALSO for AND | OF for COLON
166 | COMMA for SEMICOLON | SEMICOLON for COMMA
167 %prefer VAL THEN ELSE LPAREN
170 %value TYVAR ("'bogus")
188 op_op : OP (fn()=> error (OPleft,OPright) WARN "unnecessary `op'")
191 opid : id (fn env => let val (v,f) = var'n'fix id
192 in case lookFIX env f of NONfix => ()
193 | _ => error (idleft,idright) COMPLAIN
194 "nonfix identifier required";
197 | OP ident (fn _ => varSymbol ident)
199 qid : ID DOT qid (fn kind => strSymbol ID :: qid kind)
200 | ident (fn kind => [kind ident])
202 selector: id (labSymbol id)
203 | INT (Symbol.labSymbol(makestring INT))
205 tycon : ID DOT tycon (strSymbol ID :: tycon)
206 | ID ([tycSymbol ID])
208 tlabel : selector COLON ty (fn $ =>(selector, E ty $), V ty)
210 tlabels : tlabel COMMA tlabels (fn $ => E tlabel $ :: E tlabels $,
211 V tlabel \/ V tlabels)
212 | tlabel (fn $ => [E tlabel $], V tlabel)
214 ty' : TYVAR (let val tyv = mkTyvar(mkUBOUND(tyvSymbol TYVAR))
215 in (fn _ => VARty tyv, singleton_tyvar tyv)
218 RBRACE (fn $ => make_recordTy(E tlabels $,
219 error(LBRACEleft,RBRACEright)),
221 | LBRACE RBRACE (fn _ => make_recordTy(nil,
222 error(LBRACEleft,RBRACEright)),
225 RPAREN tycon (fn env =>let val ts = E ty0_pc env
226 in CONty(lookPathArTYC env
228 error (tyconleft,tyconright) COMPLAIN),
232 | LPAREN ty RPAREN (ty)
233 | ty' tycon (fn env =>CONty(lookPathArTYC env (tycon,1,
234 error(tyconleft,tyconright)COMPLAIN),
237 | tycon (fn env =>CONty(lookPathArTYC env (tycon, 0,
238 error(tyconleft,tyconright)COMPLAIN),[]),
241 tuple_ty : ty' ASTERISK
242 tuple_ty (fn $ => E ty' $ :: E tuple_ty $,
245 ty' (fn $ =>[E ty'1 $, E ty'2 $], V ty'1 \/ V ty'2)
247 ty : tuple_ty (fn $ =>tupleTy(E tuple_ty $), V tuple_ty)
248 | ty ARROW ty (fn $ =>CONty(arrowTycon, [E ty1 $, E ty2 $]),
252 ty0_pc : ty COMMA ty (fn $ => [E ty1 $, E ty2 $], V ty1 \/ V ty2)
254 ty0_pc (fn $ => E ty $ :: E ty0_pc $, V ty \/ V ty0_pc)
256 match : rule (fn evst => [E rule evst], V rule)
258 match (fn evst => E rule evst :: E match evst,
262 exp (makeRULE(E pat, fn $ => markexp(E exp $,expleft,expright),
263 error(patleft,patright)),
267 elabel : selector EQUAL
268 exp (fn evst => (selector,E exp evst), V exp)
270 elabels : elabel COMMA
271 elabels (fn evst => (E elabel evst :: E elabels evst),
272 V elabel \/ V elabels)
273 | elabel (fn evst => [E elabel evst], V elabel)
275 exp_ps : exp (fn st => [E exp st], V exp)
277 exp_ps (fn st => E exp st :: E exp_ps st, V exp \/ V exp_ps)
280 match (fn st=> makeHANDLEexp(E exp st, E match st),
284 (fn st=> ORELSEexp(markexp(E exp1 st, exp1left,exp1right),
285 markexp(E exp2 st,exp2left,expright)),
288 (fn st=> ANDALSOexp(markexp(E exp1 st,exp1left,exp1right),
289 markexp(E exp2 st,exp2left,exp2right)),
291 | exp COLON ty (fn (st as (env,_,_))=> CONSTRAINTexp(E exp st,
294 | app_exp (fn st=> exp_finish(E app_exp st,
295 error(app_expright,app_expright)),
298 | FN match (fn st=> markexp(FNexp(completeMatch(E match st)),
302 OF match (fn st=>markexp(CASEexp(E exp st,
303 completeMatch(E match st)),
304 CASEleft,matchright),
307 DO exp (fn st=> WHILEexp(E exp1 st,
308 markexp(E exp2 st,exp2left,exp2right)),
311 ELSE exp (fn st=>IFexp(E exp1 st,
312 markexp(E exp2 st,exp2left,exp2right),
313 markexp(E exp3 st,exp3left,exp3right)),
314 V exp1 \/ V exp2 \/ V exp3)
315 | RAISE exp (fn st=>markexp(RAISEexp(E exp st),RAISEleft,expright),
318 app_exp : aexp (fn st => exp_start(markexp(E aexp st, aexpleft,aexpright),
320 error (aexpleft,aexpright)),
322 | ident (fn (env,_,_) =>
323 let val e = error(identleft,identright)
324 val (v,f) = var'n'fix ident
325 in exp_start(markexp(lookID env (v,e),
326 identleft,identright),
330 | app_exp aexp (fn st => exp_parse(E app_exp st,
331 markexp(E aexp st, aexpleft,aexpright),
333 error (aexpleft,aexpright)),
335 | app_exp ident (fn (st as (env,_,_)) =>
336 let val e = error(identleft,identright)
337 val (v,f) = var'n'fix ident
338 in exp_parse(E app_exp st,
339 markexp(lookID env (v,e),
340 identleft,identright),
345 aexp : OP ident (fn (env,_,_) => lookID env (varSymbol ident, error(identleft,identright)),
347 | ID DOT qid (fn (env,_,_) =>
348 varcon(lookPathVARCON env (strSymbol ID
350 error(IDleft,qidright)COMPLAIN)),
352 | int (fn st => INTexp int, no_tyvars)
353 | REAL (fn st => REALexp REAL, no_tyvars)
354 | STRING (fn st => STRINGexp STRING, no_tyvars)
355 | HASH selector (fn st => SELECTORexp selector, no_tyvars)
356 | LBRACE elabels RBRACE (fn st=> makeRECORDexp(E elabels st,
357 error(LBRACEleft,RBRACEright)),
359 | LBRACE RBRACE (fn st=> RECORDexp nil, no_tyvars)
360 | LPAREN RPAREN (fn st=> unitExp, no_tyvars)
361 | LPAREN exp_ps RPAREN (fn st=> SEQexp(E exp_ps st), V exp_ps)
362 | LPAREN exp_2c RPAREN (fn st=> TUPLEexp(E exp_2c st), V exp_2c)
364 RBRACKET (fn st=> LISTexp(E exp_list st), V exp_list)
365 | LBRACKET RBRACKET (fn st=> nilExp, no_tyvars)
367 IN exp_ps END (fn (env,tv,st) =>
368 let val (d,env') = E ldecs(env,[],tv,st)
369 val e = E exp_ps (Env.atop(env',env),tv,st)
370 in markexp(LETexp(d,SEQexp e),
375 exp_2c : exp COMMA exp_2c (fn st=> E exp st :: E exp_2c st,
377 | exp COMMA exp (fn st=> [E exp1 st, E exp2 st],
380 exp_list : exp (fn st=> [E exp st], V exp)
381 | exp COMMA exp_list (fn st=> E exp st :: E exp_list st,
385 | apat apats (fn $ => make_app_pat(E apat $ ::E apats $),
388 pat' : pat AS pat (fn $ => layered(E pat1 $, E pat2 $,
389 error(pat1left,pat1right)),
394 COLON ty (fn env => CONSTRAINTpat(
395 make_app_pat(E apat env ::E apats env),
397 V apat \/ V apats \/ V ty)
398 | pat'' COLON ty (fn env => CONSTRAINTpat(E pat'' env, E ty env),
402 | LPAREN pat RPAREN (fn $ =>(E pat $,NONfix,error(LPARENleft,RPARENright)),
405 apat' : apat'' (fn $ =>(E apat'' $,NONfix,error(apat''left,apat''right)),
408 let val e = error(idleft,idright)
409 val (v,f) = var'n'fix id
410 in (pat_id env v, lookFIX env f, e)
413 | LPAREN RPAREN (fn _ =>(unitPat,NONfix,
414 error(LPARENleft,RPARENright)),
417 pat_list RPAREN (fn $ =>(TUPLEpat(E pat $ ::E pat_list $),
418 NONfix,error(LPARENleft,RPARENright)),
422 apat'' : OP ident (fn env =>pat_id env(varSymbol ident), no_tyvars)
423 | ID DOT qid (fn env =>qid_pat env (strSymbol ID :: qid varSymbol,
424 error(IDleft,qidright)),
426 | int (fn _ =>INTpat int, no_tyvars)
427 | REAL (fn _ =>REALpat REAL, no_tyvars)
428 | STRING (fn _ =>STRINGpat STRING, no_tyvars)
429 | WILD (fn _ =>WILDpat, no_tyvars)
430 | LBRACKET RBRACKET (fn _ =>LISTpat nil, no_tyvars)
432 RBRACKET (fn $ =>LISTpat(E pat_list $), V pat_list)
433 | LBRACE RBRACE (fn _ =>makeRECORDpat((nil,false),
434 error(LBRACEleft,RBRACEright)),
436 | LBRACE plabels RBRACE (fn $ =>makeRECORDpat(E plabels $,
437 error(LBRACEleft,RBRACEright)),
440 plabel : selector EQUAL pat (fn $ => (selector,E pat $), V pat)
441 | ID (fn env => (labSymbol ID, pat_id env(varSymbol ID)), no_tyvars)
442 | ID AS pat (fn env => (labSymbol ID, LAYEREDpat(pat_id env (varSymbol ID),
445 | ID COLON ty (fn env => (labSymbol ID, CONSTRAINTpat(pat_id env (varSymbol ID),
448 | ID COLON ty AS pat (fn env => (labSymbol ID, LAYEREDpat(CONSTRAINTpat(
449 pat_id env (varSymbol ID),
450 E ty env), E pat env)),
453 plabels : plabel COMMA
454 plabels (fn $ =>let val (a,(b,fx))=(E plabel $,E plabels $)
457 V plabel \/ V plabels)
458 | plabel (fn $ => ([E plabel $],false), V plabel)
459 | DOTDOTDOT (fn _ => (nil, true), no_tyvars)
461 pat_list: pat (fn $ => [E pat $], V pat)
462 | pat COMMA pat_list (fn $ => E pat $ :: E pat_list $,
465 vb : vb AND vb (fn st=> vb1 st @ vb2 st)
466 | pat EQUAL exp (valbind(pat, exp))
468 constraint : (fn _ =>NONE, no_tyvars)
469 | COLON ty (fn env =>SOME(E ty env), V ty)
471 rvb : opid constraint
472 EQUAL FN match (fn env =>[{name=opid env,
473 ty=constraint,match=match}])
474 | rvb AND rvb (fn env => (rvb1 env) @ (rvb2 env))
476 fb' : clause (fn $ =>[E clause $], V clause)
477 | clause BAR fb' (fn $ =>E clause $ ::E fb' $, V clause \/ V fb')
479 fb : fb' (fn $ => [checkFB(E fb' $,error(fb'left,fb'right))],
481 | fb' AND fb (fn $ =>
482 checkFB(E fb' $,error(fb'left,fb'right)) :: E fb $, V fb' \/ V fb)
484 clause' : LPAREN apat apats
485 RPAREN apats (fn $ =>makecl(E apat $ ::E apats1 $,E apats2 $),
486 V apat \/ V apats1 \/ V apats2)
488 RPAREN apats (fn $ =>makecl([],(E pat' $,NONfix,
489 error(LPARENleft,RPARENright))
492 | apat' apats (fn $ =>makecl([],E apat' $ ::E apats $),
495 apats : (fn _ =>nil, no_tyvars)
496 | apat apats (fn $ => E apat $ ::E apats $,
499 clause : clause' constraint
501 let val (id,pats) = E clause' env
502 in {name=id,pats=pats,
503 resultty=E constraint env,
504 exp=fn $ => markexp(E exp $,expleft,expright),
505 err=error(clause'left,clause'right)}
507 V clause' \/ V constraint \/ V exp)
509 tb : tyvars ID EQUAL ty (makeTB(tyvars, tycSymbol ID, ty,
510 error(tyleft,tyright)))
511 | tb AND tb (fn nw => sequence(tb1 nw,tb2 nw))
513 tyvars : TYVAR ([mkTyvar(mkUBOUND(tyvSymbol TYVAR))])
514 | LPAREN tyvar_pc RPAREN (checkUniq(error(tyvar_pcleft,tyvar_pcright),
515 "duplicate type variable")
516 (List.map(fn ref(UBOUND{name,...})=>name)
521 tyvar_pc: TYVAR ([mkTyvar(mkUBOUND(tyvSymbol TYVAR))])
522 | TYVAR COMMA tyvar_pc (mkTyvar(mkUBOUND(tyvSymbol TYVAR)) :: tyvar_pc)
524 db : db AND db (db1 @ db2)
525 | tyvars ident EQUAL constrs (let val name = tycSymbol ident
526 in [(name,length tyvars,
527 makeDB'(tyvars,name,constrs,
528 error(constrsleft,constrsright)))]
531 constrs : constr (fn $ => [E constr $], V constr)
532 | constr BAR constrs (fn $ => E constr $ :: E constrs $,
533 V constr \/ V constrs)
535 constr : op_op ident (fire op_op (fn(_,t)=> (varSymbol ident,true,t)),
537 | op_op ident OF ty (fire op_op (fn(env,t)=> (varSymbol ident,false,
538 CONty(arrowTycon,[E ty env, t]))),
541 eb : op_op ident (fire op_op (makeEB(varSymbol ident)), no_tyvars)
542 | op_op ident OF ty (fire op_op (makeEBof(varSymbol ident,E ty,
543 error(tyleft,tyright))),
545 | op_op ident EQUAL qid (fire op_op (makeEBeq(varSymbol ident,qid varSymbol,
546 error(qidleft,qidright))),
548 | eb AND eb (sequence(E eb1,E eb2),
551 qid_p0 : qid ([qid strSymbol])
552 | qid qid_p0 (qid strSymbol :: qid_p0)
554 qid_p : qid (fn env => [getSTRpath env (qid strSymbol,error(qidleft,qidright))])
555 | qid qid_p (fn env => getSTRpath env (qid strSymbol,error(qidleft,qidright)) :: qid_p env)
557 fixity : INFIX (infixleft 0)
558 | INFIX int (infixleft int)
559 | INFIXR (infixright 0)
560 | INFIXR int (infixright int)
563 ldec : VAL vb (makeVALdec(vb,error(vbleft,vbright)),
565 | VAL REC rvb (makeVALRECdec (rvb,error(rvbleft,rvbright)),
567 | FUN fb (makeFUNdec fb, no_tyvars)
568 | TYPE tb ((fn $ => makeTYPEdec(tb true $,
569 error(tbleft,tbright))),
571 | DATATYPE db (makeDB(db, nullTB), no_tyvars)
573 WITHTYPE tb (makeDB(db,tb), no_tyvars)
575 WITH ldecs END (makeABSTYPEdec(db,nullTB,E ldecs),V ldecs)
578 WITH ldecs END (makeABSTYPEdec(db,tb,E ldecs),V ldecs)
579 | EXCEPTION eb ((fn $ => makeEXCEPTIONdec(E eb $,
580 error(ebleft,ebright))),
582 | OPEN qid_p (makeOPENdec qid_p, no_tyvars)
583 | fixity ops (makeFIXdec(fixity,ops), no_tyvars)
584 | OVERLOAD ident COLON
585 ty AS exp_pa (makeOVERLOADdec(varSymbol ident,ty,exp_pa),
588 exp_pa : exp (fn st => [E exp st])
589 | exp AND exp_pa (fn st => E exp st :: exp_pa st)
591 ldecs : (fn $ => (SEQdec nil,Env.empty), no_tyvars)
592 | ldec ldecs (makeSEQdec(fn $ => markdec(E ldec $,ldecleft,ldecright),
595 | SEMICOLON ldecs (ldecs)
597 IN ldecs END ldecs (makeSEQdec(fn $ =>
598 markdec(makeLOCALdec(E ldecs1,E ldecs2) $,
601 V ldecs1 \/ V ldecs2 \/ V ldecs3)
603 ops : ident ([fixSymbol ident])
604 | ident ops (fixSymbol ident :: ops)
606 spec_s : (fn $ => nil)
607 | spec spec_s (fn $ => spec $ @ spec_s $)
608 | SEMICOLON spec_s (spec_s)
610 spec : STRUCTURE strspec (strspec)
611 | DATATYPE db (make_dtyspec db)
612 | TYPE tyspec (tyspec UNDEF)
613 | EQTYPE tyspec (tyspec YES)
614 | VAL valspec (valspec)
615 | EXCEPTION exnspec (exnspec)
616 | fixity ops (make_fixityspec(fixity,ops))
617 | SHARING sharespec (sharespec)
618 | OPEN qid_p0 (make_openspec(qid_p0,
619 error(OPENleft,qid_p0right)))
621 IN spec_s END (fn $ => (spec_s1 $;
622 error(spec_s1left,spec_s1right) WARN
623 "LOCAL specs are only partially implemented";
625 | INCLUDE ident (make_includespec (sigSymbol ident,error(identleft,identright)))
627 strspec : strspec AND strspec (fn $ => strspec1 $ @ strspec2 $)
628 | ident COLON sign (make_strspec(strSymbol ident, sign(false,false,NULLstr)))
630 tyspec : tyspec AND tyspec (fn eq => fn $ =>
631 tyspec1 eq $ @ tyspec2 eq $)
632 | tyvars ID (fn eq => make_tyspec(eq,tyvars,tycSymbol ID,
633 error(tyvarsleft,IDright)))
635 valspec : valspec AND valspec (fn $ => valspec1 $ @ valspec2 $)
636 | op_op ident COLON ty (fire op_op (make_valspec(varSymbol ident,ty)))
638 exnspec : exnspec AND exnspec (fn $ => exnspec1 $ @ exnspec2 $)
639 | ident (make_exnspec(varSymbol ident))
640 | ident OF ty (make_exnspecOF (varSymbol ident,ty))
642 sharespec: sharespec AND
643 sharespec (fn $ => sharespec1 $ @ sharespec2 $)
644 | TYPE patheqn (make_type_sharespec(patheqn tycSymbol))
645 | patheqn (make_str_sharespec(patheqn strSymbol))
647 patheqn: qid EQUAL qid (fn kind => [qid1 kind, qid2 kind])
648 | qid EQUAL patheqn (fn kind => qid kind :: patheqn kind)
650 sign : ID (makeSIGid(sigSymbol ID,error(IDleft,IDright)))
651 | SIG spec_s END (makeSIG(spec_s,error(spec_sleft,spec_sright)))
653 sigconstraint_op : (fn _ => NONE)
654 | COLON sign (fn (env,param) =>
655 SOME(sign(true,false,param) (env,Stampset.newStampsets())))
657 sigb : sigb AND sigb (sequence'(sigb1,sigb2))
658 | ident EQUAL sign (make_sigb(sigSymbol ident, sign(true,false,NULLstr)))
660 str : qid (markstr(make_str_qid(qid strSymbol,
661 error(qidleft,qidright)),qidleft,qidright))
662 | STRUCT sdecs END (markstr(make_str_struct(sdecs,
663 error(STRUCTleft,ENDright)),
664 STRUCTleft,ENDright))
666 RPAREN (markstr(make_str_app(fctSymbol ID,error(IDleft,IDright),
667 (fn $ => let val (s,s')=spread_args sdecs $
668 in (MARKstr(s,sdecsleft,sdecsright)
670 end)),IDleft,RPARENright))
671 | ID LPAREN str RPAREN (markstr(make_str_app(fctSymbol ID,error(IDleft,IDright),
672 single_arg str),IDleft,RPARENright))
673 | LET sdecs IN str END (markstr(make_str_let(sdecs,str),LETleft,ENDright))
675 sdecs : sdec sdecs (sequence(fn $ => markdec'(sdec $,sdecleft,
678 | SEMICOLON sdecs (sdecs)
679 | LOCAL sdecs IN sdecs
680 END sdecs (sequence(fn $ => markdec''(makeLOCALsdecs(sdecs1,sdecs2) $,LOCALleft,ENDright),
682 | (fn $ => (nil,Env.empty))
684 sdecs' : sdec sdecs' (sequence(fn $ => markdec'(sdec $,sdecleft,sdecright),
686 | LOCAL sdecs IN sdecs
687 END sdecs' (sequence(fn $ =>
688 markdec''(makeLOCALsdecs(sdecs1,sdecs2) $,
692 | LOCAL sdecs IN sdecs
693 END (fn $ => markdec''(makeLOCALsdecs(sdecs1,sdecs2) $,LOCALleft,ENDright))
695 | sdec (fn $ => seqdec(markdec(sdec $,sdecleft,sdecright)))
697 sdec : STRUCTURE strb (makeSTRBs(strb false))
698 | ABSTRACTION strb (makeSTRBs(strb true))
699 | SIGNATURE sigb (makeSIGdec(sigb,error(SIGNATUREleft,sigbright)))
700 | FUNCTOR fctb (makeFCTdec(fctb,error(FUNCTORleft,fctbright)))
701 | ldec (fn (env,pa,top,st) =>
702 let val (dec,env') = markdec(E ldec(env,pa,no_tyvars,st),ldecleft,ldecright)
703 in Typecheck.decType(Env.atop(env',env),dec,top,error,
704 (ldecleft,ldecright));
708 strb : ident sigconstraint_op
709 EQUAL str (makeSTRB(strSymbol ident,sigconstraint_op,str,
710 error(sigconstraint_opleft,sigconstraint_opright)))
711 | strb AND strb (fn a => fn $ => strb1 a $ @ strb2 a $)
713 fparam : ID COLON sign (single_formal(strSymbol ID, sign(true,true,NULLstr)))
714 | spec_s (spread_formal(spec_s,
715 error(spec_sleft,spec_sright)))
717 fctb : ident LPAREN fparam RPAREN
718 sigconstraint_op EQUAL str (makeFCTB(fctSymbol ident,fparam,
719 sigconstraint_op,str,
720 error(strleft,strright)))
721 | fctb AND fctb (fn $ => fctb1 $ @ fctb2 $)
723 importdec: STRING ([STRING])
724 | STRING importdec (STRING :: importdec)
726 interdec: sdecs' (fn env=> let val (s,e)= sdecs'(env,[],true,Stampset.globalStamps)
727 in markdec((SEQdec s,e),sdecs'left,sdecs'right)
729 | IMPORT importdec (fn env =>(IMPORTdec importdec,env))
730 | exp (fn env=>markdec(toplevelexp(env,exp,error,(expleft,expright)),