Commit | Line | Data |
---|---|---|
7f918cf1 CE |
1 | (* Heavily modified from SML/NJ sources by sweeks@sweeks.com *) |
2 | ||
3 | (* ml.grm | |
4 | * | |
5 | * Copyright 1989,1992 by AT&T Bell Laboratories | |
6 | *) | |
7 | ||
8 | fun reg (left, right) = Region.make {left = left, right = right} | |
9 | fun error (reg, msg) = Control.error (reg, Layout.str msg, Layout.empty) | |
10 | ||
11 | local | |
12 | open Control.Elaborate | |
13 | in | |
14 | val allowOptBar = fn () => current allowOptBar | |
15 | val allowOptSemicolon = fn () => current allowOptSemicolon | |
16 | val allowRecordPunExps = fn () => current allowRecordPunExps | |
17 | end | |
18 | ||
19 | open Ast | |
20 | structure Field = Record.Field | |
21 | structure Srecord = SortedRecord | |
22 | ||
23 | structure Type = | |
24 | struct | |
25 | open Type | |
26 | ||
27 | fun tuple ts = | |
28 | Record (Record.tuple (Vector.map (ts, fn t => (Region.bogus, t)))) | |
29 | ||
30 | val unit = tuple (Vector.new0 ()) | |
31 | ||
32 | fun arrow (t1, t2) = Con (Longtycon.arrow, Vector.new2 (t1, t2)) | |
33 | end | |
34 | ||
35 | structure DatBind = | |
36 | struct | |
37 | open DatBind | |
38 | ||
39 | fun make (dbs, withtypes, left, right) = | |
40 | makeRegion' (T {datatypes = dbs, withtypes = withtypes}, | |
41 | left, right) | |
42 | end | |
43 | ||
44 | structure Pat = | |
45 | struct | |
46 | open Pat | |
47 | ||
48 | fun tuple ps = | |
49 | if 1 = Vector.length ps | |
50 | then Paren (Vector.sub (ps, 0)) | |
51 | else Tuple ps | |
52 | ||
53 | val unit = tuple (Vector.new0 ()) | |
54 | ||
55 | val bogus = unit | |
56 | ||
57 | fun makeAs (p1: t, p2: t): node = | |
58 | let | |
59 | fun err () = | |
60 | error (Pat.region p1, "must have variable to left in as pattern") | |
61 | fun fixopVar (p : t) = | |
62 | case node p of | |
63 | FlatApp ps => | |
64 | if 1 = Vector.length ps | |
65 | then (case node (Vector.sub (ps, 0)) of | |
66 | Var {fixop,name} => | |
67 | (case Longvid.split name of | |
68 | ([], vid) => | |
69 | SOME (fixop, Vid.toVar vid) | |
70 | | _ => | |
71 | let | |
72 | val () = err () | |
73 | in | |
74 | SOME (Fixop.None, Var.bogus) | |
75 | end) | |
76 | | _ => NONE) | |
77 | else NONE | |
78 | | _ => NONE | |
79 | in | |
80 | case fixopVar p1 of | |
81 | SOME (fixop, var) => | |
82 | Layered {fixop = fixop, var = var, | |
83 | constraint = NONE, | |
84 | pat = p2} | |
85 | | NONE => | |
86 | case node p1 of | |
87 | Pat.Constraint (p, t) => | |
88 | (case fixopVar p of | |
89 | SOME (fixop, var) => | |
90 | Layered {fixop = fixop, var = var, | |
91 | constraint = SOME t, | |
92 | pat = p2} | |
93 | | _ => (err (); bogus)) | |
94 | | _ => (err (); bogus) | |
95 | end | |
96 | end | |
97 | ||
98 | structure Exp = | |
99 | struct | |
100 | open Exp | |
101 | ||
102 | fun tuple es = | |
103 | if 1 = Vector.length es | |
104 | then Paren (Vector.sub (es, 0)) | |
105 | else Record (Record.tuple (Vector.map (es, fn e => (Region.bogus, e)))) | |
106 | ||
107 | val unit = tuple (Vector.new0 ()) | |
108 | end | |
109 | ||
110 | structure Dec = | |
111 | struct | |
112 | open Dec | |
113 | ||
114 | fun sequence (d1: t, d2: t): t = | |
115 | makeRegion (case (node d1, node d2) of | |
116 | (SeqDec d1, SeqDec d2) => SeqDec (Vector.concat [d1, d2]) | |
117 | | (SeqDec d1, _) => | |
118 | SeqDec (Vector.concat [d1, Vector.new1 d2]) | |
119 | | (_, SeqDec d2) => | |
120 | SeqDec (Vector.concat [Vector.new1 d1, d2]) | |
121 | | _ => SeqDec (Vector.new2 (d1, d2)), | |
122 | Region.append (region d1, region d2)) | |
123 | end | |
124 | ||
125 | structure Spec = | |
126 | struct | |
127 | open Spec | |
128 | ||
129 | (* Some of this mess is so that a sharing equation captures as | |
130 | * many specs as possible in its scope. | |
131 | *) | |
132 | fun seq (s: t, s': t): t = | |
133 | let | |
134 | fun reg s'' = makeRegion (s'', Region.append (region s, region s')) | |
135 | in | |
136 | case (node s, node s') of | |
137 | (Empty, _) => s' | |
138 | | (_, Empty) => s | |
139 | | (_, Seq (s1, s2)) => reg (Seq (seq (s, s1), s2)) | |
140 | | (_, Sharing {spec, equation}) => | |
141 | reg (Sharing {spec = seq (s, spec), equation = equation}) | |
142 | | _ => reg (Seq (s, s')) | |
143 | end | |
144 | end | |
145 | ||
146 | fun consTopdec (d, dss) = | |
147 | case dss of | |
148 | [] => [[d]] | |
149 | | ds :: dss => (d :: ds) :: dss | |
150 | ||
151 | type rule = Pat.t * Exp.t | |
152 | type clause = {pats : Pat.t vector, | |
153 | resultType : Type.t option, | |
154 | body : Exp.t} | |
155 | type clauses = clause vector | |
156 | type eb = Con.t * EbRhs.t | |
157 | type db = {tyvars: Tyvar.t vector, | |
158 | tycon: Tycon.t, | |
159 | cons: (Con.t * Type.t option) vector} | |
160 | type tb = {def: Type.t, | |
161 | tycon: Tycon.t, | |
162 | tyvars: Tyvar.t vector} | |
163 | ||
164 | type strdesc = Strid.t * Sigexp.t | |
165 | ||
166 | type typdesc = {tyvars: Tyvar.t vector, | |
167 | tycon: Tycon.t} | |
168 | ||
169 | type valdesc = Var.t * Type.t | |
170 | ||
171 | type exndesc = Con.t * Type.t option | |
172 | ||
173 | type strbind = {name: Strid.t, | |
174 | def: Strexp.t, | |
175 | constraint: SigConst.t} | |
176 | ||
177 | type sigbind = Sigid.t * Sigexp.t | |
178 | ||
179 | type funbind = {name : Fctid.t, | |
180 | arg : FctArg.t, | |
181 | result : SigConst.t, | |
182 | body : Strexp.t} | |
183 | ||
184 | type vb = {pat: Pat.t, | |
185 | exp: Exp.t} | |
186 | ||
187 | type rvb = {pat: Pat.t, | |
188 | match: Match.t} | |
189 | ||
190 | fun longIdFromTok (s, left, right) = | |
191 | let | |
192 | val syms = List.map (String.split (s, #"."), Symbol.fromString) | |
193 | in | |
194 | (syms, reg (left, right)) | |
195 | end | |
196 | ||
197 | fun shortIdFromTok (s, left, right) = | |
198 | (Symbol.fromString s, reg (left, right)) | |
199 | ||
200 | fun longIdFromShortId (sym, reg) = ([sym], reg) | |
201 | ||
202 | fun cons1 (x, (l, y)) = (x :: l, y) | |
203 | ||
204 | fun augment (id, sigexp, (whereeqns, binds)) = | |
205 | (id, Sigexp.wheree (sigexp, Vector.fromList whereeqns)) | |
206 | :: binds | |
207 | ||
208 | fun 'a augment1 ((strexp: Strexp.t, | |
209 | sigconst: Sigexp.t -> SigConst.t, | |
210 | sigexp: Sigexp.t), | |
211 | (whereeqns: WhereEquation.t list, | |
212 | z: 'a)): Strexp.t * 'a = | |
213 | let | |
214 | val sigexp = Sigexp.wheree (sigexp, Vector.fromList whereeqns) | |
215 | in | |
216 | (Strexp.makeRegion | |
217 | (Strexp.Constrained (strexp, sigconst sigexp), | |
218 | Region.append (Strexp.region strexp, Sigexp.region sigexp)), | |
219 | z) | |
220 | end | |
221 | ||
222 | type 'a whereAndEqns = WhereEquation.t list * 'a list | |
223 | ||
224 | %% | |
225 | %term | |
226 | CHAR of IntInf.t | |
227 | | INT of {digits: string, | |
228 | extended: bool, | |
229 | negate: bool, | |
230 | radix: StringCvt.radix} | |
231 | | SHORTALPHANUMID of string | |
232 | | SHORTSYMID of string | |
233 | | LONGALPHANUMID of string | |
234 | | LONGSYMID of string | |
235 | | REAL of string | |
236 | | STRING of IntInf.t vector | |
237 | | TYVAR of string | |
238 | | WORD of {digits: string, | |
239 | radix: StringCvt.radix} | |
240 | | ABSTYPE | AND | ANDALSO | ARROW | AS | ASTERISK | BAR | CASE | COLON | |
241 | | COLONGT | COMMA | DATATYPE | DOTDOTDOT | ELSE | END | EOF | EQUALOP | |
242 | | EQTYPE | EXCEPTION | DO | DARROW | FN | FUN | FUNCTOR | HANDLE | HASH | |
243 | | HASHLBRACKET | IF | IN | INCLUDE | INFIX | INFIXR | LBRACE | LBRACKET | LET | |
244 | | LOCAL | LPAREN | NONFIX | ORELSE | OF | OP | OPEN | OVERLOAD | RAISE | |
245 | | RBRACE | RBRACKET | REC | RPAREN | SEMICOLON | SHARING | SIG | SIGNATURE | |
246 | | STRUCT | STRUCTURE | THEN | TYPE | VAL | WHERE | WHILE | WILD | WITH | |
247 | | WITHTYPE | |
248 | (* Extensions *) | |
249 | | BUILD_CONST | COMMAND_LINE_CONST | CONST | |
250 | | ADDRESS | EXPORT | IMPORT | SYMBOL | |
251 | | PRIM | |
252 | | SHOW_BASIS of File.t | |
253 | ||
254 | %nonterm | |
255 | aexp of Exp.node | |
256 | | apat of Pat.t | |
257 | | apatnode of Pat.node | |
258 | | apats of Pat.t list | |
259 | | app_exp of Exp.t list | |
260 | | arg_fct of Strexp.t | |
261 | | ieattributes of PrimKind.ImportExportAttribute.t list | |
262 | | barcpats of Pat.t list | |
263 | | clause of clause | |
264 | | clauses of clause list | |
265 | | clausesTop of clauses | |
266 | | commapats of Pat.t list | |
267 | | con of Con.t | |
268 | | const of Const.t | |
269 | | const' of Const.node | |
270 | | constr of Con.t * Type.t option | |
271 | | constraint of Type.t option | |
272 | | constrs of (Con.t * Type.t option) list | |
273 | | constOrBool of Const.t | |
274 | | cpat of Pat.t | |
275 | | cpatnode of Pat.node | |
276 | | datBind of DatBind.t | |
277 | | datatypeRhs of DatatypeRhs.t | |
278 | | datatypeRhsnode of DatatypeRhs.node | |
279 | | db of db | |
280 | | dbs of db vector | |
281 | | dbs' of db list | |
282 | | dec of Dec.t | |
283 | | decnode of Dec.node | |
284 | | decnolocal of Dec.node | |
285 | | decs of Dec.t | |
286 | | decsnode of Dec.node | |
287 | | digit of int | |
288 | | eb of eb | |
289 | | ebrhs of EbRhs.t | |
290 | | ebrhsnode of EbRhs.node | |
291 | | ebs of eb list | |
292 | | elabel of (Field.t * (Region.t * Exp.t)) | |
293 | | elabels of (Field.t * (Region.t * Exp.t)) list | |
294 | | exndesc of exndesc | |
295 | | exndescs of exndesc list | |
296 | | exp of Exp.t | |
297 | | exp_2c of Exp.t list | |
298 | | exp_list of Exp.t list | |
299 | | exp_ps of Exp.t list | |
300 | | expnode of Exp.node | |
301 | | expsAndTopdecs of Topdec.t list list | |
302 | | fctarg of FctArg.node | |
303 | | fctid of Fctid.t | |
304 | | field of Field.t | |
305 | | fixity of Fixity.t | |
306 | | funbinds of funbind list | |
307 | | funbinds' of Strexp.t * funbind list | |
308 | | funbinds'1 of funbind whereAndEqns | |
309 | | funbinds'1' of funbind whereAndEqns | |
310 | | funbinds'2 of funbind list | |
311 | | funs of clauses list | |
312 | | idField of Symbol.t * Region.t | |
313 | | int of IntInf.t | |
314 | | longcon of Longcon.t | |
315 | | longAlphanumId of Symbol.t list * Region.t | |
316 | | longSymId of Symbol.t list * Region.t | |
317 | | longstrid of Longstrid.t | |
318 | | longstrideqns of Longstrid.t list | |
319 | | longstrids of Longstrid.t list | |
320 | | longtycon of Longtycon.t | |
321 | | longtyconeqns of Longtycon.t list | |
322 | | longvid of Longvid.t | |
323 | | longvidEqual of Longvid.t | |
324 | | longvidNoEqual of Longvid.t | |
325 | | longvidands of Longvid.t list | |
326 | | match of Match.t | |
327 | | numericField of int | |
328 | | opaspat of Pat.t option | |
329 | | opcon of Con.t | |
330 | | optbar of unit | |
331 | | optbar' of unit | |
332 | | optsemicolon of unit | |
333 | | pat of Pat.t | |
334 | | patitem of (Field.t * Region.t * Pat.Item.t) | |
335 | | patitems of ((Field.t * Region.t * Pat.Item.t) list * bool) | |
336 | | pats of Pat.t list | |
337 | | priority of Priority.t | |
338 | | program of Program.t | |
339 | | repl of DatatypeRhs.node | |
340 | | rule of rule | |
341 | | rules of rule list | |
342 | | rvalbind of rvb list | |
343 | | sdec of Dec.t | |
344 | | sdecs of Dec.t | |
345 | | sdecsPlus of Dec.t | |
346 | | sharespec of SharingEquation.node | |
347 | | shortAlphanumId of Symbol.t * Region.t | |
348 | | shortSymId of Symbol.t * Region.t | |
349 | | sigbinds of sigbind list | |
350 | | sigbinds' of sigbind whereAndEqns | |
351 | | sigbinds'' of sigbind whereAndEqns | |
352 | | sigconst of SigConst.t | |
353 | | sigexp of Sigexp.t | |
354 | | sigexp' of Sigexp.t | |
355 | | sigexp'node of Sigexp.node | |
356 | | sigexpnode of Sigexp.node | |
357 | | sigid of Sigid.t | |
358 | | sigids of Sigid.t list | |
359 | | spec of Spec.t | |
360 | | specnode of Spec.node | |
361 | | specs of Spec.t | |
362 | | strbinds of strbind list | |
363 | | strbinds' of Strexp.t * strbind list | |
364 | | strbinds'1 of strbind whereAndEqns | |
365 | | strbinds'1' of strbind whereAndEqns | |
366 | | strbinds'2 of strbind list | |
367 | | strdec of Strdec.t | |
368 | | strdecnode of Strdec.node | |
369 | | strdecs of Strdec.t | |
370 | | strdecsnode of Strdec.node | |
371 | | strdescs of strdesc list | |
372 | | strdescs' of strdesc whereAndEqns | |
373 | | strdescs'' of strdesc whereAndEqns | |
374 | | strexp of Strexp.t | |
375 | | strexp1 of Strexp.t * (Sigexp.t -> SigConst.t) * Sigexp.t | |
376 | | strexp2 of Strexp.t | |
377 | | strexp2node of Strexp.node | |
378 | | strexpnode of Strexp.node | |
379 | | strid of Strid.t | |
380 | | string of string | |
381 | | symattributes of PrimKind.SymbolAttribute.t list | |
382 | | tb of tb | |
383 | | tbs of tb vector | |
384 | | tbs' of tb list | |
385 | | tlabel of (Field.t * (Region.t * Type.t)) | |
386 | | tlabels of (Field.t * (Region.t * Type.t)) list | |
387 | | topdec of Topdec.t | |
388 | | topdecnode of Topdec.node | |
389 | | topdecs of Topdec.t list list | |
390 | | tuple_ty of Type.t list | |
391 | | ty of Type.t | |
392 | | ty' of Type.t | |
393 | | ty'node of Type.node | |
394 | | ty0_pc of Type.t list | |
395 | | tyOpt of Type.t option | |
396 | | tycon of Tycon.t | |
397 | | tynode of Type.node | |
398 | | typBind of TypBind.t | |
399 | | typdesc of typdesc | |
400 | | typdescs of typdesc list | |
401 | | tyvar of Tyvar.t | |
402 | | tyvar_pc of Tyvar.t list | |
403 | | tyvars of Tyvar.t vector | |
404 | | tyvarseq of Tyvar.t vector | |
405 | | valbind of vb list * rvb list | |
406 | | valbindTop of vb vector * rvb vector | |
407 | | valdesc of valdesc | |
408 | | valdescs of valdesc list | |
409 | | vid of Vid.t | |
410 | | vidEqual of Vid.t | |
411 | | vidNoEqual of Vid.t | |
412 | | vids of Vid.t list | |
413 | | whereandeqns of WhereEquation.t list | |
414 | | whereeqn of (SourcePos.t -> WhereEquation.t) | |
415 | | whereeqns of WhereEquation.t vector | |
416 | | whereeqns' of WhereEquation.t list | |
417 | | withtypes of TypBind.t | |
418 | | word of IntInf.t | |
419 | ||
420 | %verbose | |
421 | %pos SourcePos.t | |
422 | %eop EOF | |
423 | %noshift EOF | |
424 | ||
425 | %header (functor MLLrValsFun (structure Token: TOKEN | |
426 | structure Ast: AST)) | |
427 | ||
428 | %nonassoc WITHTYPE | |
429 | %right AND | |
430 | %right ARROW | |
431 | %right DARROW | |
432 | %left DO | |
433 | %left ELSE | |
434 | %left RAISE | |
435 | %right HANDLE | |
436 | %left ORELSE | |
437 | %left ANDALSO | |
438 | %right AS | |
439 | %left COLON | |
440 | ||
441 | %name ML | |
442 | ||
443 | %keyword ABSTYPE AND AS CASE DATATYPE DOTDOTDOT ELSE END | |
444 | EQTYPE EXCEPTION DO DARROW FN FUN FUNCTOR HANDLE | |
445 | IF IN INCLUDE INFIX INFIXR LET LOCAL NONFIX OF OP | |
446 | OPEN OVERLOAD RAISE REC SHARING SIG SIGNATURE STRUCT | |
447 | STRUCTURE THEN TYPE VAL WHILE WHERE WITH WITHTYPE | |
448 | ORELSE ANDALSO | |
449 | ||
450 | %change -> VAL | -> THEN | -> ELSE | -> LPAREN | -> SEMICOLON | | |
451 | DARROW -> EQUALOP | EQUALOP -> DARROW | AND -> ANDALSO | COLON -> OF | | |
452 | SEMICOLON -> COMMA | COMMA -> SEMICOLON | | |
453 | -> IN SHORTALPHANUMID END | -> ELSE SHORTALPHANUMID | |
454 | ||
455 | %value CHAR (IntInf.fromInt (Char.ord #"a")) | |
456 | %value INT ({digits = "0", extended = false, negate = false, radix = StringCvt.DEC}) | |
457 | %value SHORTALPHANUMID ("bogus") | |
458 | %value REAL ("13.0") | |
459 | %value STRING (Vector.fromList []) | |
460 | %value TYVAR ("'a") | |
461 | %value WORD ({digits = "0", radix = StringCvt.DEC}) | |
462 | ||
463 | %% | |
464 | ||
465 | program: expsAndTopdecs (Program.T expsAndTopdecs) | |
466 | ||
467 | expsAndTopdecs: | |
468 | exp SEMICOLON expsAndTopdecs ([Topdec.fromExp exp] :: expsAndTopdecs) | |
469 | | topdecs (topdecs) | |
470 | ||
471 | topdecs: | |
472 | ([]) | |
473 | | topdec topdecs (consTopdec (topdec, topdecs)) | |
474 | | SEMICOLON expsAndTopdecs ([] :: expsAndTopdecs) | |
475 | ||
476 | topdec : topdecnode (Topdec.makeRegion' (topdecnode, | |
477 | topdecnodeleft, | |
478 | topdecnoderight)) | |
479 | ||
480 | topdecnode | |
481 | : strdec | |
482 | (Topdec.Strdec strdec) | |
483 | | SIGNATURE sigbinds | |
484 | (let | |
485 | val sigbinds = Vector.fromList sigbinds | |
486 | val d = Topdec.Signature sigbinds | |
487 | in | |
488 | d | |
489 | end) | |
490 | | FUNCTOR funbinds | |
491 | (Topdec.Functor (Vector.fromList funbinds)) | |
492 | ||
493 | (*---------------------------------------------------*) | |
494 | (* Structures *) | |
495 | (*---------------------------------------------------*) | |
496 | ||
497 | strdecs : strdecsnode (Strdec.makeRegion' | |
498 | (strdecsnode, strdecsnodeleft, strdecsnoderight)) | |
499 | ||
500 | strdecsnode : (Strdec.Seq []) | |
501 | | SEMICOLON strdecs (Strdec.Seq [strdecs]) | |
502 | | strdec strdecs (Strdec.Seq [strdec, strdecs]) | |
503 | ||
504 | strdec : strdecnode (Strdec.makeRegion' (strdecnode, | |
505 | strdecnodeleft, strdecnoderight)) | |
506 | ||
507 | strdecnode | |
508 | : STRUCTURE strbinds | |
509 | (let | |
510 | val strbinds = Vector.fromList strbinds | |
511 | val d = Strdec.Structure strbinds | |
512 | in | |
513 | d | |
514 | end) | |
515 | | LOCAL strdecs IN strdecs END (Strdec.Local (strdecs1, strdecs2)) | |
516 | | decnolocal | |
517 | (Strdec.Core (Dec.makeRegion' (decnolocal, | |
518 | decnolocalleft, decnolocalright))) | |
519 | | SHOW_BASIS (Strdec.ShowBasis SHOW_BASIS) | |
520 | ||
521 | ||
522 | strbinds : strid sigconst EQUALOP strbinds' | |
523 | (let val (def,strbinds) = strbinds' | |
524 | in {name = strid, def = def, constraint = sigconst} | |
525 | :: strbinds | |
526 | end) | |
527 | ||
528 | strbinds' : strexp1 strbinds'1 (augment1 (strexp1, strbinds'1)) | |
529 | | strexp2 strbinds'2 ((strexp2,strbinds'2)) | |
530 | ||
531 | strbinds'1 : strbinds'2 (([], strbinds'2)) | |
532 | | WHERE whereeqn strbinds'1' (cons1 (whereeqn WHEREleft, strbinds'1')) | |
533 | ||
534 | strbinds'1' : strbinds'1 (strbinds'1) | |
535 | | AND whereeqn strbinds'1' (cons1 (whereeqn ANDleft, strbinds'1')) | |
536 | ||
537 | strbinds'2 : ([]) | |
538 | | AND strbinds (strbinds) | |
539 | ||
540 | strexp : strexpnode (Strexp.makeRegion' (strexpnode, | |
541 | strexpnodeleft, strexpnoderight)) | |
542 | ||
543 | strexpnode | |
544 | : strexp1 | |
545 | (let | |
546 | val (strexp, sigconst, sigexp) = strexp1 | |
547 | in | |
548 | Strexp.Constrained (strexp, sigconst sigexp) | |
549 | end) | |
550 | | strexp1 whereeqns | |
551 | (let | |
552 | val (strexp,sigconst,sigexp) = strexp1 | |
553 | val sigexp = Sigexp.wheree (sigexp, whereeqns) | |
554 | in | |
555 | Strexp.Constrained | |
556 | (strexp, sigconst sigexp) | |
557 | end) | |
558 | | strexp2node | |
559 | (strexp2node) | |
560 | ||
561 | strexp1 : strexp COLON sigexp' ((strexp,SigConst.Transparent,sigexp')) | |
562 | | strexp COLONGT sigexp' ((strexp,SigConst.Opaque,sigexp')) | |
563 | ||
564 | strexp2 : strexp2node (Strexp.makeRegion' | |
565 | (strexp2node, strexp2nodeleft, strexp2noderight)) | |
566 | ||
567 | strexp2node | |
568 | : longstrid (Strexp.Var longstrid) | |
569 | | STRUCT strdecs END (Strexp.Struct strdecs) | |
570 | | fctid arg_fct (Strexp.App (fctid, arg_fct)) | |
571 | | LET strdecs IN strexp END (Strexp.Let (strdecs, strexp)) | |
572 | ||
573 | arg_fct : LPAREN strexp RPAREN (Strexp.makeRegion' | |
574 | (Strexp.node strexp, | |
575 | LPARENleft, RPARENright)) | |
576 | | LPAREN strdecs RPAREN (Strexp.makeRegion' | |
577 | (Strexp.Struct strdecs, | |
578 | LPARENleft, RPARENright)) | |
579 | ||
580 | (*---------------------------------------------------*) | |
581 | (* Signatures *) | |
582 | (*---------------------------------------------------*) | |
583 | ||
584 | sigexp | |
585 | : sigexp' (sigexp') | |
586 | | sigexp' whereeqns (Sigexp.wheree (sigexp', whereeqns)) | |
587 | ||
588 | whereeqns : whereeqns' (Vector.fromList whereeqns') | |
589 | ||
590 | whereeqns' | |
591 | : WHERE whereeqn ([whereeqn WHEREleft]) | |
592 | | WHERE whereeqn whereeqns' (whereeqn WHEREleft :: whereeqns') | |
593 | | WHERE whereeqn whereandeqns (whereeqn WHEREleft :: whereandeqns) | |
594 | ||
595 | whereandeqns | |
596 | : AND whereeqn ([whereeqn ANDleft]) | |
597 | | AND whereeqn whereandeqns (whereeqn ANDleft :: whereandeqns) | |
598 | | AND whereeqn whereeqns' (whereeqn ANDleft :: whereeqns') | |
599 | ||
600 | sigbinds: sigid EQUALOP sigexp' sigbinds' (augment (sigid, sigexp', sigbinds')) | |
601 | ||
602 | sigexp' : sigexp'node (Sigexp.makeRegion' (sigexp'node, | |
603 | sigexp'nodeleft, | |
604 | sigexp'noderight)) | |
605 | ||
606 | sigexp'node : sigid (Sigexp.Var sigid) | |
607 | | SIG specs END (Sigexp.Spec specs) | |
608 | ||
609 | sigbinds': (([], [])) | |
610 | | AND sigbinds (([], sigbinds)) | |
611 | | WHERE whereeqn sigbinds'' (cons1 (whereeqn WHEREleft, sigbinds'')) | |
612 | ||
613 | sigbinds'' : sigbinds' (sigbinds') | |
614 | | AND whereeqn sigbinds'' (cons1 (whereeqn ANDleft, sigbinds'')) | |
615 | ||
616 | whereeqn : TYPE tyvars longtycon EQUALOP ty (fn eqnleft => | |
617 | WhereEquation.makeRegion' | |
618 | (WhereEquation.Type {tyvars = tyvars, | |
619 | longtycon = longtycon, | |
620 | ty = ty}, | |
621 | eqnleft, | |
622 | tyright)) | |
623 | ||
624 | sigconst : (SigConst.None) | |
625 | | COLON sigexp (SigConst.Transparent sigexp) | |
626 | | COLONGT sigexp (SigConst.Opaque sigexp) | |
627 | ||
628 | specs : (Spec.makeRegion (Spec.Empty, Region.bogus)) | |
629 | | SEMICOLON specs (specs) | |
630 | | spec specs (Spec.seq (spec, specs)) | |
631 | ||
632 | spec : specnode (Spec.makeRegion' (specnode, specnodeleft, specnoderight)) | |
633 | ||
634 | specnode : VAL valdescs (Spec.Val (Vector.fromList valdescs)) | |
635 | | TYPE typdescs (Spec.Type (Vector.fromList typdescs)) | |
636 | | TYPE typBind (Spec.TypeDefs typBind) | |
637 | | EQTYPE typdescs (Spec.Eqtype (Vector.fromList typdescs)) | |
638 | | DATATYPE datatypeRhs (Spec.Datatype datatypeRhs) | |
639 | | EXCEPTION exndescs (Spec.Exception (Vector.fromList exndescs)) | |
640 | | STRUCTURE strdescs (Spec.Structure (Vector.fromList strdescs)) | |
641 | | INCLUDE sigexp (Spec.IncludeSigexp sigexp) | |
642 | | INCLUDE sigid sigids (* p. 59 *) | |
643 | (Spec.IncludeSigids (Vector.fromList (sigid :: sigids)) ) | |
644 | | sharespec | |
645 | (Spec.Sharing {spec = Spec.makeRegion' (Spec.Empty, | |
646 | sharespecleft, | |
647 | sharespecright), | |
648 | equation = (SharingEquation.makeRegion' | |
649 | (sharespec, | |
650 | sharespecleft, | |
651 | sharespecright))}) | |
652 | ||
653 | sharespec : SHARING TYPE longtyconeqns (SharingEquation.Type longtyconeqns) | |
654 | | SHARING longstrideqns (SharingEquation.Structure longstrideqns) | |
655 | ||
656 | longstrideqns : longstrid EQUALOP longstrid ([longstrid1,longstrid2]) | |
657 | | longstrid EQUALOP longstrideqns (longstrid :: longstrideqns) | |
658 | ||
659 | longtyconeqns : longtycon EQUALOP longtycon ([longtycon1,longtycon2]) | |
660 | | longtycon EQUALOP longtyconeqns (longtycon :: longtyconeqns) | |
661 | ||
662 | strdescs : strid COLON sigexp' strdescs' (augment (strid, sigexp', strdescs')) | |
663 | ||
664 | strdescs' : (([], [])) | |
665 | | AND strdescs (([], strdescs)) | |
666 | | WHERE whereeqn strdescs'' (cons1 (whereeqn WHEREleft, strdescs'')) | |
667 | ||
668 | strdescs'' : strdescs' (strdescs') | |
669 | | AND whereeqn strdescs'' (cons1 (whereeqn ANDleft, strdescs'')) | |
670 | ||
671 | typdescs : typdesc ([typdesc]) | |
672 | | typdesc AND typdescs (typdesc :: typdescs) | |
673 | ||
674 | typdesc : tyvars tycon ({tyvars = tyvars, | |
675 | tycon = tycon}) | |
676 | ||
677 | valdescs : valdesc ([valdesc]) | |
678 | | valdesc AND valdescs (valdesc :: valdescs) | |
679 | ||
680 | valdesc : vid COLON ty (Vid.toVar vid, ty) | |
681 | ||
682 | exndescs : exndesc ([exndesc]) | |
683 | | exndesc AND exndescs (exndesc :: exndescs) | |
684 | ||
685 | exndesc : con tyOpt (con, tyOpt) | |
686 | ||
687 | tyOpt : (NONE) | |
688 | | OF ty (SOME ty) | |
689 | ||
690 | (*---------------------------------------------------*) | |
691 | (* Functors *) | |
692 | (*---------------------------------------------------*) | |
693 | ||
694 | funbinds : fctid LPAREN fctarg RPAREN sigconst EQUALOP funbinds' | |
695 | (let val (strexp,funbinds) = funbinds' | |
696 | in {name = fctid, | |
697 | arg = FctArg.makeRegion' (fctarg, fctargleft, fctargright), | |
698 | result = sigconst, | |
699 | body = strexp} | |
700 | :: funbinds | |
701 | end) | |
702 | ||
703 | funbinds' : strexp1 funbinds'1 (augment1 (strexp1, funbinds'1)) | |
704 | | strexp2 funbinds'2 ((strexp2, funbinds'2)) | |
705 | ||
706 | funbinds'1 : funbinds'2 ([], funbinds'2) | |
707 | | WHERE whereeqn funbinds'1' (cons1 (whereeqn WHEREleft, funbinds'1')) | |
708 | ||
709 | funbinds'2 : ([]) | |
710 | | AND funbinds (funbinds) | |
711 | ||
712 | funbinds'1' : funbinds'1 (funbinds'1) | |
713 | | AND whereeqn funbinds'1' (cons1 (whereeqn ANDleft, funbinds'1')) | |
714 | ||
715 | fctarg : strid COLON sigexp (FctArg.Structure (strid, sigexp)) | |
716 | | specs (FctArg.Spec specs) | |
717 | ||
718 | (*---------------------------------------------------*) | |
719 | (* Declarations *) | |
720 | (*---------------------------------------------------*) | |
721 | ||
722 | decs : (Dec.makeRegion' (Dec.SeqDec (Vector.new0 ()), | |
723 | defaultPos, defaultPos)) | |
724 | | dec decs (Dec.sequence (dec,decs)) | |
725 | | SEMICOLON decs (decs) | |
726 | ||
727 | dec : decnode (Dec.makeRegion' (decnode, decnodeleft, decnoderight)) | |
728 | ||
729 | decnode : decnolocal (decnolocal) | |
730 | | LOCAL decs IN decs END (Dec.Local (decs1,decs2)) | |
731 | ||
732 | decnolocal | |
733 | : VAL valbindTop (Dec.Val {tyvars = Vector.new0 (), | |
734 | vbs = #1 valbindTop, | |
735 | rvbs = #2 valbindTop}) | |
736 | | VAL tyvarseq valbindTop (Dec.Val {tyvars = tyvarseq, | |
737 | vbs = #1 valbindTop, | |
738 | rvbs = #2 valbindTop}) | |
739 | | DO exp (Dec.DoDec exp) | |
740 | | FUN funs (Dec.Fun {tyvars = Vector.new0 (), fbs = Vector.fromList funs}) | |
741 | | FUN tyvarseq funs (Dec.Fun {tyvars = tyvarseq, fbs = Vector.fromList funs}) | |
742 | | TYPE typBind (Dec.Type typBind) | |
743 | | DATATYPE datatypeRhs (Dec.Datatype datatypeRhs) | |
744 | | ABSTYPE datBind WITH decs END (Dec.Abstype {datBind = datBind, | |
745 | body = decs}) | |
746 | | EXCEPTION ebs (Dec.Exception (Vector.fromList ebs)) | |
747 | | OPEN longstrids (Dec.Open (Vector.fromList longstrids)) | |
748 | | fixity vids (Dec.Fix {fixity = fixity, | |
749 | ops = Vector.fromList vids}) | |
750 | | OVERLOAD priority vid COLON ty AS longvidands | |
751 | (Dec.Overload (priority, | |
752 | Vid.toVar vid, | |
753 | Vector.new0 (), | |
754 | ty, | |
755 | Vector.fromList longvidands)) | |
756 | ||
757 | valbindTop : valbind (let | |
758 | val (vbs, rvbs) = valbind | |
759 | in | |
760 | (Vector.fromList vbs, | |
761 | Vector.fromList rvbs) | |
762 | end) | |
763 | ||
764 | valbind : pat EQUALOP exp | |
765 | (([{pat = pat, exp = exp}], [])) | |
766 | | pat EQUALOP exp AND valbind | |
767 | (let | |
768 | val (vbs, rvbs) = valbind | |
769 | in | |
770 | ({pat = pat, exp = exp} :: vbs, | |
771 | rvbs) | |
772 | end) | |
773 | | REC rvalbind (([], rvalbind)) | |
774 | ||
775 | rvalbind : REC rvalbind (rvalbind) | |
776 | | pat EQUALOP FN match | |
777 | ([{pat = pat, match = match}]) | |
778 | | pat EQUALOP FN match AND rvalbind | |
779 | ({pat = pat, match = match} :: rvalbind) | |
780 | ||
781 | constraint : (NONE) | |
782 | | COLON ty (SOME ty) | |
783 | ||
784 | funs : clausesTop ([clausesTop]) | |
785 | | clausesTop AND funs (clausesTop :: funs) | |
786 | ||
787 | clausesTop: clauses (Vector.fromList clauses) | |
788 | | optbar' clauses (Vector.fromList clauses) | |
789 | ||
790 | clauses : clause ([clause]) | |
791 | | clause BAR clauses (clause :: clauses) | |
792 | ||
793 | clause : apats constraint EQUALOP exp ({pats = Vector.fromList apats, | |
794 | resultType = constraint, | |
795 | body = exp}) | |
796 | ||
797 | typBind : tbs | |
798 | (TypBind.makeRegion' (TypBind.T tbs, tbsleft, tbsright)) | |
799 | ||
800 | tbs : tbs' (Vector.fromList tbs') | |
801 | ||
802 | tbs' : tb ([tb]) | |
803 | | tb AND tbs' (tb :: tbs') | |
804 | ||
805 | tb : tyvars tycon EQUALOP ty | |
806 | ({def = ty, | |
807 | tycon = tycon, | |
808 | tyvars = tyvars}) | |
809 | ||
810 | tyvars : tyvarseq (tyvarseq) | |
811 | | (Vector.new0 ()) | |
812 | ||
813 | tyvarseq: tyvar (Vector.new1 tyvar) | |
814 | | LPAREN tyvar_pc RPAREN (Vector.fromList tyvar_pc) | |
815 | ||
816 | tyvar_pc: tyvar ([tyvar]) | |
817 | | tyvar COMMA tyvar_pc (tyvar :: tyvar_pc) | |
818 | ||
819 | constrs : constr ([constr]) | |
820 | | constr BAR constrs (constr :: constrs) | |
821 | ||
822 | constr : opcon (opcon, NONE) | |
823 | | opcon OF ty (opcon, SOME ty) | |
824 | ||
825 | opcon : con (con) | |
826 | | OP con (con) | |
827 | ||
828 | ebs : eb ([eb]) | |
829 | | eb AND ebs (eb::ebs) | |
830 | ||
831 | eb : opcon ebrhs (opcon, ebrhs) | |
832 | ||
833 | ebrhs : ebrhsnode (EbRhs.makeRegion' (ebrhsnode, | |
834 | ebrhsnodeleft, ebrhsnoderight)) | |
835 | ||
836 | ebrhsnode : (EbRhs.Gen NONE) | |
837 | | OF ty (EbRhs.Gen (SOME ty)) | |
838 | | EQUALOP longcon (EbRhs.Def longcon) | |
839 | | EQUALOP OP longcon (EbRhs.Def longcon) | |
840 | ||
841 | fixity : INFIX (Fixity.Infix NONE) | |
842 | | INFIX digit (Fixity.Infix (SOME digit)) | |
843 | | INFIXR (Fixity.Infixr NONE) | |
844 | | INFIXR digit (Fixity.Infixr (SOME digit)) | |
845 | | NONFIX (Fixity.Nonfix) | |
846 | ||
847 | priority : (Priority.T NONE) | |
848 | | digit (Priority.T (SOME digit)) | |
849 | ||
850 | int : INT | |
851 | (let | |
852 | val {digits, negate, radix, ...} = INT | |
853 | in | |
854 | case StringCvt.scanString (fn r => IntInf.scan (radix, r)) digits of | |
855 | NONE => Error.bug "parser saw invalid int" | |
856 | | SOME i => if negate then ~ i else i | |
857 | end) | |
858 | ||
859 | word : WORD | |
860 | (let | |
861 | val {digits, radix} = WORD | |
862 | in | |
863 | case StringCvt.scanString (fn r => IntInf.scan (radix, r)) digits of | |
864 | NONE => Error.bug "parser saw invalid word" | |
865 | | SOME i => i | |
866 | end) | |
867 | ||
868 | digit : INT | |
869 | (let | |
870 | val {digits, extended, negate, radix} = INT | |
871 | in | |
872 | if 1 = String.size digits andalso not extended andalso not negate andalso radix = StringCvt.DEC | |
873 | then valOf (Int.fromString digits) | |
874 | else let | |
875 | open Layout | |
876 | val _ = | |
877 | Control.error (reg (INTleft, INTright), | |
878 | str "invalid digit in infix declaration", | |
879 | empty) | |
880 | in | |
881 | 0 | |
882 | end | |
883 | end) | |
884 | ||
885 | numericField : INT | |
886 | (let | |
887 | val {digits, extended, negate, radix} = INT | |
888 | fun err () = | |
889 | let | |
890 | open Layout | |
891 | val _ = | |
892 | Control.error (reg (INTleft, INTright), | |
893 | str "invalid numeric label", | |
894 | empty) | |
895 | in | |
896 | 1 | |
897 | end | |
898 | in | |
899 | if String.sub (digits, 0) <> #"0" andalso not extended andalso not negate andalso radix = StringCvt.DEC | |
900 | then case StringCvt.scanString (fn r => IntInf.scan (radix, r)) digits of | |
901 | NONE => Error.bug "parser saw invalid int" | |
902 | | SOME i => (IntInf.toInt (if negate then ~ i else i) | |
903 | handle Exn.Overflow => err ()) | |
904 | else err () | |
905 | end) | |
906 | ||
907 | datatypeRhs | |
908 | : datatypeRhsnode | |
909 | (DatatypeRhs.makeRegion' (datatypeRhsnode, | |
910 | datatypeRhsnodeleft, datatypeRhsnoderight)) | |
911 | ||
912 | datatypeRhsnode | |
913 | : repl (repl) | |
914 | | datBind (DatatypeRhs.DatBind datBind) | |
915 | ||
916 | repl : tyvars tycon EQUALOP DATATYPE longtycon | |
917 | (if Vector.isEmpty tyvars | |
918 | then () | |
919 | else error (reg (tyvarsleft, tyvarsright), | |
920 | "nonempty tyvars in datatype repl") | |
921 | ; DatatypeRhs.Repl {lhs = tycon, rhs = longtycon}) | |
922 | ||
923 | datBind | |
924 | : dbs | |
925 | (DatBind.make (dbs, TypBind.empty, dbsleft, dbsright)) | |
926 | | dbs withtypes | |
927 | (DatBind.make (dbs, withtypes, dbsleft, withtypesright)) | |
928 | ||
929 | dbs : dbs' (Vector.fromList dbs') | |
930 | ||
931 | dbs' : db ([db]) | |
932 | | db AND dbs' (db :: dbs') | |
933 | ||
934 | db : tyvars tycon EQUALOP optbar constrs | |
935 | ({cons = Vector.fromList constrs, | |
936 | tycon = tycon, | |
937 | tyvars = tyvars}) | |
938 | ||
939 | withtypes : WITHTYPE typBind (typBind) | |
940 | ||
941 | longvidands : longvid ([longvid]) | |
942 | | longvid AND longvidands (longvid :: longvidands) | |
943 | ||
944 | match : optbar rules (Match.makeRegion' (Match.T (Vector.fromList rules), | |
945 | rulesleft, rulesright)) | |
946 | ||
947 | rules : rule ([rule]) | |
948 | | rule BAR rules (rule :: rules) | |
949 | ||
950 | rule : pat DARROW exp ((pat,exp)) | |
951 | ||
952 | elabel : field EQUALOP exp (field, (reg (fieldleft, fieldright), exp)) | |
953 | | idField constraint (if allowRecordPunExps () | |
954 | then () | |
955 | else error (reg (idFieldleft, idFieldright), "Record punning expressions disallowed, compile with -default-ann 'allowRecordPunExps true'") | |
956 | ; (Field.Symbol (#1 idField), | |
957 | (reg (idFieldleft, idFieldright), | |
958 | let | |
959 | val exp = | |
960 | Exp.makeRegion' | |
961 | (Exp.FlatApp | |
962 | (Vector.new1 | |
963 | (Exp.makeRegion' | |
964 | (Exp.Var {name = Longvid.short (Vid.fromSymbol idField), | |
965 | fixop = Fixop.None}, | |
966 | idFieldleft, idFieldright))), | |
967 | idFieldleft, idFieldright) | |
968 | val exp = | |
969 | case constraint of | |
970 | NONE => exp | |
971 | | SOME ty => | |
972 | Exp.makeRegion' | |
973 | (Exp.Constraint (exp, ty), | |
974 | idFieldleft, constraintright) | |
975 | in | |
976 | exp | |
977 | end))) | |
978 | ||
979 | elabels : elabel COMMA elabels (elabel :: elabels) | |
980 | | elabel ([elabel]) | |
981 | ||
982 | exp_ps : exp optsemicolon ([exp]) | |
983 | | exp SEMICOLON exp_ps (exp :: exp_ps) | |
984 | ||
985 | exp : expnode (Exp.makeRegion' (expnode, expnodeleft, expnoderight)) | |
986 | ||
987 | expnode : exp HANDLE match (Exp.Handle (exp, match)) | |
988 | | exp ORELSE exp (Exp.Orelse (exp1, exp2)) | |
989 | | exp ANDALSO exp (Exp.Andalso (exp1, exp2)) | |
990 | | exp COLON ty (Exp.Constraint (exp, ty)) | |
991 | | app_exp (Exp.FlatApp (Vector.fromList app_exp)) | |
992 | | FN match (Exp.Fn match) | |
993 | | CASE exp OF match (Exp.Case (exp, match)) | |
994 | | WHILE exp DO exp (Exp.While {test = exp1, expr = exp2}) | |
995 | | IF exp THEN exp ELSE exp (Exp.If (exp1, exp2, exp3)) | |
996 | | RAISE exp (Exp.Raise exp) | |
997 | ||
998 | app_exp : aexp ([Exp.makeRegion' (aexp, aexpleft, aexpright)]) | |
999 | | aexp app_exp (Exp.makeRegion' (aexp, aexpleft, aexpright) | |
1000 | :: app_exp) | |
1001 | | longvid ([Exp.makeRegion' (Exp.Var {name = longvid, | |
1002 | fixop = Fixop.None}, | |
1003 | longvidleft, longvidright)]) | |
1004 | | longvid app_exp (Exp.makeRegion' (Exp.Var {name = longvid, | |
1005 | fixop = Fixop.None}, | |
1006 | longvidleft, longvidright) | |
1007 | :: app_exp) | |
1008 | ||
1009 | aexp : OP longvid (Exp.Var {name = longvid, | |
1010 | fixop = Fixop.Op}) | |
1011 | | const (Exp.Const const) | |
1012 | | HASH field (Exp.Selector field) | |
1013 | | HASHLBRACKET exp_list RBRACKET (Exp.Vector (Vector.fromList exp_list)) | |
1014 | | HASHLBRACKET RBRACKET (Exp.Vector (Vector.new0 ())) | |
1015 | | LBRACE elabels RBRACE | |
1016 | (Exp.Record (Record.fromVector (Vector.fromList elabels))) | |
1017 | | LBRACE RBRACE (Exp.unit) | |
1018 | | LPAREN RPAREN (Exp.unit) | |
1019 | | LPAREN exp_ps RPAREN | |
1020 | (case exp_ps of | |
1021 | [exp] => Exp.Paren exp | |
1022 | | _ => Exp.Seq (Vector.fromList exp_ps)) | |
1023 | | LPAREN exp_2c RPAREN (Exp.tuple (Vector.fromList exp_2c)) | |
1024 | | LBRACKET exp_list RBRACKET (Exp.List (Vector.fromList exp_list)) | |
1025 | | LBRACKET RBRACKET (Exp.List (Vector.new0 ())) | |
1026 | | LET decs IN exp_ps END | |
1027 | (Exp.Let (decs, | |
1028 | case exp_ps of | |
1029 | [exp] => exp | |
1030 | | _ => Exp.makeRegion' (Exp.Seq (Vector.fromList exp_ps), | |
1031 | exp_psleft, exp_psright))) | |
1032 | | ADDRESS string symattributes COLON ty SEMICOLON | |
1033 | (Exp.Prim (PrimKind.Address {attributes = symattributes, | |
1034 | name = string, | |
1035 | ty = ty})) | |
1036 | | BUILD_CONST string COLON ty SEMICOLON | |
1037 | (Exp.Prim (PrimKind.BuildConst {name = string, ty = ty})) | |
1038 | | COMMAND_LINE_CONST string COLON ty EQUALOP constOrBool SEMICOLON | |
1039 | (Exp.Prim (PrimKind.CommandLineConst {name = string, | |
1040 | ty = ty, | |
1041 | value = constOrBool})) | |
1042 | | CONST string COLON ty SEMICOLON | |
1043 | (Exp.Prim (PrimKind.Const {name = string, ty = ty})) | |
1044 | | EXPORT string ieattributes COLON ty SEMICOLON | |
1045 | (Exp.Prim (PrimKind.Export {attributes = ieattributes, | |
1046 | name = string, | |
1047 | ty = ty})) | |
1048 | | IMPORT string ieattributes COLON ty SEMICOLON | |
1049 | (Exp.Prim (PrimKind.Import {attributes = ieattributes, | |
1050 | name = string, | |
1051 | ty = ty})) | |
1052 | | IMPORT ASTERISK ieattributes COLON ty SEMICOLON | |
1053 | (Exp.Prim (PrimKind.IImport {attributes = ieattributes, | |
1054 | ty = ty})) | |
1055 | | PRIM string COLON ty SEMICOLON | |
1056 | (Exp.Prim (PrimKind.Prim {name = string, | |
1057 | ty = ty})) | |
1058 | | SYMBOL string symattributes COLON ty SEMICOLON | |
1059 | (Exp.Prim (PrimKind.Symbol {attributes = symattributes, | |
1060 | name = string, | |
1061 | ty = ty})) | |
1062 | | SYMBOL ASTERISK COLON ty SEMICOLON | |
1063 | (Exp.Prim (PrimKind.ISymbol {ty = ty})) | |
1064 | ||
1065 | ieattributes | |
1066 | : | |
1067 | ([]) | |
1068 | | shortAlphanumId ieattributes | |
1069 | (let | |
1070 | val (id, reg) = shortAlphanumId | |
1071 | in | |
1072 | case Symbol.toString id of | |
1073 | "cdecl" => PrimKind.ImportExportAttribute.Cdecl :: ieattributes | |
1074 | | "external" => PrimKind.ImportExportAttribute.External :: ieattributes | |
1075 | | "impure" => PrimKind.ImportExportAttribute.Impure :: ieattributes | |
1076 | | "private" => PrimKind.ImportExportAttribute.Private :: ieattributes | |
1077 | | "public" => PrimKind.ImportExportAttribute.Public :: ieattributes | |
1078 | | "pure" => PrimKind.ImportExportAttribute.Pure :: ieattributes | |
1079 | | "reentrant" => PrimKind.ImportExportAttribute.Reentrant :: ieattributes | |
1080 | | "runtime" => PrimKind.ImportExportAttribute.Runtime :: ieattributes | |
1081 | | "stdcall" => PrimKind.ImportExportAttribute.Stdcall :: ieattributes | |
1082 | | id => (error (reg, concat ["invalid attribute: ", id]) | |
1083 | ; ieattributes) | |
1084 | end) | |
1085 | ||
1086 | symattributes | |
1087 | : | |
1088 | ([]) | |
1089 | | shortAlphanumId symattributes | |
1090 | (let | |
1091 | val (id, reg) = shortAlphanumId | |
1092 | in | |
1093 | case Symbol.toString id of | |
1094 | "alloc" => PrimKind.SymbolAttribute.Alloc :: symattributes | |
1095 | | "external" => PrimKind.SymbolAttribute.External :: symattributes | |
1096 | | "private" => PrimKind.SymbolAttribute.Private :: symattributes | |
1097 | | "public" => PrimKind.SymbolAttribute.Public :: symattributes | |
1098 | | id => (error (reg, concat ["invalid attribute: ", id]) | |
1099 | ; symattributes) | |
1100 | end) | |
1101 | ||
1102 | exp_2c : exp COMMA exp_2c (exp :: exp_2c) | |
1103 | | exp COMMA exp ([exp1, exp2]) | |
1104 | ||
1105 | exp_list : exp ([exp]) | |
1106 | | exp COMMA exp_list (exp :: exp_list) | |
1107 | ||
1108 | (*---------------------------------------------------*) | |
1109 | (* Patterns *) | |
1110 | (*---------------------------------------------------*) | |
1111 | ||
1112 | pat : cpat BAR barcpats (Pat.makeRegion' (Pat.Or (Vector.fromList (cpat::barcpats)), | |
1113 | cpatleft, barcpatsright)) | |
1114 | | cpat (cpat) | |
1115 | ||
1116 | cpat : cpatnode (Pat.makeRegion' (cpatnode, cpatnodeleft, cpatnoderight)) | |
1117 | ||
1118 | cpatnode : cpat AS cpat (Pat.makeAs (cpat1, cpat2)) | |
1119 | | cpat COLON ty (Pat.Constraint (cpat, ty)) | |
1120 | | apats (Pat.FlatApp (Vector.fromList apats)) | |
1121 | ||
1122 | apats : apat ([apat]) | |
1123 | | apat apats (apat :: apats) | |
1124 | ||
1125 | apat | |
1126 | : apatnode (Pat.makeRegion' (apatnode, | |
1127 | apatnodeleft, | |
1128 | apatnoderight)) | |
1129 | ||
1130 | apatnode | |
1131 | : longvidNoEqual (Pat.Var {name = longvidNoEqual, | |
1132 | fixop = Fixop.None}) | |
1133 | | OP longvid (Pat.Var {name = longvid, | |
1134 | fixop = Fixop.Op}) | |
1135 | | const | |
1136 | (let | |
1137 | val _ = | |
1138 | case Const.node const of | |
1139 | Const.Real r => | |
1140 | let | |
1141 | open Layout | |
1142 | in | |
1143 | Control.error | |
1144 | (Const.region const, | |
1145 | seq [str "real constants not allowed in patterns: ", | |
1146 | Const.layout const], | |
1147 | empty) | |
1148 | end | |
1149 | | _ => () | |
1150 | in | |
1151 | Pat.Const const | |
1152 | end) | |
1153 | | WILD (Pat.Wild) | |
1154 | | LPAREN pats RPAREN (Pat.tuple (Vector.fromList pats)) | |
1155 | | LBRACKET pats RBRACKET (Pat.List (Vector.fromList pats)) | |
1156 | | HASHLBRACKET pats RBRACKET (Pat.Vector (Vector.fromList pats)) | |
1157 | | LBRACE RBRACE (Pat.unit) | |
1158 | | LBRACE patitems RBRACE | |
1159 | (let | |
1160 | val (items, flexible) = patitems | |
1161 | in | |
1162 | Pat.Record {flexible = flexible, | |
1163 | items = Vector.fromList items} | |
1164 | end) | |
1165 | ||
1166 | pats : ([]) | |
1167 | | pat commapats (pat :: commapats) | |
1168 | ||
1169 | barcpats : cpat ([cpat]) | |
1170 | | cpat BAR barcpats (cpat :: barcpats) | |
1171 | ||
1172 | commapats : ([]) | |
1173 | | COMMA pat commapats (pat :: commapats) | |
1174 | ||
1175 | patitems : patitem COMMA patitems (let val (items, f) = patitems | |
1176 | in (patitem :: items, f) | |
1177 | end) | |
1178 | | patitem ([patitem], false) | |
1179 | | DOTDOTDOT ([], true) | |
1180 | ||
1181 | patitem | |
1182 | : field EQUALOP pat | |
1183 | ((field, reg (fieldleft, fieldright), Pat.Item.Field pat)) | |
1184 | | vid constraint opaspat | |
1185 | (Field.Symbol (Vid.toSymbol vid), | |
1186 | reg (vidleft, vidright), | |
1187 | Pat.Item.Vid (vid, constraint, opaspat)) | |
1188 | ||
1189 | opaspat : (NONE) | |
1190 | | AS pat (SOME pat) | |
1191 | ||
1192 | (*---------------------------------------------------*) | |
1193 | (* Types *) | |
1194 | (*---------------------------------------------------*) | |
1195 | ||
1196 | ty : tynode (Type.makeRegion' (tynode, tynodeleft, tynoderight)) | |
1197 | ||
1198 | tynode : tuple_ty (Type.tuple (Vector.fromList tuple_ty)) | |
1199 | | ty ARROW ty (Type.arrow (ty1, ty2)) | |
1200 | | ty'node (ty'node) | |
1201 | ||
1202 | ty' : ty'node (Type.makeRegion' (ty'node, ty'nodeleft, ty'noderight)) | |
1203 | ||
1204 | ty'node : tyvar (Type.Var tyvar) | |
1205 | | LBRACE tlabels RBRACE | |
1206 | (Type.Record (Record.fromVector (Vector.fromList tlabels))) | |
1207 | | LBRACE RBRACE (Type.unit) | |
1208 | | LPAREN ty0_pc RPAREN longtycon (Type.Con (longtycon, | |
1209 | Vector.fromList ty0_pc)) | |
1210 | | LPAREN ty RPAREN (Type.Paren ty) | |
1211 | | ty' longtycon (Type.Con (longtycon, | |
1212 | Vector.new1 ty')) | |
1213 | | longtycon (Type.Con (longtycon, | |
1214 | Vector.new0 ())) | |
1215 | ||
1216 | tlabel : field COLON ty (field, (reg (fieldleft, fieldright), ty)) | |
1217 | ||
1218 | tlabels : tlabel COMMA tlabels (tlabel :: tlabels) | |
1219 | | tlabel ([tlabel]) | |
1220 | ||
1221 | tuple_ty : ty' ASTERISK tuple_ty (ty' :: tuple_ty) | |
1222 | | ty' ASTERISK ty' ([ty'1, ty'2]) | |
1223 | ||
1224 | ty0_pc : ty COMMA ty ([ty1, ty2]) | |
1225 | | ty COMMA ty0_pc (ty :: ty0_pc) | |
1226 | ||
1227 | (*---------------------------------------------------*) | |
1228 | (* Atoms *) | |
1229 | (*---------------------------------------------------*) | |
1230 | ||
1231 | optbar | |
1232 | : (* empty *) () | |
1233 | | optbar' () | |
1234 | ||
1235 | optbar' | |
1236 | : BAR (if allowOptBar () | |
1237 | then () | |
1238 | else error (reg (BARleft, BARright), "Optional bar disallowed, compile with -default-ann 'allowOptBar true'")) | |
1239 | ||
1240 | optsemicolon | |
1241 | : (* empty *) () | |
1242 | | SEMICOLON (if allowOptSemicolon () | |
1243 | then () | |
1244 | else error (reg (SEMICOLONleft, SEMICOLONright), "Optional semicolon disallowed, compile with -default-ann 'allowOptSemicolon true'")) | |
1245 | ||
1246 | constOrBool | |
1247 | : const (const) | |
1248 | | shortAlphanumId | |
1249 | (let | |
1250 | fun ok b = Const.makeRegion (Const.Bool b, #2 shortAlphanumId) | |
1251 | in | |
1252 | case Symbol.toString (#1 shortAlphanumId) of | |
1253 | "false" => ok false | |
1254 | | "true" => ok true | |
1255 | | s => (error (#2 shortAlphanumId, concat ["unknown boolean constant: ", s]) | |
1256 | ; ok false) | |
1257 | end) | |
1258 | ||
1259 | const : const' (Const.makeRegion | |
1260 | (const', reg (const'left, const'right))) | |
1261 | ||
1262 | const' : int (Const.Int int) | |
1263 | | word (Const.Word word) | |
1264 | | REAL (Const.Real REAL) | |
1265 | | STRING (Const.String STRING) | |
1266 | | CHAR (Const.Char CHAR) | |
1267 | ||
1268 | string : STRING (CharVector.tabulate | |
1269 | (Vector.length STRING, fn i => | |
1270 | Char.fromInt (Int.fromIntInf (Vector.sub (STRING, i))))) | |
1271 | ||
1272 | ||
1273 | shortAlphanumId | |
1274 | : SHORTALPHANUMID | |
1275 | (shortIdFromTok (SHORTALPHANUMID, SHORTALPHANUMIDleft, SHORTALPHANUMIDright)) | |
1276 | shortSymId | |
1277 | : SHORTSYMID | |
1278 | (shortIdFromTok (SHORTSYMID, SHORTSYMIDleft, SHORTSYMIDright)) | |
1279 | longAlphanumId | |
1280 | : LONGALPHANUMID | |
1281 | (longIdFromTok (LONGALPHANUMID, LONGALPHANUMIDleft, LONGALPHANUMIDright)) | |
1282 | longSymId | |
1283 | : LONGSYMID | |
1284 | (longIdFromTok (LONGSYMID, LONGSYMIDleft, LONGSYMIDright)) | |
1285 | ||
1286 | vidNoEqual : shortAlphanumId (Vid.fromSymbol shortAlphanumId) | |
1287 | | shortSymId (Vid.fromSymbol shortSymId) | |
1288 | | ASTERISK (Vid.fromSymbol (Symbol.asterisk, | |
1289 | reg (ASTERISKleft, ASTERISKright))) | |
1290 | vidEqual : EQUALOP (Vid.fromSymbol (Symbol.equal, | |
1291 | reg (EQUALOPleft, EQUALOPright))) | |
1292 | vid : vidNoEqual (vidNoEqual) | |
1293 | | vidEqual (vidEqual) | |
1294 | longvidNoEqual : vidNoEqual (Longvid.short vidNoEqual) | |
1295 | | longAlphanumId (Longvid.fromSymbols longAlphanumId) | |
1296 | | longSymId (Longvid.fromSymbols longSymId) | |
1297 | longvidEqual : vidEqual (Longvid.short vidEqual) | |
1298 | longvid : longvidNoEqual (longvidNoEqual) | |
1299 | | longvidEqual (longvidEqual) | |
1300 | ||
1301 | con : vid (Vid.toCon vid) | |
1302 | longcon : longvid (Longvid.toLongcon longvid) | |
1303 | ||
1304 | tyvar : TYVAR (Tyvar.fromSymbol (Symbol.fromString TYVAR, reg (TYVARleft, TYVARright))) | |
1305 | ||
1306 | tycon : shortAlphanumId (Tycon.fromSymbol shortAlphanumId) | |
1307 | | shortSymId (Tycon.fromSymbol shortSymId) | |
1308 | longtycon : tycon (Longtycon.short tycon) | |
1309 | | longAlphanumId (Longtycon.fromSymbols longAlphanumId) | |
1310 | ||
1311 | idField : shortAlphanumId (shortAlphanumId) | |
1312 | | shortSymId (shortSymId) | |
1313 | | ASTERISK ((Symbol.asterisk, | |
1314 | reg (ASTERISKleft, ASTERISKright))) | |
1315 | field : idField (Field.Symbol (#1 idField)) | |
1316 | | numericField (Field.Int (numericField - 1)) | |
1317 | ||
1318 | strid : shortAlphanumId (Strid.fromSymbol shortAlphanumId) | |
1319 | longstrid : strid (Longstrid.short strid) | |
1320 | | longAlphanumId (Longstrid.fromSymbols longAlphanumId) | |
1321 | ||
1322 | sigid : shortAlphanumId (Sigid.fromSymbol shortAlphanumId) | |
1323 | fctid : shortAlphanumId (Fctid.fromSymbol shortAlphanumId) | |
1324 | ||
1325 | vids : vid ([vid]) | |
1326 | | vid vids (vid::vids) | |
1327 | ||
1328 | sigids : sigid ([sigid]) | |
1329 | | sigid sigids (sigid :: sigids) | |
1330 | ||
1331 | longstrids : longstrid ([longstrid]) | |
1332 | | longstrid longstrids (longstrid :: longstrids) |