HCoop / hcoop / debian / mlton.git / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | blame (incremental) | history | HEAD
Import Upstream version 20180207
[hcoop/debian/mlton.git] / benchmark / tests / DATA / ml.grm
CommitLineData
7f918cf1
CE		 1(* Copyright 1989 by AT&T Bell Laboratories *)
2open ErrorMsg Symbol Access Basics BasicTypes TypesUtil Absyn
3open EnvAccess Misc CoreLang Signs Strs TyvarSet
4fun fire a b c = (a(); b c)
5fun markexp (e as MARKexp _, _, _) = e
6 | markexp(e,a,b) = if !System.Control.markabsyn
7 then MARKexp(e,a,b) else e
8fun 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)
11
12fun markdec' d =
13 let val (d,e) = markdec d
14 in ([d],e)
15 end
16
17fun markdec'' (([d],e),a,b) = markdec'((d,e),a,b)
18 | markdec'' ((s,e),a,b) = markdec'((SEQdec s, e),a,b)
19
20fun 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
24
25infix \/
26val op \/ = union_tyvars
27
28fun V(_,vars) = vars and E(e,_) = e
29
30fun 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))
34 end
35
36fun 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))
40 end
41
42fun seqdec (d,e) = ([d],e)
43
44%%
45%term
46 EOF | SEMICOLON
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
57
58%nonterm ident of string
59 | id of string
60 | int of int
61 | op_op of unit susp
62 | opid of symbol enved
63 | qid of ((string->symbol) -> symbol list)
64 | qid_p0 of symbol list list
65 | selector of symbol
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
109 | fixity of fixity
110 | ldec of dec withenv epathvstamped uvars
111 | exp_pa of exp list evstamped
112 | ldecs of dec withenv epathvstamped uvars
113 | ops of symbol list
114 | spec_s of spectype
115 | spec of spectype
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
126 | str of strtype
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
135
136%pos int
137%arg (error) : pos * pos -> ErrorMsg.severity -> string -> unit
138%pure
139%start interdec
140%eop EOF SEMICOLON
141%noshift EOF
142
143%nonassoc WITHTYPE
144%right AND
145%right ARROW
146%right AS
147%right DARROW
148%left DO
149%left ELSE
150%left RAISE
151%right HANDLE
152%left ORELSE
153%left ANDALSO
154%left COLON
155
156%name ML
157
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
164
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
168
169%value ID ("bogus")
170%value TYVAR ("'bogus")
171%value INT (1)
172%value INT0 (0)
173%value REAL ("0.0")
174%value STRING ("")
175
176%%
177
178int : INT (INT)
179 | INT0 (INT0)
180
181id : ID (ID)
182 | ASTERISK ("*")
183
184ident : ID (ID)
185 | ASTERISK ("*")
186 | EQUAL ("=")
187
188op_op : OP (fn()=> error (OPleft,OPright) WARN "unnecessary `op'")
189 | (fn()=>())
190
191opid : 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";
195 v
196 end)
197 | OP ident (fn _ => varSymbol ident)
198
199qid : ID DOT qid (fn kind => strSymbol ID :: qid kind)
200 | ident (fn kind => [kind ident])
201
202selector: id (labSymbol id)
203 | INT (Symbol.labSymbol(makestring INT))
204
205tycon : ID DOT tycon (strSymbol ID :: tycon)
206 | ID ([tycSymbol ID])
207
208tlabel : selector COLON ty (fn $ =>(selector, E ty $), V ty)
209
210tlabels : tlabel COMMA tlabels (fn $ => E tlabel $ :: E tlabels $,
211 V tlabel \/ V tlabels)
212 | tlabel (fn $ => [E tlabel $], V tlabel)
213
214ty' : TYVAR (let val tyv = mkTyvar(mkUBOUND(tyvSymbol TYVAR))
215 in (fn _ => VARty tyv, singleton_tyvar tyv)
216 end)
217 | LBRACE tlabels
218 RBRACE (fn $ => make_recordTy(E tlabels $,
219 error(LBRACEleft,RBRACEright)),
220 V tlabels)
221 | LBRACE RBRACE (fn _ => make_recordTy(nil,
222 error(LBRACEleft,RBRACEright)),
223 no_tyvars)
224 | LPAREN ty0_pc
225 RPAREN tycon (fn env =>let val ts = E ty0_pc env
226 in CONty(lookPathArTYC env
227 (tycon,length ts,
228 error (tyconleft,tyconright) COMPLAIN),
229 ts)
230 end,
231 V ty0_pc)
232 | LPAREN ty RPAREN (ty)
233 | ty' tycon (fn env =>CONty(lookPathArTYC env (tycon,1,
234 error(tyconleft,tyconright)COMPLAIN),
235 [E ty' env]),
236 V ty')
237 | tycon (fn env =>CONty(lookPathArTYC env (tycon, 0,
238 error(tyconleft,tyconright)COMPLAIN),[]),
239 no_tyvars)
240
241tuple_ty : ty' ASTERISK
242 tuple_ty (fn $ => E ty' $ :: E tuple_ty $,
243 V ty' \/ V tuple_ty)
244 | ty' ASTERISK
245 ty' (fn $ =>[E ty'1 $, E ty'2 $], V ty'1 \/ V ty'2)
246
247ty : tuple_ty (fn $ =>tupleTy(E tuple_ty $), V tuple_ty)
248 | ty ARROW ty (fn $ =>CONty(arrowTycon, [E ty1 $, E ty2 $]),
249 V ty1 \/ V ty2)
250 | ty' (ty')
251
252ty0_pc : ty COMMA ty (fn $ => [E ty1 $, E ty2 $], V ty1 \/ V ty2)
253 | ty COMMA
254 ty0_pc (fn $ => E ty $ :: E ty0_pc $, V ty \/ V ty0_pc)
255
256match : rule (fn evst => [E rule evst], V rule)
257 | rule BAR
258 match (fn evst => E rule evst :: E match evst,
259 V rule \/ V match)
260
261rule : pat DARROW
262 exp (makeRULE(E pat, fn $ => markexp(E exp $,expleft,expright),
263 error(patleft,patright)),
264 V pat \/ V exp)
265
266
267elabel : selector EQUAL
268 exp (fn evst => (selector,E exp evst), V exp)
269
270elabels : 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)
274
275exp_ps : exp (fn st => [E exp st], V exp)
276 | exp SEMICOLON
277 exp_ps (fn st => E exp st :: E exp_ps st, V exp \/ V exp_ps)
278
279exp : exp HANDLE
280 match (fn st=> makeHANDLEexp(E exp st, E match st),
281 V exp \/ V match)
282
283 | exp ORELSE exp
284 (fn st=> ORELSEexp(markexp(E exp1 st, exp1left,exp1right),
285 markexp(E exp2 st,exp2left,expright)),
286 V exp1 \/ V exp2)
287 | exp ANDALSO exp
288 (fn st=> ANDALSOexp(markexp(E exp1 st,exp1left,exp1right),
289 markexp(E exp2 st,exp2left,exp2right)),
290 V exp1 \/ V exp2)
291 | exp COLON ty (fn (st as (env,_,_))=> CONSTRAINTexp(E exp st,
292 E ty env),
293 V exp \/ V ty)
294 | app_exp (fn st=> exp_finish(E app_exp st,
295 error(app_expright,app_expright)),
296 V app_exp)
297
298 | FN match (fn st=> markexp(FNexp(completeMatch(E match st)),
299 FNleft,matchright),
300 V match)
301 | CASE exp
302 OF match (fn st=>markexp(CASEexp(E exp st,
303 completeMatch(E match st)),
304 CASEleft,matchright),
305 V exp \/ V match)
306 | WHILE exp
307 DO exp (fn st=> WHILEexp(E exp1 st,
308 markexp(E exp2 st,exp2left,exp2right)),
309 V exp1 \/ V exp2)
310 | IF exp THEN exp
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),
316 V exp)
317
318app_exp : aexp (fn st => exp_start(markexp(E aexp st, aexpleft,aexpright),
319 NONfix,
320 error (aexpleft,aexpright)),
321 V aexp)
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),
327 lookFIX env f, e)
328 end,
329 no_tyvars)
330 | app_exp aexp (fn st => exp_parse(E app_exp st,
331 markexp(E aexp st, aexpleft,aexpright),
332 NONfix,
333 error (aexpleft,aexpright)),
334 V app_exp \/ V aexp)
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),
341 lookFIX env f, e)
342 end,
343 V app_exp)
344
345aexp : OP ident (fn (env,_,_) => lookID env (varSymbol ident, error(identleft,identright)),
346 no_tyvars)
347 | ID DOT qid (fn (env,_,_) =>
348 varcon(lookPathVARCON env (strSymbol ID
349 ::(qid varSymbol),
350 error(IDleft,qidright)COMPLAIN)),
351 no_tyvars)
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)),
358 V elabels)
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)
363 | LBRACKET exp_list
364 RBRACKET (fn st=> LISTexp(E exp_list st), V exp_list)
365 | LBRACKET RBRACKET (fn st=> nilExp, no_tyvars)
366 | LET ldecs
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),
371 LETleft,ENDright)
372 end,
373 V exp_ps \/ V ldecs)
374
375exp_2c : exp COMMA exp_2c (fn st=> E exp st :: E exp_2c st,
376 V exp \/ V exp_2c)
377 | exp COMMA exp (fn st=> [E exp1 st, E exp2 st],
378 V exp1 \/ V exp2)
379
380exp_list : exp (fn st=> [E exp st], V exp)
381 | exp COMMA exp_list (fn st=> E exp st :: E exp_list st,
382 V exp \/ V exp_list)
383
384pat : pat' (pat')
385 | apat apats (fn $ => make_app_pat(E apat $ ::E apats $),
386 V apat \/ V apats)
387
388pat' : pat AS pat (fn $ => layered(E pat1 $, E pat2 $,
389 error(pat1left,pat1right)),
390 V pat1 \/ V pat2)
391 | pat'' (pat'')
392
393pat'' : apat apats
394 COLON ty (fn env => CONSTRAINTpat(
395 make_app_pat(E apat env ::E apats env),
396 E ty env),
397 V apat \/ V apats \/ V ty)
398 | pat'' COLON ty (fn env => CONSTRAINTpat(E pat'' env, E ty env),
399 V pat'' \/ V ty)
400
401apat : apat' (apat')
402 | LPAREN pat RPAREN (fn $ =>(E pat $,NONfix,error(LPARENleft,RPARENright)),
403 V pat)
404
405apat' : apat'' (fn $ =>(E apat'' $,NONfix,error(apat''left,apat''right)),
406 V apat'')
407 | id (fn env =>
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)
411 end,
412 no_tyvars)
413 | LPAREN RPAREN (fn _ =>(unitPat,NONfix,
414 error(LPARENleft,RPARENright)),
415 no_tyvars)
416 | LPAREN pat COMMA
417 pat_list RPAREN (fn $ =>(TUPLEpat(E pat $ ::E pat_list $),
418 NONfix,error(LPARENleft,RPARENright)),
419 V pat \/ V pat_list)
420
421
422apat'' : 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)),
425 no_tyvars)
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)
431 | LBRACKET pat_list
432 RBRACKET (fn $ =>LISTpat(E pat_list $), V pat_list)
433 | LBRACE RBRACE (fn _ =>makeRECORDpat((nil,false),
434 error(LBRACEleft,RBRACEright)),
435 no_tyvars)
436 | LBRACE plabels RBRACE (fn $ =>makeRECORDpat(E plabels $,
437 error(LBRACEleft,RBRACEright)),
438 V plabels)
439
440plabel : 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),
443 E pat env)),
444 V pat)
445 | ID COLON ty (fn env => (labSymbol ID, CONSTRAINTpat(pat_id env (varSymbol ID),
446 E ty env)),
447 V ty)
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)),
451 V ty \/ V pat)
452
453plabels : plabel COMMA
454 plabels (fn $ =>let val (a,(b,fx))=(E plabel $,E plabels $)
455 in (a::b, fx)
456 end,
457 V plabel \/ V plabels)
458 | plabel (fn $ => ([E plabel $],false), V plabel)
459 | DOTDOTDOT (fn _ => (nil, true), no_tyvars)
460
461pat_list: pat (fn $ => [E pat $], V pat)
462 | pat COMMA pat_list (fn $ => E pat $ :: E pat_list $,
463 V pat \/ V pat_list)
464
465vb : vb AND vb (fn st=> vb1 st @ vb2 st)
466 | pat EQUAL exp (valbind(pat, exp))
467
468constraint : (fn _ =>NONE, no_tyvars)
469 | COLON ty (fn env =>SOME(E ty env), V ty)
470
471rvb : 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))
475
476fb' : clause (fn $ =>[E clause $], V clause)
477 | clause BAR fb' (fn $ =>E clause $ ::E fb' $, V clause \/ V fb')
478
479fb : fb' (fn $ => [checkFB(E fb' $,error(fb'left,fb'right))],
480 V fb')
481 | fb' AND fb (fn $ =>
482 checkFB(E fb' $,error(fb'left,fb'right)) :: E fb $, V fb' \/ V fb)
483
484clause' : LPAREN apat apats
485 RPAREN apats (fn $ =>makecl(E apat $ ::E apats1 $,E apats2 $),
486 V apat \/ V apats1 \/ V apats2)
487 | LPAREN pat'
488 RPAREN apats (fn $ =>makecl([],(E pat' $,NONfix,
489 error(LPARENleft,RPARENright))
490 ::E apats $),
491 V pat' \/ V apats)
492 | apat' apats (fn $ =>makecl([],E apat' $ ::E apats $),
493 V apat' \/ V apats)
494
495apats : (fn _ =>nil, no_tyvars)
496 | apat apats (fn $ => E apat $ ::E apats $,
497 V apat \/ V apats)
498
499clause : clause' constraint
500 EQUAL exp (fn env =>
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)}
506 end,
507 V clause' \/ V constraint \/ V exp)
508
509tb : tyvars ID EQUAL ty (makeTB(tyvars, tycSymbol ID, ty,
510 error(tyleft,tyright)))
511 | tb AND tb (fn nw => sequence(tb1 nw,tb2 nw))
512
513tyvars : 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)
517 tyvar_pc);
518 tyvar_pc)
519 | (nil)
520
521tyvar_pc: TYVAR ([mkTyvar(mkUBOUND(tyvSymbol TYVAR))])
522 | TYVAR COMMA tyvar_pc (mkTyvar(mkUBOUND(tyvSymbol TYVAR)) :: tyvar_pc)
523
524db : 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)))]
529 end)
530
531constrs : constr (fn $ => [E constr $], V constr)
532 | constr BAR constrs (fn $ => E constr $ :: E constrs $,
533 V constr \/ V constrs)
534
535constr : op_op ident (fire op_op (fn(_,t)=> (varSymbol ident,true,t)),
536 no_tyvars)
537 | op_op ident OF ty (fire op_op (fn(env,t)=> (varSymbol ident,false,
538 CONty(arrowTycon,[E ty env, t]))),
539 V ty)
540
541eb : 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))),
544 V ty)
545 | op_op ident EQUAL qid (fire op_op (makeEBeq(varSymbol ident,qid varSymbol,
546 error(qidleft,qidright))),
547 no_tyvars)
548 | eb AND eb (sequence(E eb1,E eb2),
549 V eb1 \/ V eb2)
550
551qid_p0 : qid ([qid strSymbol])
552 | qid qid_p0 (qid strSymbol :: qid_p0)
553
554qid_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)
556
557fixity : INFIX (infixleft 0)
558 | INFIX int (infixleft int)
559 | INFIXR (infixright 0)
560 | INFIXR int (infixright int)
561 | NONFIX (NONfix)
562
563ldec : VAL vb (makeVALdec(vb,error(vbleft,vbright)),
564 no_tyvars)
565 | VAL REC rvb (makeVALRECdec (rvb,error(rvbleft,rvbright)),
566 no_tyvars)
567 | FUN fb (makeFUNdec fb, no_tyvars)
568 | TYPE tb ((fn $ => makeTYPEdec(tb true $,
569 error(tbleft,tbright))),
570 no_tyvars)
571 | DATATYPE db (makeDB(db, nullTB), no_tyvars)
572 | DATATYPE db
573 WITHTYPE tb (makeDB(db,tb), no_tyvars)
574 | ABSTYPE db
575 WITH ldecs END (makeABSTYPEdec(db,nullTB,E ldecs),V ldecs)
576 | ABSTYPE db
577 WITHTYPE tb
578 WITH ldecs END (makeABSTYPEdec(db,tb,E ldecs),V ldecs)
579 | EXCEPTION eb ((fn $ => makeEXCEPTIONdec(E eb $,
580 error(ebleft,ebright))),
581 V eb)
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),
586 no_tyvars)
587
588exp_pa : exp (fn st => [E exp st])
589 | exp AND exp_pa (fn st => E exp st :: exp_pa st)
590
591ldecs : (fn $ => (SEQdec nil,Env.empty), no_tyvars)
592 | ldec ldecs (makeSEQdec(fn $ => markdec(E ldec $,ldecleft,ldecright),
593 E ldecs),
594 V ldec \/ V ldecs)
595 | SEMICOLON ldecs (ldecs)
596 | LOCAL ldecs
597 IN ldecs END ldecs (makeSEQdec(fn $ =>
598 markdec(makeLOCALdec(E ldecs1,E ldecs2) $,
599 LOCALleft,ENDright),
600 E ldecs3),
601 V ldecs1 \/ V ldecs2 \/ V ldecs3)
602
603ops : ident ([fixSymbol ident])
604 | ident ops (fixSymbol ident :: ops)
605
606spec_s : (fn $ => nil)
607 | spec spec_s (fn $ => spec $ @ spec_s $)
608 | SEMICOLON spec_s (spec_s)
609
610spec : 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)))
620 | LOCAL spec_s
621 IN spec_s END (fn $ => (spec_s1 $;
622 error(spec_s1left,spec_s1right) WARN
623 "LOCAL specs are only partially implemented";
624 spec_s2 $))
625 | INCLUDE ident (make_includespec (sigSymbol ident,error(identleft,identright)))
626
627strspec : strspec AND strspec (fn $ => strspec1 $ @ strspec2 $)
628 | ident COLON sign (make_strspec(strSymbol ident, sign(false,false,NULLstr)))
629
630tyspec : 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)))
634
635valspec : valspec AND valspec (fn $ => valspec1 $ @ valspec2 $)
636 | op_op ident COLON ty (fire op_op (make_valspec(varSymbol ident,ty)))
637
638exnspec : exnspec AND exnspec (fn $ => exnspec1 $ @ exnspec2 $)
639 | ident (make_exnspec(varSymbol ident))
640 | ident OF ty (make_exnspecOF (varSymbol ident,ty))
641
642sharespec: sharespec AND
643 sharespec (fn $ => sharespec1 $ @ sharespec2 $)
644 | TYPE patheqn (make_type_sharespec(patheqn tycSymbol))
645 | patheqn (make_str_sharespec(patheqn strSymbol))
646
647patheqn: qid EQUAL qid (fn kind => [qid1 kind, qid2 kind])
648 | qid EQUAL patheqn (fn kind => qid kind :: patheqn kind)
649
650sign : ID (makeSIGid(sigSymbol ID,error(IDleft,IDright)))
651 | SIG spec_s END (makeSIG(spec_s,error(spec_sleft,spec_sright)))
652
653sigconstraint_op : (fn _ => NONE)
654 | COLON sign (fn (env,param) =>
655 SOME(sign(true,false,param) (env,Stampset.newStampsets())))
656
657sigb : sigb AND sigb (sequence'(sigb1,sigb2))
658 | ident EQUAL sign (make_sigb(sigSymbol ident, sign(true,false,NULLstr)))
659
660str : 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))
665 | ID LPAREN sdecs
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)
669 ,s')
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))
674
675sdecs : sdec sdecs (sequence(fn $ => markdec'(sdec $,sdecleft,
676 sdecright),
677 sdecs))
678 | SEMICOLON sdecs (sdecs)
679 | LOCAL sdecs IN sdecs
680 END sdecs (sequence(fn $ => markdec''(makeLOCALsdecs(sdecs1,sdecs2) $,LOCALleft,ENDright),
681 sdecs3))
682 | (fn $ => (nil,Env.empty))
683
684sdecs' : sdec sdecs' (sequence(fn $ => markdec'(sdec $,sdecleft,sdecright),
685 sdecs'))
686 | LOCAL sdecs IN sdecs
687 END sdecs' (sequence(fn $ =>
688 markdec''(makeLOCALsdecs(sdecs1,sdecs2) $,
689 LOCALleft,ENDright),
690 sdecs'))
691
692 | LOCAL sdecs IN sdecs
693 END (fn $ => markdec''(makeLOCALsdecs(sdecs1,sdecs2) $,LOCALleft,ENDright))
694
695 | sdec (fn $ => seqdec(markdec(sdec $,sdecleft,sdecright)))
696
697sdec : 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));
705 (dec,env')
706 end)
707
708strb : 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 $)
712
713fparam : ID COLON sign (single_formal(strSymbol ID, sign(true,true,NULLstr)))
714 | spec_s (spread_formal(spec_s,
715 error(spec_sleft,spec_sright)))
716
717fctb : 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 $)
722
723importdec: STRING ([STRING])
724 | STRING importdec (STRING :: importdec)
725
726interdec: sdecs' (fn env=> let val (s,e)= sdecs'(env,[],true,Stampset.globalStamps)
727 in markdec((SEQdec s,e),sdecs'left,sdecs'right)
728 end)
729 | IMPORT importdec (fn env =>(IMPORTdec importdec,env))
730 | exp (fn env=>markdec(toplevelexp(env,exp,error,(expleft,expright)),
731 expleft,expright))
732
mlton packaging