Commit | Line | Data |
---|---|---|
7f918cf1 CE |
1 | (* Heavily modified from the SML/NJ sources. *) |
2 | ||
3 | (* Copyright 1996 by AT&T Bell Laboratories *) | |
4 | (* precedence.sml *) | |
5 | ||
6 | functor PrecedenceParse (S: PRECEDENCE_PARSE_STRUCTS): PRECEDENCE_PARSE = | |
7 | struct | |
8 | ||
9 | open S | |
10 | ||
11 | local open Ast | |
12 | in structure Exp = Exp | |
13 | structure Fixity = Fixity | |
14 | structure Fixop = Fixop | |
15 | structure Longvid = Longvid | |
16 | structure Pat = Pat | |
17 | structure Vid = Vid | |
18 | end | |
19 | ||
20 | structure Exp = | |
21 | struct | |
22 | open Exp | |
23 | fun apply {func, arg} = Exp.app (func, arg) | |
24 | fun applyInfix {func, argl, argr} = | |
25 | let | |
26 | val arg = Exp.tuple (Vector.new2 (argl, argr)) | |
27 | in | |
28 | Exp.makeRegion (Exp.App (func, arg), | |
29 | Exp.region arg) | |
30 | end | |
31 | end | |
32 | ||
33 | structure Pat = | |
34 | struct | |
35 | open Pat | |
36 | local | |
37 | fun finishApply {func, arg, region, ctxt} = | |
38 | case Pat.node func of | |
39 | Pat.Var {name, ...} => | |
40 | Pat.makeRegion (Pat.App (Longvid.toLongcon name, arg), | |
41 | region) | |
42 | | _ => | |
43 | let | |
44 | val () = | |
45 | Control.error | |
46 | (region, | |
47 | Layout.str "non-constructor applied to argument in pattern", | |
48 | ctxt ()) | |
49 | in | |
50 | Pat.wild | |
51 | end | |
52 | in | |
53 | fun apply ctxt {func, arg} = | |
54 | finishApply {func = func, arg = arg, | |
55 | region = Region.append (Pat.region func, Pat.region arg), | |
56 | ctxt = ctxt} | |
57 | fun applyInfix ctxt {func, argl, argr} = | |
58 | let | |
59 | val arg = Pat.tuple (Vector.new2 (argl, argr)) | |
60 | in | |
61 | finishApply {func = func, arg = arg, | |
62 | region = Pat.region arg, | |
63 | ctxt = ctxt} | |
64 | end | |
65 | end | |
66 | end | |
67 | ||
68 | structure Fixval = | |
69 | struct | |
70 | datatype t = Nonfix | Infix of int * int | |
71 | ||
72 | fun eval (f: Fixity.t): t = | |
73 | case f of | |
74 | Fixity.Infix NONE => Infix (0, 1) | |
75 | | Fixity.Infix (SOME n) => Infix (n+n, n+n+1) | |
76 | | Fixity.Infixr NONE => Infix (1, 0) | |
77 | | Fixity.Infixr (SOME n) => Infix (n+n+1, n+n) | |
78 | | Fixity.Nonfix => Nonfix | |
79 | ||
80 | fun make ({name: Longvid.t, fixop: Fixop.t}, E: Env.t): t = | |
81 | case (fixop, Longvid.split name) of | |
82 | (Fixop.None, ([], vid)) => | |
83 | (case Env.peekFix (E, vid) of | |
84 | NONE => Nonfix | |
85 | | SOME f => eval f) | |
86 | | _ => Nonfix | |
87 | ||
88 | fun makePat (p: Pat.t, E: Env.t): t = | |
89 | case Pat.node p of | |
90 | Pat.Var r => make (r, E) | |
91 | | _ => Nonfix | |
92 | ||
93 | fun makeExp (e: Exp.t, E: Env.t): t = | |
94 | case Exp.node e of | |
95 | Exp.Var r => make (r, E) | |
96 | | _ => Nonfix | |
97 | end | |
98 | ||
99 | (*---------------------------------------------------*) | |
100 | (* from elaborate/precedence.sml *) | |
101 | (*---------------------------------------------------*) | |
102 | ||
103 | datatype 'a precStack = | |
104 | INf of int * 'a * 'a precStack | |
105 | | NONf of 'a * 'a precStack | |
106 | | NILf | |
107 | ||
108 | fun 'a parse {apply: {func: 'a, arg: 'a} -> 'a, | |
109 | applyInfix: {func: 'a, argl: 'a, argr: 'a} -> 'a, | |
110 | ctxt: unit -> Layout.t, | |
111 | fixval: 'a -> Fixval.t, | |
112 | items: 'a vector, | |
113 | name: string, | |
114 | region: 'a -> Region.t, | |
115 | toString: 'a -> string}: 'a = | |
116 | let | |
117 | fun error (r: Region.t, msg: string) = | |
118 | Control.error (r, Layout.str msg, ctxt ()) | |
119 | fun ensureNONf ((e, f), p, start) = | |
120 | let | |
121 | val _ = | |
122 | case f of | |
123 | Fixval.Nonfix => () | |
124 | | _ => | |
125 | error | |
126 | (region e, | |
127 | concat [if start | |
128 | then name ^ " starts with infix identifier: " | |
129 | else "identifier must be used infix: ", | |
130 | toString e]) | |
131 | in | |
132 | NONf (e, p) | |
133 | end | |
134 | fun start token = ensureNONf (token, NILf, true) | |
135 | (* parse an expression *) | |
136 | fun parse (stack: 'a precStack, (item: 'a, fixval: Fixval.t)) = | |
137 | case (stack, (item, fixval)) of | |
138 | (NONf (e, r), (e', Fixval.Nonfix)) => NONf (apply {func = e, arg = e'}, r) | |
139 | | (p as INf _, token) => ensureNONf (token, p, false) | |
140 | | (p as NONf (e1, INf (bp, e2, NONf (e3, r))), | |
141 | (e4, f as Fixval.Infix (lbp, rbp))) => | |
142 | if lbp > bp then INf (rbp, e4, p) | |
143 | else (if lbp = bp | |
144 | then error (Region.append (region e2, region e4), | |
145 | concat ["infix identifiers with equal precedence but mixed associativity: ", toString e2, ", ", toString e4]) | |
146 | else (); | |
147 | parse (NONf (applyInfix {func = e2, argl = e3, argr = e1}, | |
148 | r), | |
149 | (e4, f))) | |
150 | | (p as NONf _, (e', Fixval.Infix (_, rbp))) => INf (rbp, e', p) | |
151 | | _ => Error.bug "PrecedenceParse.parse.parse" | |
152 | (* clean up the stack *) | |
153 | fun finish stack = | |
154 | case stack of | |
155 | NONf (e1, INf (_, e2, NONf (e3, r))) => | |
156 | finish (NONf (applyInfix {func = e2, argl = e3, argr = e1}, | |
157 | r)) | |
158 | | NONf (e1, NILf) => e1 | |
159 | | INf (_, e1, NONf (e2, p)) => | |
160 | (error (region e1, concat [name, " ends with infix identifier: ", toString e1]) | |
161 | ; finish (NONf (apply {func = e2, arg = e1}, p))) | |
162 | | NILf => Error.bug "PrecedenceParse.parse.finish: NILf" | |
163 | | _ => Error.bug "PrecedenceParse.parse.finish" | |
164 | fun getfix x = (x, fixval x) | |
165 | in | |
166 | if Vector.isEmpty items | |
167 | then | |
168 | Error.bug "PrecedenceParse.parse" | |
169 | else | |
170 | let | |
171 | val item = Vector.first items | |
172 | in | |
173 | finish (Vector.foldFrom | |
174 | (items, 1, start (getfix item), fn (item, state) => | |
175 | parse (state, getfix item))) | |
176 | end | |
177 | end | |
178 | ||
179 | fun parsePat (ps, E, ctxt) = | |
180 | parse {apply = Pat.apply ctxt, | |
181 | applyInfix = Pat.applyInfix ctxt, | |
182 | ctxt = ctxt, | |
183 | fixval = fn p => Fixval.makePat (p, E), | |
184 | items = ps, | |
185 | name = "pattern", | |
186 | region = Pat.region, | |
187 | toString = Layout.toString o Pat.layout} | |
188 | ||
189 | val parsePat = | |
190 | Trace.trace ("PrecedenceParse.parsePat", | |
191 | fn (ps, _, _) => Vector.layout Pat.layout ps, | |
192 | Ast.Pat.layout) | |
193 | parsePat | |
194 | ||
195 | fun parseExp (es, E, ctxt) = | |
196 | parse {apply = Exp.apply, | |
197 | applyInfix = Exp.applyInfix, | |
198 | ctxt = ctxt, | |
199 | fixval = fn e => Fixval.makeExp (e, E), | |
200 | items = es, | |
201 | name = "expression", | |
202 | region = Exp.region, | |
203 | toString = Layout.toString o Exp.layout} | |
204 | ||
205 | val parseExp = | |
206 | Trace.trace ("PrecedenceParse.parseExp", | |
207 | fn (es, _, _) => Vector.layout Exp.layout es, | |
208 | Ast.Exp.layout) | |
209 | parseExp | |
210 | ||
211 | (*---------------------------------------------------*) | |
212 | (* parseClause *) | |
213 | (*---------------------------------------------------*) | |
214 | ||
215 | structure ClausePat = | |
216 | struct | |
217 | datatype t = | |
218 | Apply of {func: t, arg: t} | |
219 | | ApplyInfix of {func: t, argl: t, argr: t} | |
220 | | Pat of Pat.t | |
221 | ||
222 | fun region p = | |
223 | case p of | |
224 | Apply {func, arg} => | |
225 | Region.append (region func, region arg) | |
226 | | ApplyInfix {argl, argr, ...} => | |
227 | Region.append (region argl, region argr) | |
228 | | Pat p => Pat.region p | |
229 | ||
230 | local | |
231 | fun toPat p = | |
232 | case p of | |
233 | Apply {func, arg} => | |
234 | let | |
235 | val func = toPat func | |
236 | val arg = toPat arg | |
237 | in | |
238 | Pat.makeRegion | |
239 | (Pat.FlatApp (Vector.new2 (func, arg)), | |
240 | Region.append (Pat.region func, Pat.region arg)) | |
241 | end | |
242 | | ApplyInfix {func, argl, argr} => | |
243 | let | |
244 | val func = toPat func | |
245 | val argl = toPat argl | |
246 | val argr = toPat argr | |
247 | in | |
248 | Pat.makeRegion | |
249 | (Pat.FlatApp (Vector.new3 (argl, func, argr)), | |
250 | Region.append (Pat.region argl, Pat.region argr)) | |
251 | end | |
252 | | Pat p => p | |
253 | in | |
254 | val layout = Pat.layout o toPat | |
255 | end | |
256 | end | |
257 | ||
258 | fun parseClausePats (ps, E, ctxt) = | |
259 | parse {apply = ClausePat.Apply, | |
260 | applyInfix = ClausePat.ApplyInfix, | |
261 | ctxt = ctxt, | |
262 | fixval = fn ClausePat.Pat p => Fixval.makePat (p, E) | |
263 | | _ => Fixval.Nonfix, | |
264 | items = Vector.map (ps, ClausePat.Pat), | |
265 | name = "function clause", | |
266 | region = ClausePat.region, | |
267 | toString = Layout.toString o ClausePat.layout} | |
268 | ||
269 | fun parseClause (pats: Pat.t vector, E: Env.t, ctxt) = | |
270 | let | |
271 | fun error (region, msg) = | |
272 | Control.error (region, msg, ctxt ()) | |
273 | fun improper region = | |
274 | error | |
275 | (region, Layout.str "function clause with improper infix pattern") | |
276 | ||
277 | fun toPat p= | |
278 | case p of | |
279 | ClausePat.Pat p => p | |
280 | | ClausePat.Apply {func, arg} => | |
281 | Pat.apply ctxt | |
282 | {func = toPat func, | |
283 | arg = toPat arg} | |
284 | | ClausePat.ApplyInfix {func, argl, argr} => | |
285 | Pat.applyInfix ctxt | |
286 | {func = toPat func, | |
287 | argl = toPat argl, | |
288 | argr = toPat argr} | |
289 | fun toPatTop p = | |
290 | case p of | |
291 | ClausePat.Pat p => p | |
292 | | _ => (improper (ClausePat.region p) | |
293 | ; toPat p) | |
294 | fun toPatList p = | |
295 | let | |
296 | fun loop (p, args) = | |
297 | case p of | |
298 | ClausePat.Apply {func, arg} => | |
299 | loop (func, (toPatTop arg)::args) | |
300 | | _ => (toPatTop p)::args | |
301 | in | |
302 | loop (p, []) | |
303 | end | |
304 | ||
305 | fun done (func: Pat.t, args: Pat.t list) = | |
306 | let | |
307 | fun illegalName () = | |
308 | (error (Pat.region func, | |
309 | Layout.seq [Layout.str "function clause with illegal name: ", | |
310 | Pat.layout func]) | |
311 | ; Ast.Var.bogus) | |
312 | val func = | |
313 | case Pat.node func of | |
314 | Pat.Var {name, ...} => | |
315 | (case Longvid.split name of | |
316 | ([], x) => Vid.toVar x | |
317 | | _ => illegalName ()) | |
318 | | _ => illegalName () | |
319 | val args = Vector.fromList args | |
320 | val _ = | |
321 | if Vector.isEmpty args | |
322 | then error (Region.append (Pat.region (Vector.sub (pats, 0)), | |
323 | Pat.region (Vector.last pats)), | |
324 | Layout.str "function clause with no arguments") | |
325 | else () | |
326 | in | |
327 | {func = func, args = args} | |
328 | end | |
329 | fun doneApplyInfix ({func, argl, argr}, rest) = | |
330 | let | |
331 | val func = toPatTop func | |
332 | val argl = toPatTop argl | |
333 | val argr = toPatTop argr | |
334 | in | |
335 | done (func, (Pat.tuple (Vector.new2 (argl, argr)))::rest) | |
336 | end | |
337 | in | |
338 | case parseClausePats (pats, E, ctxt) of | |
339 | ClausePat.ApplyInfix func_argl_argr => | |
340 | doneApplyInfix (func_argl_argr, []) | |
341 | | p => | |
342 | (case toPatList p of | |
343 | [] => Error.bug "PrecedenceParse.parseClause: empty" | |
344 | | p::rest => | |
345 | let | |
346 | val improper = fn () => | |
347 | (improper (Pat.region p) | |
348 | ; done (Pat.var Ast.Var.bogus, rest)) | |
349 | in | |
350 | case Pat.node p of | |
351 | Pat.Paren p' => | |
352 | (case Pat.node p' of | |
353 | Pat.FlatApp pats => | |
354 | (case parseClausePats (pats, E, ctxt) of | |
355 | ClausePat.ApplyInfix func_argl_argr => | |
356 | doneApplyInfix (func_argl_argr, rest) | |
357 | | _ => improper ()) | |
358 | | _ => improper ()) | |
359 | | _ => done (p, rest) | |
360 | end) | |
361 | end | |
362 | ||
363 | end |