Mercurial > urweb

comparison src/checknest.sml @ 879:b2a175a0f2ef

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Demo working with MySQL
author Adam Chlipala <adamc@hcoop.net>
date Thu, 16 Jul 2009 18:10:29 -0400
parents
children 217eb87dde31
comparison
equal deleted inserted replaced
878:a8952047e1d3 879:b2a175a0f2ef
1 (* Copyright (c) 2009, 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 Checknest :> CHECKNEST = struct
29
30 open Cjr
31
32 structure IS = IntBinarySet
33 structure IM = IntBinaryMap
34
35 fun expUses globals =
36 let
37 fun eu (e, _) =
38 case e of
39 EPrim _ => IS.empty
40 | ERel _ => IS.empty
41 | ENamed n => Option.getOpt (IM.find (globals, n), IS.empty)
42 | ECon (_, _, NONE) => IS.empty
43 | ECon (_, _, SOME e) => eu e
44 | ENone _ => IS.empty
45 | ESome (_, e) => eu e
46 | EFfi _ => IS.empty
47 | EFfiApp (_, _, es) => foldl IS.union IS.empty (map eu es)
48 | EApp (e, es) => foldl IS.union (eu e) (map eu es)
49
50 | EUnop (_, e) => eu e
51 | EBinop (_, e1, e2) => IS.union (eu e1, eu e2)
52
53 | ERecord (_, xes) => foldl (fn ((_, e), s) => IS.union (eu e, s)) IS.empty xes
54 | EField (e, _) => eu e
55
56 | ECase (e, pes, _) => foldl (fn ((_, e), s) => IS.union (eu e, s)) (eu e) pes
57
58 | EError (e, _) => eu e
59 | EReturnBlob {blob, mimeType, ...} => IS.union (eu blob, eu mimeType)
60
61 | EWrite e => eu e
62 | ESeq (e1, e2) => IS.union (eu e1, eu e2)
63 | ELet (_, _, e1, e2) => IS.union (eu e1, eu e2)
64
65 | EQuery {query, body, initial, prepared, ...} =>
66 let
67 val s = IS.union (eu query, IS.union (eu body, eu initial))
68 in
69 case prepared of
70 SOME {id, ...} => IS.add (s, id)
71 | _ => s
72 end
73 | EDml {dml, prepared, ...} =>
74 let
75 val s = eu dml
76 in
77 case prepared of
78 SOME {id, ...} => IS.add (s, id)
79 | _ => s
80 end
81 | ENextval {seq, prepared, ...} =>
82 let
83 val s = eu seq
84 in
85 case prepared of
86 SOME {id, ...} => IS.add (s, id)
87 | _ => s
88 end
89
90 | EUnurlify (e, _) => eu e
91 in
92 eu
93 end
94
95 fun annotateExp globals =
96 let
97 fun ae (e as (_, loc)) =
98 case #1 e of
99 EPrim _ => e
100 | ERel _ => e
101 | ENamed n => e
102 | ECon (_, _, NONE) => e
103 | ECon (dk, pc, SOME e) => (ECon (dk, pc, SOME (ae e)), loc)
104 | ENone _ => e
105 | ESome (t, e) => (ESome (t, ae e), loc)
106 | EFfi _ => e
107 | EFfiApp (m, f, es) => (EFfiApp (m, f, map ae es), loc)
108 | EApp (e, es) => (EApp (ae e, map ae es), loc)
109
110 | EUnop (uo, e) => (EUnop (uo, ae e), loc)
111 | EBinop (bo, e1, e2) => (EBinop (bo, ae e1, ae e2), loc)
112
113 | ERecord (n, xes) => (ERecord (n, map (fn (x, e) => (x, ae e)) xes), loc)
114 | EField (e, f) => (EField (ae e, f), loc)
115
116 | ECase (e, pes, ts) => (ECase (ae e, map (fn (p, e) => (p, ae e)) pes, ts), loc)
117
118 | EError (e, t) => (EError (ae e, t), loc)
119 | EReturnBlob {blob, mimeType, t} => (EReturnBlob {blob = ae blob, mimeType = ae mimeType, t = t}, loc)
120
121 | EWrite e => (EWrite (ae e), loc)
122 | ESeq (e1, e2) => (ESeq (ae e1, ae e2), loc)
123 | ELet (x, t, e1, e2) => (ELet (x, t, ae e1, ae e2), loc)
124
125 | EQuery {exps, tables, rnum, state, query, body, initial, prepared} =>
126 (EQuery {exps = exps,
127 tables = tables,
128 rnum = rnum,
129 state = state,
130 query = ae query,
131 body = ae body,
132 initial = ae initial,
133 prepared = case prepared of
134 NONE => NONE
135 | SOME {id, query, ...} => SOME {id = id, query = query,
136 nested = IS.member (expUses globals body, id)}},
137 loc)
138 | EDml {dml, prepared} =>
139 (EDml {dml = ae dml,
140 prepared = prepared}, loc)
141
142 | ENextval {seq, prepared} =>
143 (ENextval {seq = ae seq,
144 prepared = prepared}, loc)
145
146 | EUnurlify (e, t) => (EUnurlify (ae e, t), loc)
147 in
148 ae
149 end
150
151 fun annotate (ds, syms) =
152 let
153 val globals =
154 foldl (fn ((d, _), globals) =>
155 case d of
156 DVal (_, n, _, e) => IM.insert (globals, n, expUses globals e)
157 | DFun (_, n, _, _, e) => IM.insert (globals, n, expUses globals e)
158 | DFunRec fs =>
159 let
160 val s = foldl (fn ((_, _, _, _, e), s) => IS.union (expUses globals e, s)) IS.empty fs
161 in
162 foldl (fn ((_, n, _, _, _), globals) => IM.insert (globals, n, s)) globals fs
163 end
164 | _ => globals) IM.empty ds
165
166 val ds =
167 map (fn d as (_, loc) =>
168 case #1 d of
169 DVal (x, n, t, e) => (DVal (x, n, t, annotateExp globals e), loc)
170 | DFun (x, n, ts, t, e) => (DFun (x, n, ts, t, annotateExp globals e), loc)
171 | DFunRec fs => (DFunRec
172 (map (fn (x, n, ts, t, e) => (x, n, ts, t, annotateExp globals e)) fs), loc)
173 | _ => d) ds
174 in
175 (ds, syms)
176 end
177
178 end