adamc@282
|
1 (* Copyright (c) 2008, Adam Chlipala
|
adamc@282
|
2 * All rights reserved.
|
adamc@282
|
3 *
|
adamc@282
|
4 * Redistribution and use in source and binary forms, with or without
|
adamc@282
|
5 * modification, are permitted provided that the following conditions are met:
|
adamc@282
|
6 *
|
adamc@282
|
7 * - Redistributions of source code must retain the above copyright notice,
|
adamc@282
|
8 * this list of conditions and the following disclaimer.
|
adamc@282
|
9 * - Redistributions in binary form must reproduce the above copyright notice,
|
adamc@282
|
10 * this list of conditions and the following disclaimer in the documentation
|
adamc@282
|
11 * and/or other materials provided with the distribution.
|
adamc@282
|
12 * - The names of contributors may not be used to endorse or promote products
|
adamc@282
|
13 * derived from this software without specific prior written permission.
|
adamc@282
|
14 *
|
adamc@282
|
15 * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
|
adamc@282
|
16 * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
|
adamc@282
|
17 * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
|
adamc@282
|
18 * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
|
adamc@282
|
19 * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
|
adamc@282
|
20 * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
|
adamc@282
|
21 * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
|
adamc@282
|
22 * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
|
adamc@282
|
23 * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
|
adamc@282
|
24 * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
|
adamc@282
|
25 * POSSIBILITY OF SUCH DAMAGE.
|
adamc@282
|
26 *)
|
adamc@282
|
27
|
adamc@282
|
28 structure Prepare :> PREPARE = struct
|
adamc@282
|
29
|
adamc@282
|
30 open Cjr
|
adamc@282
|
31
|
adamc@282
|
32 fun prepString (e, ss, n) =
|
adamc@282
|
33 case #1 e of
|
adamc@282
|
34 EPrim (Prim.String s) =>
|
adamc@282
|
35 SOME (s :: ss, n)
|
adamc@282
|
36 | EFfiApp ("Basis", "strcat", [e1, e2]) =>
|
adamc@282
|
37 (case prepString (e1, ss, n) of
|
adamc@282
|
38 NONE => NONE
|
adamc@282
|
39 | SOME (ss, n) => prepString (e2, ss, n))
|
adamc@282
|
40 | EFfiApp ("Basis", "sqlifyInt", [e]) =>
|
adamc@282
|
41 SOME ("$" ^ Int.toString (n + 1) ^ "::int8" :: ss, n + 1)
|
adamc@282
|
42 | EFfiApp ("Basis", "sqlifyFloat", [e]) =>
|
adamc@282
|
43 SOME ("$" ^ Int.toString (n + 1) ^ "::float8" :: ss, n + 1)
|
adamc@282
|
44 | EFfiApp ("Basis", "sqlifyString", [e]) =>
|
adamc@282
|
45 SOME ("$" ^ Int.toString (n + 1) ^ "::text" :: ss, n + 1)
|
adamc@282
|
46 | EFfiApp ("Basis", "sqlifyBool", [e]) =>
|
adamc@282
|
47 SOME ("$" ^ Int.toString (n + 1) ^ "::bool" :: ss, n + 1)
|
adamc@322
|
48 | ECase (e,
|
adamc@322
|
49 [((PCon (_, PConFfi {mod = "Basis", con = "True", ...}, _), _),
|
adamc@322
|
50 (EPrim (Prim.String "TRUE"), _)),
|
adamc@322
|
51 ((PCon (_, PConFfi {mod = "Basis", con = "False", ...}, _), _),
|
adamc@322
|
52 (EPrim (Prim.String "FALSE"), _))],
|
adamc@322
|
53 _) => SOME ("$" ^ Int.toString (n + 1) ^ "::bool" :: ss, n + 1)
|
adamc@282
|
54
|
adamc@282
|
55 | _ => NONE
|
adamc@282
|
56
|
adamc@282
|
57 fun prepExp (e as (_, loc), sns) =
|
adamc@282
|
58 case #1 e of
|
adamc@282
|
59 EPrim _ => (e, sns)
|
adamc@282
|
60 | ERel _ => (e, sns)
|
adamc@282
|
61 | ENamed _ => (e, sns)
|
adamc@282
|
62 | ECon (_, _, NONE) => (e, sns)
|
adamc@282
|
63 | ECon (dk, pc, SOME e) =>
|
adamc@282
|
64 let
|
adamc@282
|
65 val (e, sns) = prepExp (e, sns)
|
adamc@282
|
66 in
|
adamc@282
|
67 ((ECon (dk, pc, SOME e), loc), sns)
|
adamc@282
|
68 end
|
adamc@297
|
69 | ENone t => (e, sns)
|
adamc@291
|
70 | ESome (t, e) =>
|
adamc@291
|
71 let
|
adamc@291
|
72 val (e, sns) = prepExp (e, sns)
|
adamc@291
|
73 in
|
adamc@291
|
74 ((ESome (t, e), loc), sns)
|
adamc@291
|
75 end
|
adamc@282
|
76 | EFfi _ => (e, sns)
|
adamc@282
|
77 | EFfiApp (m, x, es) =>
|
adamc@282
|
78 let
|
adamc@282
|
79 val (es, sns) = ListUtil.foldlMap prepExp sns es
|
adamc@282
|
80 in
|
adamc@282
|
81 ((EFfiApp (m, x, es), loc), sns)
|
adamc@282
|
82 end
|
adamc@316
|
83 | EApp (e1, es) =>
|
adamc@282
|
84 let
|
adamc@282
|
85 val (e1, sns) = prepExp (e1, sns)
|
adamc@316
|
86 val (es, sns) = ListUtil.foldlMap prepExp sns es
|
adamc@282
|
87 in
|
adamc@316
|
88 ((EApp (e1, es), loc), sns)
|
adamc@282
|
89 end
|
adamc@282
|
90
|
adamc@387
|
91 | EUnop (s, e1) =>
|
adamc@387
|
92 let
|
adamc@387
|
93 val (e1, sns) = prepExp (e1, sns)
|
adamc@387
|
94 in
|
adamc@387
|
95 ((EUnop (s, e1), loc), sns)
|
adamc@387
|
96 end
|
adamc@387
|
97 | EBinop (s, e1, e2) =>
|
adamc@387
|
98 let
|
adamc@387
|
99 val (e1, sns) = prepExp (e1, sns)
|
adamc@387
|
100 val (e2, sns) = prepExp (e2, sns)
|
adamc@387
|
101 in
|
adamc@387
|
102 ((EBinop (s, e1, e2), loc), sns)
|
adamc@387
|
103 end
|
adamc@387
|
104
|
adamc@282
|
105 | ERecord (rn, xes) =>
|
adamc@282
|
106 let
|
adamc@282
|
107 val (xes, sns) = ListUtil.foldlMap (fn ((x, e), sns) =>
|
adamc@282
|
108 let
|
adamc@282
|
109 val (e, sns) = prepExp (e, sns)
|
adamc@282
|
110 in
|
adamc@282
|
111 ((x, e), sns)
|
adamc@282
|
112 end) sns xes
|
adamc@282
|
113 in
|
adamc@282
|
114 ((ERecord (rn, xes), loc), sns)
|
adamc@282
|
115 end
|
adamc@282
|
116 | EField (e, s) =>
|
adamc@282
|
117 let
|
adamc@282
|
118 val (e, sns) = prepExp (e, sns)
|
adamc@282
|
119 in
|
adamc@282
|
120 ((EField (e, s), loc), sns)
|
adamc@282
|
121 end
|
adamc@282
|
122
|
adamc@282
|
123 | ECase (e, pes, ts) =>
|
adamc@282
|
124 let
|
adamc@282
|
125 val (e, sns) = prepExp (e, sns)
|
adamc@282
|
126 val (pes, sns) = ListUtil.foldlMap (fn ((p, e), sns) =>
|
adamc@282
|
127 let
|
adamc@282
|
128 val (e, sns) = prepExp (e, sns)
|
adamc@282
|
129 in
|
adamc@282
|
130 ((p, e), sns)
|
adamc@282
|
131 end) sns pes
|
adamc@282
|
132 in
|
adamc@282
|
133 ((ECase (e, pes, ts), loc), sns)
|
adamc@282
|
134 end
|
adamc@282
|
135
|
adamc@283
|
136 | EError (e, t) =>
|
adamc@283
|
137 let
|
adamc@283
|
138 val (e, sns) = prepExp (e, sns)
|
adamc@283
|
139 in
|
adamc@283
|
140 ((EError (e, t), loc), sns)
|
adamc@283
|
141 end
|
adamc@283
|
142
|
adamc@282
|
143 | EWrite e =>
|
adamc@282
|
144 let
|
adamc@282
|
145 val (e, sns) = prepExp (e, sns)
|
adamc@282
|
146 in
|
adamc@282
|
147 ((EWrite e, loc), sns)
|
adamc@282
|
148 end
|
adamc@282
|
149 | ESeq (e1, e2) =>
|
adamc@282
|
150 let
|
adamc@282
|
151 val (e1, sns) = prepExp (e1, sns)
|
adamc@282
|
152 val (e2, sns) = prepExp (e2, sns)
|
adamc@282
|
153 in
|
adamc@282
|
154 ((ESeq (e1, e2), loc), sns)
|
adamc@282
|
155 end
|
adamc@282
|
156 | ELet (x, t, e1, e2) =>
|
adamc@282
|
157 let
|
adamc@282
|
158 val (e1, sns) = prepExp (e1, sns)
|
adamc@282
|
159 val (e2, sns) = prepExp (e2, sns)
|
adamc@282
|
160 in
|
adamc@282
|
161 ((ELet (x, t, e1, e2), loc), sns)
|
adamc@282
|
162 end
|
adamc@282
|
163
|
adamc@282
|
164 | EQuery {exps, tables, rnum, state, query, body, initial, ...} =>
|
adamc@282
|
165 (case prepString (query, [], 0) of
|
adamc@282
|
166 NONE => (e, sns)
|
adamc@282
|
167 | SOME (ss, n) =>
|
adamc@282
|
168 ((EQuery {exps = exps, tables = tables, rnum = rnum,
|
adamc@282
|
169 state = state, query = query, body = body,
|
adamc@282
|
170 initial = initial, prepared = SOME (#2 sns)}, loc),
|
adamc@282
|
171 ((String.concat (rev ss), n) :: #1 sns, #2 sns + 1)))
|
adamc@282
|
172
|
adamc@307
|
173 | EDml {dml, ...} =>
|
adamc@307
|
174 (case prepString (dml, [], 0) of
|
adamc@307
|
175 NONE => (e, sns)
|
adamc@307
|
176 | SOME (ss, n) =>
|
adamc@307
|
177 ((EDml {dml = dml, prepared = SOME (#2 sns)}, loc),
|
adamc@307
|
178 ((String.concat (rev ss), n) :: #1 sns, #2 sns + 1)))
|
adamc@307
|
179
|
adamc@338
|
180 | ENextval {seq, ...} =>
|
adamc@338
|
181 let
|
adamc@338
|
182 val s = (EFfiApp ("Basis", "strcat", [seq, (EPrim (Prim.String "')"), loc)]), loc)
|
adamc@338
|
183 val s = (EFfiApp ("Basis", "strcat", [(EPrim (Prim.String "SELECT NEXTVAL('"), loc), s]), loc)
|
adamc@338
|
184 in
|
adamc@338
|
185 case prepString (s, [], 0) of
|
adamc@338
|
186 NONE => (e, sns)
|
adamc@338
|
187 | SOME (ss, n) =>
|
adamc@338
|
188 ((ENextval {seq = seq, prepared = SOME (#2 sns)}, loc),
|
adamc@338
|
189 ((String.concat (rev ss), n) :: #1 sns, #2 sns + 1))
|
adamc@338
|
190 end
|
adamc@338
|
191
|
adamc@282
|
192 fun prepDecl (d as (_, loc), sns) =
|
adamc@282
|
193 case #1 d of
|
adamc@282
|
194 DStruct _ => (d, sns)
|
adamc@282
|
195 | DDatatype _ => (d, sns)
|
adamc@282
|
196 | DDatatypeForward _ => (d, sns)
|
adamc@282
|
197 | DVal (x, n, t, e) =>
|
adamc@282
|
198 let
|
adamc@282
|
199 val (e, sns) = prepExp (e, sns)
|
adamc@282
|
200 in
|
adamc@282
|
201 ((DVal (x, n, t, e), loc), sns)
|
adamc@282
|
202 end
|
adamc@282
|
203 | DFun (x, n, xts, t, e) =>
|
adamc@282
|
204 let
|
adamc@282
|
205 val (e, sns) = prepExp (e, sns)
|
adamc@282
|
206 in
|
adamc@282
|
207 ((DFun (x, n, xts, t, e), loc), sns)
|
adamc@282
|
208 end
|
adamc@282
|
209 | DFunRec fs =>
|
adamc@282
|
210 let
|
adamc@282
|
211 val (fs, sns) = ListUtil.foldlMap (fn ((x, n, xts, t, e), sns) =>
|
adamc@282
|
212 let
|
adamc@282
|
213 val (e, sns) = prepExp (e, sns)
|
adamc@282
|
214 in
|
adamc@282
|
215 ((x, n, xts, t, e), sns)
|
adamc@282
|
216 end) sns fs
|
adamc@282
|
217 in
|
adamc@282
|
218 ((DFunRec fs, loc), sns)
|
adamc@282
|
219 end
|
adamc@282
|
220
|
adamc@282
|
221 | DTable _ => (d, sns)
|
adamc@338
|
222 | DSequence _ => (d, sns)
|
adamc@282
|
223 | DDatabase _ => (d, sns)
|
adamc@282
|
224 | DPreparedStatements _ => (d, sns)
|
adamc@282
|
225
|
adamc@282
|
226 fun prepare (ds, ps) =
|
adamc@282
|
227 let
|
adamc@282
|
228 val (ds, (sns, _)) = ListUtil.foldlMap prepDecl ([], 0) ds
|
adamc@282
|
229 in
|
adamc@282
|
230 ((DPreparedStatements (rev sns), ErrorMsg.dummySpan) :: ds, ps)
|
adamc@282
|
231 end
|
adamc@282
|
232
|
adamc@282
|
233 end
|
adamc@282
|
234
|