Commit | Line | Data |
---|---|---|
7f918cf1 CE |
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) | |
11 | ||
12 | fun markdec' d = | |
13 | let val (d,e) = markdec d | |
14 | in ([d],e) | |
15 | end | |
16 | ||
17 | fun markdec'' (([d],e),a,b) = markdec'((d,e),a,b) | |
18 | | markdec'' ((s,e),a,b) = markdec'((SEQdec s, e),a,b) | |
19 | ||
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 | |
24 | ||
25 | infix \/ | |
26 | val op \/ = union_tyvars | |
27 | ||
28 | fun V(_,vars) = vars and E(e,_) = e | |
29 | ||
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)) | |
34 | end | |
35 | ||
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)) | |
40 | end | |
41 | ||
42 | fun 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 | ||
178 | int : INT (INT) | |
179 | | INT0 (INT0) | |
180 | ||
181 | id : ID (ID) | |
182 | | ASTERISK ("*") | |
183 | ||
184 | ident : ID (ID) | |
185 | | ASTERISK ("*") | |
186 | | EQUAL ("=") | |
187 | ||
188 | op_op : OP (fn()=> error (OPleft,OPright) WARN "unnecessary `op'") | |
189 | | (fn()=>()) | |
190 | ||
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"; | |
195 | v | |
196 | end) | |
197 | | OP ident (fn _ => varSymbol ident) | |
198 | ||
199 | qid : ID DOT qid (fn kind => strSymbol ID :: qid kind) | |
200 | | ident (fn kind => [kind ident]) | |
201 | ||
202 | selector: id (labSymbol id) | |
203 | | INT (Symbol.labSymbol(makestring INT)) | |
204 | ||
205 | tycon : ID DOT tycon (strSymbol ID :: tycon) | |
206 | | ID ([tycSymbol ID]) | |
207 | ||
208 | tlabel : selector COLON ty (fn $ =>(selector, E ty $), V ty) | |
209 | ||
210 | tlabels : tlabel COMMA tlabels (fn $ => E tlabel $ :: E tlabels $, | |
211 | V tlabel \/ V tlabels) | |
212 | | tlabel (fn $ => [E tlabel $], V tlabel) | |
213 | ||
214 | ty' : 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 | ||
241 | tuple_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 | ||
247 | ty : 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 | ||
252 | ty0_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 | ||
256 | match : 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 | ||
261 | rule : pat DARROW | |
262 | exp (makeRULE(E pat, fn $ => markexp(E exp $,expleft,expright), | |
263 | error(patleft,patright)), | |
264 | V pat \/ V exp) | |
265 | ||
266 | ||
267 | elabel : selector EQUAL | |
268 | exp (fn evst => (selector,E exp evst), V exp) | |
269 | ||
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) | |
274 | ||
275 | exp_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 | ||
279 | exp : 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 | ||
318 | app_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 | ||
345 | aexp : 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 | ||
375 | exp_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 | ||
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, | |
382 | V exp \/ V exp_list) | |
383 | ||
384 | pat : pat' (pat') | |
385 | | apat apats (fn $ => make_app_pat(E apat $ ::E apats $), | |
386 | V apat \/ V apats) | |
387 | ||
388 | pat' : pat AS pat (fn $ => layered(E pat1 $, E pat2 $, | |
389 | error(pat1left,pat1right)), | |
390 | V pat1 \/ V pat2) | |
391 | | pat'' (pat'') | |
392 | ||
393 | pat'' : 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 | ||
401 | apat : apat' (apat') | |
402 | | LPAREN pat RPAREN (fn $ =>(E pat $,NONfix,error(LPARENleft,RPARENright)), | |
403 | V pat) | |
404 | ||
405 | apat' : 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 | ||
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)), | |
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 | ||
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), | |
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 | ||
453 | plabels : 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 | ||
461 | pat_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 | ||
465 | vb : vb AND vb (fn st=> vb1 st @ vb2 st) | |
466 | | pat EQUAL exp (valbind(pat, exp)) | |
467 | ||
468 | constraint : (fn _ =>NONE, no_tyvars) | |
469 | | COLON ty (fn env =>SOME(E ty env), V ty) | |
470 | ||
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)) | |
475 | ||
476 | fb' : clause (fn $ =>[E clause $], V clause) | |
477 | | clause BAR fb' (fn $ =>E clause $ ::E fb' $, V clause \/ V fb') | |
478 | ||
479 | fb : 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 | ||
484 | clause' : 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 | ||
495 | apats : (fn _ =>nil, no_tyvars) | |
496 | | apat apats (fn $ => E apat $ ::E apats $, | |
497 | V apat \/ V apats) | |
498 | ||
499 | clause : 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 | ||
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)) | |
512 | ||
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) | |
517 | tyvar_pc); | |
518 | tyvar_pc) | |
519 | | (nil) | |
520 | ||
521 | tyvar_pc: TYVAR ([mkTyvar(mkUBOUND(tyvSymbol TYVAR))]) | |
522 | | TYVAR COMMA tyvar_pc (mkTyvar(mkUBOUND(tyvSymbol TYVAR)) :: tyvar_pc) | |
523 | ||
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)))] | |
529 | end) | |
530 | ||
531 | constrs : constr (fn $ => [E constr $], V constr) | |
532 | | constr BAR constrs (fn $ => E constr $ :: E constrs $, | |
533 | V constr \/ V constrs) | |
534 | ||
535 | constr : 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 | ||
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))), | |
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 | ||
551 | qid_p0 : qid ([qid strSymbol]) | |
552 | | qid qid_p0 (qid strSymbol :: qid_p0) | |
553 | ||
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) | |
556 | ||
557 | fixity : INFIX (infixleft 0) | |
558 | | INFIX int (infixleft int) | |
559 | | INFIXR (infixright 0) | |
560 | | INFIXR int (infixright int) | |
561 | | NONFIX (NONfix) | |
562 | ||
563 | ldec : 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 | ||
588 | exp_pa : exp (fn st => [E exp st]) | |
589 | | exp AND exp_pa (fn st => E exp st :: exp_pa st) | |
590 | ||
591 | ldecs : (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 | ||
603 | ops : ident ([fixSymbol ident]) | |
604 | | ident ops (fixSymbol ident :: ops) | |
605 | ||
606 | spec_s : (fn $ => nil) | |
607 | | spec spec_s (fn $ => spec $ @ spec_s $) | |
608 | | SEMICOLON spec_s (spec_s) | |
609 | ||
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))) | |
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 | ||
627 | strspec : strspec AND strspec (fn $ => strspec1 $ @ strspec2 $) | |
628 | | ident COLON sign (make_strspec(strSymbol ident, sign(false,false,NULLstr))) | |
629 | ||
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))) | |
634 | ||
635 | valspec : valspec AND valspec (fn $ => valspec1 $ @ valspec2 $) | |
636 | | op_op ident COLON ty (fire op_op (make_valspec(varSymbol ident,ty))) | |
637 | ||
638 | exnspec : exnspec AND exnspec (fn $ => exnspec1 $ @ exnspec2 $) | |
639 | | ident (make_exnspec(varSymbol ident)) | |
640 | | ident OF ty (make_exnspecOF (varSymbol ident,ty)) | |
641 | ||
642 | sharespec: sharespec AND | |
643 | sharespec (fn $ => sharespec1 $ @ sharespec2 $) | |
644 | | TYPE patheqn (make_type_sharespec(patheqn tycSymbol)) | |
645 | | patheqn (make_str_sharespec(patheqn strSymbol)) | |
646 | ||
647 | patheqn: qid EQUAL qid (fn kind => [qid1 kind, qid2 kind]) | |
648 | | qid EQUAL patheqn (fn kind => qid kind :: patheqn kind) | |
649 | ||
650 | sign : ID (makeSIGid(sigSymbol ID,error(IDleft,IDright))) | |
651 | | SIG spec_s END (makeSIG(spec_s,error(spec_sleft,spec_sright))) | |
652 | ||
653 | sigconstraint_op : (fn _ => NONE) | |
654 | | COLON sign (fn (env,param) => | |
655 | SOME(sign(true,false,param) (env,Stampset.newStampsets()))) | |
656 | ||
657 | sigb : sigb AND sigb (sequence'(sigb1,sigb2)) | |
658 | | ident EQUAL sign (make_sigb(sigSymbol ident, sign(true,false,NULLstr))) | |
659 | ||
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)) | |
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 | ||
675 | sdecs : 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 | ||
684 | sdecs' : 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 | ||
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)); | |
705 | (dec,env') | |
706 | end) | |
707 | ||
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 $) | |
712 | ||
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))) | |
716 | ||
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 $) | |
722 | ||
723 | importdec: STRING ([STRING]) | |
724 | | STRING importdec (STRING :: importdec) | |
725 | ||
726 | interdec: 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 |