Mercurial > urweb

comparison src/flat_util.sml @ 26:4ab19c19665f

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Closure conversion
author Adam Chlipala <adamc@hcoop.net>
date Tue, 10 Jun 2008 15:56:33 -0400
parents
children 104d43266b33
comparison
equal deleted inserted replaced
25:0a762c73824d 26:4ab19c19665f
1 (* Copyright (c) 2008, Adam Chlipala
2 * All rights reserved.
3 *
4 * Redistribution and use in source and binary forms, with or without
5 * modification, are permitted provided that the following conditions are met:
6 *
7 * - Redistributions of source code must retain the above copyright notice,
8 * this list of conditions and the following disclaimer.
9 * - Redistributions in binary form must reproduce the above copyright notice,
10 * this list of conditions and the following disclaimer in the documentation
11 * and/or other materials provided with the distribution.
12 * - The names of contributors may not be used to endorse or promote products
13 * derived from this software without specific prior written permission.
14 *
15 * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
16 * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
17 * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
18 * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
19 * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
20 * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
21 * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
22 * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
23 * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
24 * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
25 * POSSIBILITY OF SUCH DAMAGE.
26 *)
27
28 structure FlatUtil :> FLAT_UTIL = struct
29
30 open Flat
31
32 structure S = Search
33
34 structure Typ = struct
35
36 fun mapfold fc =
37 let
38 fun mft c acc =
39 S.bindP (mft' c acc, fc)
40
41 and mft' (cAll as (c, loc)) =
42 case c of
43 TFun (t1, t2) =>
44 S.bind2 (mft t1,
45 fn t1' =>
46 S.map2 (mft t2,
47 fn t2' =>
48 (TFun (t1', t2'), loc)))
49 | TCode (t1, t2) =>
50 S.bind2 (mft t1,
51 fn t1' =>
52 S.map2 (mft t2,
53 fn t2' =>
54 (TCode (t1', t2'), loc)))
55 | TRecord xts =>
56 S.map2 (ListUtil.mapfold (fn (x, t) =>
57 S.map2 (mft t,
58 fn t' =>
59 (x, t')))
60 xts,
61 fn xts' => (TRecord xts', loc))
62 | TNamed _ => S.return2 cAll
63 in
64 mft
65 end
66
67 fun map typ c =
68 case mapfold (fn c => fn () => S.Continue (typ c, ())) c () of
69 S.Return () => raise Fail "Flat_util.Typ.map"
70 | S.Continue (c, ()) => c
71
72 fun fold typ s c =
73 case mapfold (fn c => fn s => S.Continue (c, typ (c, s))) c s of
74 S.Continue (_, s) => s
75 | S.Return _ => raise Fail "FlatUtil.Typ.fold: Impossible"
76
77 fun exists typ k =
78 case mapfold (fn c => fn () =>
79 if typ c then
80 S.Return ()
81 else
82 S.Continue (c, ())) k () of
83 S.Return _ => true
84 | S.Continue _ => false
85
86 end
87
88 structure Exp = struct
89
90 datatype binder =
91 NamedT of string * int * typ option
92 | RelE of string * typ
93 | NamedE of string * int * typ * exp option
94
95 fun mapfoldB {typ = fc, exp = fe, bind} =
96 let
97 val mft = Typ.mapfold fc
98
99 fun mfe ctx e acc =
100 S.bindP (mfe' ctx e acc, fe ctx)
101
102 and mfe' ctx (eAll as (e, loc)) =
103 case e of
104 EPrim _ => S.return2 eAll
105 | ERel _ => S.return2 eAll
106 | ENamed _ => S.return2 eAll
107 | ECode _ => S.return2 eAll
108 | EApp (e1, e2) =>
109 S.bind2 (mfe ctx e1,
110 fn e1' =>
111 S.map2 (mfe ctx e2,
112 fn e2' =>
113 (EApp (e1', e2'), loc)))
114
115 | ERecord xes =>
116 S.map2 (ListUtil.mapfold (fn (x, e) =>
117 S.map2 (mfe ctx e,
118 fn e' =>
119 (x, e')))
120 xes,
121 fn xes' =>
122 (ERecord xes', loc))
123 | EField (e, x) =>
124 S.map2 (mfe ctx e,
125 fn e' =>
126 (EField (e', x), loc))
127
128 | ELet (xes, e) =>
129 S.bind2 (ListUtil.mapfold (fn (x, e) =>
130 S.map2 (mfe ctx e,
131 fn e' =>
132 (x, e')))
133 xes,
134 fn xes' =>
135 S.map2 (mfe ctx e,
136 fn e' =>
137 (ELet (xes', e'), loc)))
138 in
139 mfe
140 end
141
142 fun mapfold {typ = fc, exp = fe} =
143 mapfoldB {typ = fc,
144 exp = fn () => fe,
145 bind = fn ((), _) => ()} ()
146
147 fun mapB {typ, exp, bind} ctx e =
148 case mapfoldB {typ = fn c => fn () => S.Continue (typ c, ()),
149 exp = fn ctx => fn e => fn () => S.Continue (exp ctx e, ()),
150 bind = bind} ctx e () of
151 S.Continue (e, ()) => e
152 | S.Return _ => raise Fail "FlatUtil.Exp.mapB: Impossible"
153
154 fun map {typ, exp} e =
155 case mapfold {typ = fn c => fn () => S.Continue (typ c, ()),
156 exp = fn e => fn () => S.Continue (exp e, ())} e () of
157 S.Return () => raise Fail "Flat_util.Exp.map"
158 | S.Continue (e, ()) => e
159
160 fun fold {typ, exp} s e =
161 case mapfold {typ = fn c => fn s => S.Continue (c, typ (c, s)),
162 exp = fn e => fn s => S.Continue (e, exp (e, s))} e s of
163 S.Continue (_, s) => s
164 | S.Return _ => raise Fail "FlatUtil.Exp.fold: Impossible"
165
166 fun exists {typ, exp} k =
167 case mapfold {typ = fn c => fn () =>
168 if typ c then
169 S.Return ()
170 else
171 S.Continue (c, ()),
172 exp = fn e => fn () =>
173 if exp e then
174 S.Return ()
175 else
176 S.Continue (e, ())} k () of
177 S.Return _ => true
178 | S.Continue _ => false
179
180 end
181
182 structure Decl = struct
183
184 datatype binder = datatype Exp.binder
185
186 fun mapfoldB {typ = fc, exp = fe, decl = fd, bind} =
187 let
188 val mft = Typ.mapfold fc
189
190 val mfe = Exp.mapfoldB {typ = fc, exp = fe, bind = bind}
191
192 fun mfd ctx d acc =
193 S.bindP (mfd' ctx d acc, fd ctx)
194
195 and mfd' ctx (dAll as (d, loc)) =
196 case d of
197 DVal (x, n, t, e) =>
198 S.bind2 (mft t,
199 fn t' =>
200 S.map2 (mfe ctx e,
201 fn e' =>
202 (DVal (x, n, t', e'), loc)))
203 | DFun (n, x, dom, ran, e) =>
204 S.bind2 (mft dom,
205 fn dom' =>
206 S.bind2 (mft ran,
207 fn ran' =>
208 S.map2 (mfe ctx e,
209 fn e' =>
210 (DFun (n, x, dom', ran', e'), loc))))
211 in
212 mfd
213 end
214
215 fun mapfold {typ = fc, exp = fe, decl = fd} =
216 mapfoldB {typ = fc,
217 exp = fn () => fe,
218 decl = fn () => fd,
219 bind = fn ((), _) => ()} ()
220
221 fun fold {typ, exp, decl} s d =
222 case mapfold {typ = fn c => fn s => S.Continue (c, typ (c, s)),
223 exp = fn e => fn s => S.Continue (e, exp (e, s)),
224 decl = fn d => fn s => S.Continue (d, decl (d, s))} d s of
225 S.Continue (_, s) => s
226 | S.Return _ => raise Fail "FlatUtil.Decl.fold: Impossible"
227
228 end
229
230 structure File = struct
231
232 datatype binder =
233 NamedT of string * int * typ option
234 | RelE of string * typ
235 | NamedE of string * int * typ * exp option
236 | F of int * string * Flat.typ * Flat.typ * Flat.exp
237
238 fun mapfoldB (all as {bind, ...}) =
239 let
240 val mfd = Decl.mapfoldB all
241
242 fun mff ctx ds =
243 case ds of
244 nil => S.return2 nil
245 | d :: ds' =>
246 S.bind2 (mfd ctx d,
247 fn d' =>
248 let
249 val b =
250 case #1 d' of
251 DVal (x, n, t, e) => NamedE (x, n, t, SOME e)
252 | DFun v => F v
253 val ctx' = bind (ctx, b)
254 in
255 S.map2 (mff ctx' ds',
256 fn ds' =>
257 d' :: ds')
258 end)
259 in
260 mff
261 end
262
263 fun mapfold {typ = fc, exp = fe, decl = fd} =
264 mapfoldB {typ = fc,
265 exp = fn () => fe,
266 decl = fn () => fd,
267 bind = fn ((), _) => ()} ()
268
269 fun mapB {typ, exp, decl, bind} ctx ds =
270 case mapfoldB {typ = fn c => fn () => S.Continue (typ c, ()),
271 exp = fn ctx => fn e => fn () => S.Continue (exp ctx e, ()),
272 decl = fn ctx => fn d => fn () => S.Continue (decl ctx d, ()),
273 bind = bind} ctx ds () of
274 S.Continue (ds, ()) => ds
275 | S.Return _ => raise Fail "FlatUtil.File.mapB: Impossible"
276
277 fun fold {typ, exp, decl} s d =
278 case mapfold {typ = fn c => fn s => S.Continue (c, typ (c, s)),
279 exp = fn e => fn s => S.Continue (e, exp (e, s)),
280 decl = fn d => fn s => S.Continue (d, decl (d, s))} d s of
281 S.Continue (_, s) => s
282 | S.Return _ => raise Fail "FlatUtil.File.fold: Impossible"
283
284 end
285
286 end