1 (* Copyright (C) 2017 Matthew Fluet.
2 * Copyright (C) 1999-2005 Henry Cejtin, Matthew Fluet, Suresh
3 * Jagannathan, and Stephen Weeks.
4 * Copyright (C) 1997-2000 NEC Research Institute.
6 * MLton is released under a BSD-style license.
7 * See the file MLton-LICENSE for details.
10 functor Scope (S: SCOPE_STRUCTS): SCOPE =
16 structure Tyvars = UnorderedSet (Tyvar)
20 val fromVector = fn v =>
21 Vector.fold (v, empty, fn (x, s) => add (s, x))
26 {(* bindType is used at datatype and type declarations. *)
27 bindType: ('down * Tyvar.t vector
28 -> 'down * ('up -> 'up)),
29 (* bindFunVal is used at fun, overload, and val declarations. *)
30 bindFunVal: ('down * Tyvar.t vector * Region.t
31 -> ('down * ('up -> Tyvar.t vector * 'up))),
32 combineUp: 'up * 'up -> 'up,
35 tyvar: Tyvar.t * 'down -> 'up
38 fun visits (xs: 'a vector, visitX: 'a -> 'up): 'up =
39 Vector.fold (xs, initUp, fn (x, u) => combineUp (u, visitX x))
40 fun loops (xs: 'a vector, loopX: 'a -> 'a * 'up): 'a vector * 'up =
41 Vector.mapAndFold (xs, initUp, fn (x, u) =>
45 (x, combineUp (u, u'))
47 fun visitTy (t: Type.t, d: 'down): 'up =
49 datatype z = datatype Type.node
50 fun visit (t: Type.t): 'up =
52 Con (_, ts) => visits (ts, visit)
56 (r, initUp, fn ((_, t), u) =>
57 combineUp (u, visit t))
58 | Var a => tyvar (a, d)
62 fun visitTyOpt (to: Type.t option, d: 'down): 'up =
65 | SOME t => visitTy (t, d)
66 fun visitTypBind (tb: TypBind.t, d: 'down): 'up =
68 val TypBind.T tbs = TypBind.node tb
71 (tbs, fn {def, tyvars, ...} =>
73 val (d, finish) = bindType (d, tyvars)
75 finish (visitTy (def, d))
80 fun visitDatBind (db: DatBind.t, d: 'down): 'up =
82 val DatBind.T {datatypes, withtypes} = DatBind.node db
85 (datatypes, fn {cons, tyvars, ...} =>
87 val (d, finish) = bindType (d, tyvars)
89 finish (visits (cons, fn (_, arg) =>
92 val u' = visitTypBind (withtypes, d)
96 fun visitPat (p: Pat.t, d: 'down): 'up =
98 datatype z = datatype Pat.node
99 fun visit (p: Pat.t): 'up =
101 App (_, p) => visit p
103 | Constraint (p, t) =>
104 combineUp (visit p, visitTy (t, d))
105 | FlatApp ps => visits (ps, visit)
106 | Layered {constraint, pat, ...} =>
107 combineUp (visitTyOpt (constraint, d), visit pat)
108 | List ps => visits (ps, visit)
109 | Or ps => visits (ps, visit)
111 | Record {items, ...} =>
113 (items, initUp, fn ((_, _, i), u) =>
115 datatype z = datatype Pat.Item.t
121 val u = visitTyOpt (to, d)
129 | Tuple ps => visits (ps, visit)
131 | Vector ps => visits (ps, visit)
140 fun visitPrimKind (kind: PrimKind.t, d: 'down): 'up =
142 datatype z = datatype PrimKind.t
147 | BuildConst {ty, ...} =>
149 | CommandLineConst {ty, ...} =>
153 | Export {ty, ...} =>
155 | IImport {ty, ...} =>
157 | Import {ty, ...} =>
163 | Symbol {ty, ...} =>
166 fun loopDec (d: Dec.t, down: 'down): Dec.t * 'up =
168 fun doit n = Dec.makeRegion (n, Dec.region d)
169 fun do1 ((a, u), f) = (doit (f a), u)
170 fun do2 ((a1, u1), (a2, u2), f) =
171 (doit (f (a1, a2)), combineUp (u1, u2))
172 fun doVec (ds: Dec.t vector, f: Dec.t vector -> Dec.node)
175 val (ds, u) = loops (ds, fn d => loopDec (d, down))
179 fun empty () = (d, initUp)
180 datatype z = datatype Dec.node
183 Abstype {body, datBind} =>
185 val (body, u) = loopDec (body, down)
186 val u' = visitDatBind (datBind, down)
188 (doit (Abstype {body = body, datBind = datBind}),
193 datatype z = datatype DatatypeRhs.node
195 case DatatypeRhs.node rhs of
196 DatBind db => visitDatBind (db, down)
202 do1 (loopExp (e, down), DoDec)
206 visits (ebs, fn (_, rhs) =>
208 datatype z = datatype EbRhs.node
210 case EbRhs.node rhs of
214 val u = visitTyOpt (to, down)
225 | Fun {tyvars, fbs} =>
227 val (down, finish) = bindFunVal (down, tyvars, Dec.region d)
229 loops (fbs, fn clauses =>
233 (clauses, fn {body, pats, resultType} =>
235 val (body, u) = loopExp (body, down)
237 visits (pats, fn p =>
240 visitTyOpt (resultType, down)
244 resultType = resultType},
245 combineUp (u, combineUp (u', u'')))
250 val (tyvars, u) = finish u
252 (doit (Fun {tyvars = tyvars, fbs = fbs}), u)
255 do2 (loopDec (d, down), loopDec (d', down), Local)
257 | Overload (i, x, tyvars, ty, ys) =>
259 val (down, finish) = bindFunVal (down, tyvars, Dec.region d)
260 val up = visitTy (ty, down)
261 val (tyvars, up) = finish up
263 (doit (Overload (i, x, tyvars, ty, ys)), up)
265 | SeqDec ds => doVec (ds, SeqDec)
268 val u = visitTypBind (tb, down)
272 | Val {rvbs, tyvars, vbs} =>
274 val (down, finish) = bindFunVal (down, tyvars, Dec.region d)
276 loops (rvbs, fn {match, pat} =>
278 val (match, u) = loopMatch (match, down)
279 val u' = visitPat (pat, down)
286 loops (vbs, fn {exp, pat} =>
288 val (exp, u) = loopExp (exp, down)
289 val u' = visitPat (pat, down)
295 val (tyvars, u) = finish (combineUp (u, u'))
297 (doit (Val {rvbs = rvbs,
303 and loopExp (e: Exp.t, d: 'down): Exp.t * 'up =
305 val loopMatch = fn m => loopMatch (m, d)
306 fun loop (e: Exp.t): Exp.t * 'up =
308 fun empty () = (e, initUp)
309 val region = Exp.region e
310 fun doit n = Exp.makeRegion (n, region)
311 datatype z = datatype Exp.node
312 fun do1 ((a, u), f) = (doit (f a), u)
313 fun do2 ((a1, u1), (a2, u2), f) =
314 (doit (f (a1, a2)), combineUp (u1, u2))
315 fun do3 ((a1, u1), (a2, u2), (a3, u3), f) =
316 (doit (f (a1, a2, a3)), combineUp (u1, combineUp (u2, u3)))
317 fun doVec (es: Exp.t vector, f: Exp.t vector -> Exp.node)
320 val (es, u) = loops (es, loop)
326 Andalso (e1, e2) => do2 (loop e1, loop e2, Andalso)
327 | App (e1, e2) => do2 (loop e1, loop e2, App)
328 | Case (e, m) => do2 (loop e, loopMatch m, Case)
329 | Const _ => empty ()
330 | Constraint (e, t) =>
333 val u' = visitTy (t, d)
335 (doit (Constraint (e, t)),
338 | FlatApp es => doVec (es, FlatApp)
339 | Fn m => do1 (loopMatch m, Fn)
340 | Handle (e, m) => do2 (loop e, loopMatch m, Handle)
341 | If (e1, e2, e3) => do3 (loop e1, loop e2, loop e3, If)
342 | Let (dec, e) => do2 (loopDec (dec, d), loop e, Let)
343 | List ts => doVec (ts, List)
344 | Orelse (e1, e2) => do2 (loop e1, loop e2, Orelse)
345 | Paren e => do1 (loop e, Paren)
346 | Prim kind => (e, visitPrimKind (kind, d))
347 | Raise exn => do1 (loop exn, Raise)
353 loops (res, fn (r, e) =>
354 let val (e', u) = loop e
360 | Selector _ => empty ()
361 | Seq es => doVec (es, Seq)
363 | Vector vs => doVec (vs, Vector)
364 | While {expr, test} =>
365 do2 (loop expr, loop test, fn (expr, test) =>
366 While {expr = expr, test = test})
371 and loopMatch (m, d) =
373 val (Match.T rules, region) = Match.dest m
375 loops (rules, fn (p, e) =>
377 val u = visitPat (p, d)
378 val (e, u') = loopExp (e, d)
380 ((p, e), combineUp (u, u'))
383 (Match.makeRegion (Match.T rules, region),
387 loopDec (d, initDown)
390 fun scope (dec: Dec.t): Dec.t =
392 fun bindFunVal ((), tyvars, regionDec) =
394 fun finish {free, mayNotBind} =
396 val bound = Tyvars.+ (free, Tyvars.fromVector tyvars)
400 not (Tyvars.contains (bound, a))
407 seq [str "type variable scoped at an outer declaration: ",
409 seq [str "scoped at: ", Region.layout regionDec])
413 val bound = Vector.fromList (Tyvars.toList bound)
416 {free = Tyvars.empty,
417 mayNotBind = List.append (Vector.toList tyvars, mayNotBind)})
422 fun bindType ((), tyvars) =
424 fun finish {free, mayNotBind = _} =
425 {free = Tyvars.- (free, Tyvars.fromVector tyvars),
431 {free = Tyvars.singleton a,
433 fun combineUp ({free = f, mayNotBind = m}, {free = f', mayNotBind = m'}) =
434 {free = Tyvars.+ (f, f'),
435 mayNotBind = List.append (m, m')}
437 processDec (dec, {bindFunVal = bindFunVal,
439 combineUp = combineUp,
441 initUp = {free = Tyvars.empty, mayNotBind = []},
444 (* Walk down and bind a tyvar as soon as you see it, removing
445 * all lower binding occurrences of the tyvar.
447 fun bindFunVal (bound, tyvars: Tyvar.t vector, _) =
452 not (Tyvars.contains (bound, a)))
454 Tyvars.+ (bound, Tyvars.fromVector tyvars)
456 (bound, fn () => (tyvars, ()))
458 fun bindType (bound, tyvars) =
460 val bound = Tyvars.+ (bound, Tyvars.fromVector tyvars)
464 fun tyvar (_, _) = ()
466 processDec (dec, {bindFunVal = bindFunVal,
468 combineUp = fn ((), ()) => (),
469 initDown = Tyvars.empty,
476 val scope = Trace.trace ("Scope.scope", Dec.layout, Dec.layout) scope