adamc@29
|
1 (* Copyright (c) 2008, Adam Chlipala
|
adamc@29
|
2 * All rights reserved.
|
adamc@29
|
3 *
|
adamc@29
|
4 * Redistribution and use in source and binary forms, with or without
|
adamc@29
|
5 * modification, are permitted provided that the following conditions are met:
|
adamc@29
|
6 *
|
adamc@29
|
7 * - Redistributions of source code must retain the above copyright notice,
|
adamc@29
|
8 * this list of conditions and the following disclaimer.
|
adamc@29
|
9 * - Redistributions in binary form must reproduce the above copyright notice,
|
adamc@29
|
10 * this list of conditions and the following disclaimer in the documentation
|
adamc@29
|
11 * and/or other materials provided with the distribution.
|
adamc@29
|
12 * - The names of contributors may not be used to endorse or promote products
|
adamc@29
|
13 * derived from this software without specific prior written permission.
|
adamc@29
|
14 *
|
adamc@29
|
15 * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
|
adamc@29
|
16 * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
|
adamc@29
|
17 * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
|
adamc@29
|
18 * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
|
adamc@29
|
19 * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
|
adamc@29
|
20 * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
|
adamc@29
|
21 * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
|
adamc@29
|
22 * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
|
adamc@29
|
23 * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
|
adamc@29
|
24 * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
|
adamc@29
|
25 * POSSIBILITY OF SUCH DAMAGE.
|
adamc@29
|
26 *)
|
adamc@29
|
27
|
adamc@29
|
28 (* Pretty-printing C jr. *)
|
adamc@29
|
29
|
adamc@29
|
30 structure CjrPrint :> CJR_PRINT = struct
|
adamc@29
|
31
|
adamc@29
|
32 open Print.PD
|
adamc@29
|
33 open Print
|
adamc@29
|
34
|
adamc@29
|
35 open Cjr
|
adamc@29
|
36
|
adamc@269
|
37 val dummyt = (TRecord 0, ErrorMsg.dummySpan)
|
adamc@269
|
38
|
adamc@29
|
39 structure E = CjrEnv
|
adamc@29
|
40 structure EM = ErrorMsg
|
adamc@29
|
41
|
adamc@144
|
42 structure SK = struct
|
adamc@144
|
43 type ord_key = string
|
adamc@144
|
44 val compare = String.compare
|
adamc@144
|
45 end
|
adamc@144
|
46
|
adamc@144
|
47 structure SS = BinarySetFn(SK)
|
adamc@144
|
48 structure SM = BinaryMapFn(SK)
|
adamc@144
|
49 structure IS = IntBinarySet
|
adamc@144
|
50
|
adamc@144
|
51 structure CM = BinaryMapFn(struct
|
adamc@144
|
52 type ord_key = char
|
adamc@144
|
53 val compare = Char.compare
|
adamc@144
|
54 end)
|
adamc@144
|
55
|
adamc@29
|
56 val debug = ref false
|
adamc@29
|
57
|
adamc@196
|
58 val dummyTyp = (TDatatype (Enum, 0, ref []), ErrorMsg.dummySpan)
|
adamc@29
|
59
|
adamc@29
|
60 fun p_typ' par env (t, loc) =
|
adamc@29
|
61 case t of
|
adamc@269
|
62 TFun (t1, t2) => parenIf par (box [p_typ' true env t2,
|
adamc@109
|
63 space,
|
adamc@109
|
64 string "(*)",
|
adamc@109
|
65 space,
|
adamc@109
|
66 string "(",
|
adamc@109
|
67 p_typ env t1,
|
adamc@109
|
68 string ")"])
|
adamc@29
|
69 | TRecord i => box [string "struct",
|
adamc@29
|
70 space,
|
adamc@311
|
71 string "__uws_",
|
adamc@29
|
72 string (Int.toString i)]
|
adamc@188
|
73 | TDatatype (Enum, n, _) =>
|
adamc@188
|
74 (box [string "enum",
|
adamc@188
|
75 space,
|
adamc@311
|
76 string ("__uwe_" ^ #1 (E.lookupDatatype env n) ^ "_" ^ Int.toString n)]
|
adamc@311
|
77 handle CjrEnv.UnboundNamed _ => string ("__uwd_UNBOUND__" ^ Int.toString n))
|
adamc@198
|
78 | TDatatype (Option, n, xncs) =>
|
adamc@198
|
79 (case ListUtil.search #3 (!xncs) of
|
adamc@198
|
80 NONE => raise Fail "CjrPrint: TDatatype marked Option has no constructor with an argument"
|
adamc@198
|
81 | SOME t =>
|
adamc@198
|
82 case #1 t of
|
adamc@198
|
83 TDatatype _ => p_typ' par env t
|
adamc@199
|
84 | TFfi ("Basis", "string") => p_typ' par env t
|
adamc@198
|
85 | _ => box [p_typ' par env t,
|
adamc@198
|
86 string "*"])
|
adamc@188
|
87 | TDatatype (Default, n, _) =>
|
adamc@165
|
88 (box [string "struct",
|
adamc@165
|
89 space,
|
adamc@311
|
90 string ("__uwd_" ^ #1 (E.lookupDatatype env n) ^ "_" ^ Int.toString n ^ "*")]
|
adamc@311
|
91 handle CjrEnv.UnboundNamed _ => string ("__uwd_UNBOUND__" ^ Int.toString n))
|
adamc@311
|
92 | TFfi (m, x) => box [string "uw_", string m, string "_", string x]
|
adamc@288
|
93 | TOption t =>
|
adamc@288
|
94 (case #1 t of
|
adamc@288
|
95 TDatatype _ => p_typ' par env t
|
adamc@288
|
96 | TFfi ("Basis", "string") => p_typ' par env t
|
adamc@288
|
97 | _ => box [p_typ' par env t,
|
adamc@288
|
98 string "*"])
|
adamc@29
|
99
|
adamc@29
|
100 and p_typ env = p_typ' false env
|
adamc@29
|
101
|
adamc@311
|
102 fun p_rel env n = string ("__uwr_" ^ #1 (E.lookupERel env n) ^ "_" ^ Int.toString (E.countERels env - n - 1))
|
adamc@311
|
103 handle CjrEnv.UnboundRel _ => string ("__uwr_UNBOUND_" ^ Int.toString (E.countERels env - n - 1))
|
adamc@29
|
104
|
adamc@109
|
105 fun p_enamed env n =
|
adamc@311
|
106 string ("__uwn_" ^ #1 (E.lookupENamed env n) ^ "_" ^ Int.toString n)
|
adamc@311
|
107 handle CjrEnv.UnboundNamed _ => string ("__uwn_UNBOUND_" ^ Int.toString n)
|
adamc@109
|
108
|
adamc@182
|
109 fun p_con_named env n =
|
adamc@311
|
110 string ("__uwc_" ^ #1 (E.lookupConstructor env n) ^ "_" ^ Int.toString n)
|
adamc@311
|
111 handle CjrEnv.UnboundNamed _ => string ("__uwc_UNBOUND_" ^ Int.toString n)
|
adamc@182
|
112
|
adamc@182
|
113 fun p_pat_preamble env (p, _) =
|
adamc@182
|
114 case p of
|
adamc@182
|
115 PWild => (box [],
|
adamc@182
|
116 env)
|
adamc@182
|
117 | PVar (x, t) => (box [p_typ env t,
|
adamc@182
|
118 space,
|
adamc@311
|
119 string "__uwr_",
|
adamc@182
|
120 string x,
|
adamc@182
|
121 string "_",
|
adamc@182
|
122 string (Int.toString (E.countERels env)),
|
adamc@182
|
123 string ";",
|
adamc@182
|
124 newline],
|
adamc@196
|
125 E.pushERel env x t)
|
adamc@182
|
126 | PPrim _ => (box [], env)
|
adamc@188
|
127 | PCon (_, _, NONE) => (box [], env)
|
adamc@188
|
128 | PCon (_, _, SOME p) => p_pat_preamble env p
|
adamc@182
|
129 | PRecord xps =>
|
adamc@182
|
130 foldl (fn ((_, p, _), (pp, env)) =>
|
adamc@182
|
131 let
|
adamc@182
|
132 val (pp', env) = p_pat_preamble env p
|
adamc@182
|
133 in
|
adamc@182
|
134 (box [pp', pp], env)
|
adamc@182
|
135 end) (box [], env) xps
|
adamc@288
|
136 | PNone _ => (box [], env)
|
adamc@288
|
137 | PSome (_, p) => p_pat_preamble env p
|
adamc@182
|
138
|
adamc@182
|
139 fun p_patCon env pc =
|
adamc@182
|
140 case pc of
|
adamc@182
|
141 PConVar n => p_con_named env n
|
adamc@311
|
142 | PConFfi {mod = m, con, ...} => string ("uw_" ^ m ^ "_" ^ con)
|
adamc@182
|
143
|
adamc@182
|
144 fun p_pat (env, exit, depth) (p, _) =
|
adamc@182
|
145 case p of
|
adamc@182
|
146 PWild =>
|
adamc@182
|
147 (box [], env)
|
adamc@182
|
148 | PVar (x, t) =>
|
adamc@311
|
149 (box [string "__uwr_",
|
adamc@182
|
150 string x,
|
adamc@182
|
151 string "_",
|
adamc@182
|
152 string (Int.toString (E.countERels env)),
|
adamc@182
|
153 space,
|
adamc@182
|
154 string "=",
|
adamc@182
|
155 space,
|
adamc@182
|
156 string "disc",
|
adamc@182
|
157 string (Int.toString depth),
|
adamc@182
|
158 string ";"],
|
adamc@182
|
159 E.pushERel env x t)
|
adamc@182
|
160 | PPrim (Prim.Int n) =>
|
adamc@182
|
161 (box [string "if",
|
adamc@182
|
162 space,
|
adamc@182
|
163 string "(disc",
|
adamc@182
|
164 string (Int.toString depth),
|
adamc@182
|
165 space,
|
adamc@182
|
166 string "!=",
|
adamc@182
|
167 space,
|
adamc@276
|
168 Prim.p_t_GCC (Prim.Int n),
|
adamc@182
|
169 string ")",
|
adamc@182
|
170 space,
|
adamc@182
|
171 exit],
|
adamc@182
|
172 env)
|
adamc@182
|
173 | PPrim (Prim.String s) =>
|
adamc@182
|
174 (box [string "if",
|
adamc@182
|
175 space,
|
adamc@182
|
176 string "(strcmp(disc",
|
adamc@182
|
177 string (Int.toString depth),
|
adamc@182
|
178 string ",",
|
adamc@182
|
179 space,
|
adamc@276
|
180 Prim.p_t_GCC (Prim.String s),
|
adamc@182
|
181 string "))",
|
adamc@182
|
182 space,
|
adamc@182
|
183 exit],
|
adamc@182
|
184 env)
|
adamc@182
|
185 | PPrim _ => raise Fail "CjrPrint: Disallowed PPrim primitive"
|
adamc@182
|
186
|
adamc@188
|
187 | PCon (dk, pc, po) =>
|
adamc@182
|
188 let
|
adamc@182
|
189 val (p, env) =
|
adamc@182
|
190 case po of
|
adamc@182
|
191 NONE => (box [], env)
|
adamc@182
|
192 | SOME p =>
|
adamc@182
|
193 let
|
adamc@182
|
194 val (p, env) = p_pat (env, exit, depth + 1) p
|
adamc@182
|
195
|
adamc@182
|
196 val (x, to) = case pc of
|
adamc@182
|
197 PConVar n =>
|
adamc@182
|
198 let
|
adamc@182
|
199 val (x, to, _) = E.lookupConstructor env n
|
adamc@182
|
200 in
|
adamc@311
|
201 ("uw_" ^ x, to)
|
adamc@182
|
202 end
|
adamc@188
|
203 | PConFfi {mod = m, con, arg, ...} =>
|
adamc@311
|
204 ("uw_" ^ m ^ "_" ^ con, arg)
|
adamc@182
|
205
|
adamc@182
|
206 val t = case to of
|
adamc@182
|
207 NONE => raise Fail "CjrPrint: Constructor mismatch"
|
adamc@182
|
208 | SOME t => t
|
adamc@182
|
209 in
|
adamc@182
|
210 (box [string "{",
|
adamc@182
|
211 newline,
|
adamc@182
|
212 p_typ env t,
|
adamc@182
|
213 space,
|
adamc@182
|
214 string "disc",
|
adamc@182
|
215 string (Int.toString (depth + 1)),
|
adamc@182
|
216 space,
|
adamc@182
|
217 string "=",
|
adamc@182
|
218 space,
|
adamc@198
|
219 case dk of
|
adamc@198
|
220 Enum => raise Fail "CjrPrint: Looking at argument of no-argument constructor"
|
adamc@198
|
221 | Default => box [string "disc",
|
adamc@198
|
222 string (Int.toString depth),
|
adamc@198
|
223 string "->data.",
|
adamc@198
|
224 string x]
|
adamc@198
|
225 | Option =>
|
adamc@198
|
226 case #1 t of
|
adamc@198
|
227 TDatatype _ => box [string "disc",
|
adamc@198
|
228 string (Int.toString depth)]
|
adamc@199
|
229 | TFfi ("Basis", "string") => box [string "disc",
|
adamc@199
|
230 string (Int.toString depth)]
|
adamc@198
|
231 | _ => box [string "*disc",
|
adamc@198
|
232 string (Int.toString depth)],
|
adamc@182
|
233 string ";",
|
adamc@182
|
234 newline,
|
adamc@182
|
235 p,
|
adamc@182
|
236 newline,
|
adamc@182
|
237 string "}"],
|
adamc@182
|
238 env)
|
adamc@182
|
239 end
|
adamc@182
|
240 in
|
adamc@182
|
241 (box [string "if",
|
adamc@182
|
242 space,
|
adamc@182
|
243 string "(disc",
|
adamc@182
|
244 string (Int.toString depth),
|
adamc@198
|
245 case (dk, po) of
|
adamc@198
|
246 (Enum, _) => box [space,
|
adamc@198
|
247 string "!=",
|
adamc@198
|
248 space,
|
adamc@198
|
249 p_patCon env pc]
|
adamc@198
|
250 | (Default, _) => box [string "->tag",
|
adamc@198
|
251 space,
|
adamc@198
|
252 string "!=",
|
adamc@198
|
253 space,
|
adamc@198
|
254 p_patCon env pc]
|
adamc@198
|
255 | (Option, NONE) => box [space,
|
adamc@198
|
256 string "!=",
|
adamc@198
|
257 space,
|
adamc@198
|
258 string "NULL"]
|
adamc@198
|
259 | (Option, SOME _) => box [space,
|
adamc@198
|
260 string "==",
|
adamc@198
|
261 space,
|
adamc@198
|
262 string "NULL"],
|
adamc@182
|
263 string ")",
|
adamc@182
|
264 space,
|
adamc@182
|
265 exit,
|
adamc@182
|
266 newline,
|
adamc@182
|
267 p],
|
adamc@182
|
268 env)
|
adamc@182
|
269 end
|
adamc@182
|
270
|
adamc@182
|
271 | PRecord xps =>
|
adamc@182
|
272 let
|
adamc@182
|
273 val (xps, env) =
|
adamc@182
|
274 ListUtil.foldlMap (fn ((x, p, t), env) =>
|
adamc@182
|
275 let
|
adamc@182
|
276 val (p, env) = p_pat (env, exit, depth + 1) p
|
adamc@182
|
277
|
adamc@182
|
278 val p = box [string "{",
|
adamc@182
|
279 newline,
|
adamc@182
|
280 p_typ env t,
|
adamc@182
|
281 space,
|
adamc@182
|
282 string "disc",
|
adamc@182
|
283 string (Int.toString (depth + 1)),
|
adamc@182
|
284 space,
|
adamc@182
|
285 string "=",
|
adamc@182
|
286 space,
|
adamc@182
|
287 string "disc",
|
adamc@182
|
288 string (Int.toString depth),
|
adamc@311
|
289 string ".__uwf_",
|
adamc@182
|
290 string x,
|
adamc@182
|
291 string ";",
|
adamc@182
|
292 newline,
|
adamc@182
|
293 p,
|
adamc@182
|
294 newline,
|
adamc@182
|
295 string "}"]
|
adamc@182
|
296 in
|
adamc@182
|
297 (p, env)
|
adamc@182
|
298 end) env xps
|
adamc@182
|
299 in
|
adamc@182
|
300 (p_list_sep newline (fn x => x) xps,
|
adamc@182
|
301 env)
|
adamc@182
|
302 end
|
adamc@182
|
303
|
adamc@288
|
304 | PNone t =>
|
adamc@288
|
305 (box [string "if",
|
adamc@288
|
306 space,
|
adamc@288
|
307 string "(disc",
|
adamc@288
|
308 string (Int.toString depth),
|
adamc@288
|
309 space,
|
adamc@288
|
310 string "!=",
|
adamc@288
|
311 space,
|
adamc@288
|
312 string "NULL)",
|
adamc@288
|
313 space,
|
adamc@288
|
314 exit,
|
adamc@288
|
315 newline],
|
adamc@288
|
316 env)
|
adamc@288
|
317
|
adamc@288
|
318 | PSome (t, p) =>
|
adamc@288
|
319 let
|
adamc@288
|
320 val (p, env) =
|
adamc@288
|
321 let
|
adamc@288
|
322 val (p, env) = p_pat (env, exit, depth + 1) p
|
adamc@288
|
323 in
|
adamc@288
|
324 (box [string "{",
|
adamc@288
|
325 newline,
|
adamc@288
|
326 p_typ env t,
|
adamc@288
|
327 space,
|
adamc@288
|
328 string "disc",
|
adamc@288
|
329 string (Int.toString (depth + 1)),
|
adamc@288
|
330 space,
|
adamc@288
|
331 string "=",
|
adamc@288
|
332 space,
|
adamc@288
|
333 case #1 t of
|
adamc@288
|
334 TDatatype _ => box [string "disc",
|
adamc@288
|
335 string (Int.toString depth)]
|
adamc@288
|
336 | TFfi ("Basis", "string") => box [string "disc",
|
adamc@288
|
337 string (Int.toString depth)]
|
adamc@288
|
338 | _ => box [string "*disc",
|
adamc@288
|
339 string (Int.toString depth)],
|
adamc@288
|
340 string ";",
|
adamc@288
|
341 newline,
|
adamc@288
|
342 p,
|
adamc@288
|
343 newline,
|
adamc@288
|
344 string "}"],
|
adamc@288
|
345 env)
|
adamc@288
|
346 end
|
adamc@288
|
347 in
|
adamc@288
|
348 (box [string "if",
|
adamc@288
|
349 space,
|
adamc@288
|
350 string "(disc",
|
adamc@288
|
351 string (Int.toString depth),
|
adamc@288
|
352 space,
|
adamc@288
|
353 string "==",
|
adamc@288
|
354 space,
|
adamc@288
|
355 string "NULL)",
|
adamc@288
|
356 space,
|
adamc@288
|
357 exit,
|
adamc@288
|
358 newline,
|
adamc@288
|
359 p],
|
adamc@288
|
360 env)
|
adamc@288
|
361 end
|
adamc@288
|
362
|
adamc@182
|
363 local
|
adamc@182
|
364 val count = ref 0
|
adamc@182
|
365 in
|
adamc@182
|
366 fun newGoto () =
|
adamc@182
|
367 let
|
adamc@182
|
368 val r = !count
|
adamc@182
|
369 in
|
adamc@182
|
370 count := r + 1;
|
adamc@182
|
371 string ("L" ^ Int.toString r)
|
adamc@182
|
372 end
|
adamc@182
|
373 end
|
adamc@182
|
374
|
adamc@185
|
375 fun patConInfo env pc =
|
adamc@185
|
376 case pc of
|
adamc@185
|
377 PConVar n =>
|
adamc@185
|
378 let
|
adamc@185
|
379 val (x, _, dn) = E.lookupConstructor env n
|
adamc@185
|
380 val (dx, _) = E.lookupDatatype env dn
|
adamc@185
|
381 in
|
adamc@311
|
382 ("__uwd_" ^ dx ^ "_" ^ Int.toString dn,
|
adamc@311
|
383 "__uwc_" ^ x ^ "_" ^ Int.toString n,
|
adamc@311
|
384 "uw_" ^ x)
|
adamc@185
|
385 end
|
adamc@186
|
386 | PConFfi {mod = m, datatyp, con, ...} =>
|
adamc@311
|
387 ("uw_" ^ m ^ "_" ^ datatyp,
|
adamc@311
|
388 "uw_" ^ m ^ "_" ^ con,
|
adamc@311
|
389 "uw_" ^ con)
|
adamc@185
|
390
|
adamc@278
|
391 fun p_unsql env (tAll as (t, loc)) e =
|
adamc@278
|
392 case t of
|
adamc@311
|
393 TFfi ("Basis", "int") => box [string "uw_Basis_stringToInt_error(ctx, ", e, string ")"]
|
adamc@311
|
394 | TFfi ("Basis", "float") => box [string "uw_Basis_stringToFloat_error(ctx, ", e, string ")"]
|
adamc@311
|
395 | TFfi ("Basis", "string") => box [string "uw_Basis_strdup(ctx, ", e, string ")"]
|
adamc@311
|
396 | TFfi ("Basis", "bool") => box [string "uw_Basis_stringToBool_error(ctx, ", e, string ")"]
|
adamc@278
|
397 | _ => (ErrorMsg.errorAt loc "Don't know how to unmarshal type from SQL";
|
adamc@278
|
398 Print.eprefaces' [("Type", p_typ env tAll)];
|
adamc@278
|
399 string "ERROR")
|
adamc@278
|
400
|
adamc@282
|
401 datatype sql_type =
|
adamc@282
|
402 Int
|
adamc@282
|
403 | Float
|
adamc@282
|
404 | String
|
adamc@282
|
405 | Bool
|
adamc@282
|
406
|
adamc@282
|
407 fun p_sql_type t =
|
adamc@282
|
408 string (case t of
|
adamc@311
|
409 Int => "uw_Basis_int"
|
adamc@311
|
410 | Float => "uw_Basis_float"
|
adamc@311
|
411 | String => "uw_Basis_string"
|
adamc@311
|
412 | Bool => "uw_Basis_bool")
|
adamc@282
|
413
|
adamc@282
|
414 fun getPargs (e, _) =
|
adamc@282
|
415 case e of
|
adamc@282
|
416 EPrim (Prim.String _) => []
|
adamc@282
|
417 | EFfiApp ("Basis", "strcat", [e1, e2]) => getPargs e1 @ getPargs e2
|
adamc@282
|
418
|
adamc@282
|
419 | EFfiApp ("Basis", "sqlifyInt", [e]) => [(e, Int)]
|
adamc@282
|
420 | EFfiApp ("Basis", "sqlifyFloat", [e]) => [(e, Float)]
|
adamc@282
|
421 | EFfiApp ("Basis", "sqlifyString", [e]) => [(e, String)]
|
adamc@282
|
422 | EFfiApp ("Basis", "sqlifyBool", [e]) => [(e, Bool)]
|
adamc@282
|
423
|
adamc@282
|
424 | _ => raise Fail "CjrPrint: getPargs"
|
adamc@282
|
425
|
adamc@282
|
426 fun p_ensql t e =
|
adamc@282
|
427 case t of
|
adamc@311
|
428 Int => box [string "uw_Basis_attrifyInt(ctx, ", e, string ")"]
|
adamc@311
|
429 | Float => box [string "uw_Basis_attrifyFloat(ctx, ", e, string ")"]
|
adamc@282
|
430 | String => e
|
adamc@295
|
431 | Bool => box [string "(", e, string " ? \"TRUE\" : \"FALSE\")"]
|
adamc@282
|
432
|
adamc@282
|
433 fun p_ensql_len t e =
|
adamc@282
|
434 case t of
|
adamc@311
|
435 Int => string "sizeof(uw_Basis_int)"
|
adamc@311
|
436 | Float => string "sizeof(uw_Basis_float)"
|
adamc@282
|
437 | String => box [string "strlen(", e, string ")"]
|
adamc@311
|
438 | Bool => string "sizeof(uw_Basis_bool)"
|
adamc@282
|
439
|
adamc@182
|
440 fun p_exp' par env (e, loc) =
|
adamc@29
|
441 case e of
|
adamc@276
|
442 EPrim p => Prim.p_t_GCC p
|
adamc@29
|
443 | ERel n => p_rel env n
|
adamc@109
|
444 | ENamed n => p_enamed env n
|
adamc@188
|
445 | ECon (Enum, pc, _) => p_patCon env pc
|
adamc@198
|
446 | ECon (Option, pc, NONE) => string "NULL"
|
adamc@198
|
447 | ECon (Option, pc, SOME e) =>
|
adamc@198
|
448 let
|
adamc@198
|
449 val to = case pc of
|
adamc@198
|
450 PConVar n => #2 (E.lookupConstructor env n)
|
adamc@198
|
451 | PConFfi {arg, ...} => arg
|
adamc@198
|
452
|
adamc@198
|
453 val t = case to of
|
adamc@198
|
454 NONE => raise Fail "CjrPrint: ECon argument status mismatch"
|
adamc@198
|
455 | SOME t => t
|
adamc@198
|
456 in
|
adamc@198
|
457 case #1 t of
|
adamc@198
|
458 TDatatype _ => p_exp' par env e
|
adamc@199
|
459 | TFfi ("Basis", "string") => p_exp' par env e
|
adamc@198
|
460 | _ => box [string "({",
|
adamc@198
|
461 newline,
|
adamc@198
|
462 p_typ env t,
|
adamc@198
|
463 space,
|
adamc@198
|
464 string "*tmp",
|
adamc@198
|
465 space,
|
adamc@198
|
466 string "=",
|
adamc@198
|
467 space,
|
adamc@311
|
468 string "uw_malloc(ctx, sizeof(",
|
adamc@198
|
469 p_typ env t,
|
adamc@198
|
470 string "));",
|
adamc@198
|
471 newline,
|
adamc@198
|
472 string "*tmp",
|
adamc@198
|
473 space,
|
adamc@198
|
474 string "=",
|
adamc@198
|
475 p_exp' par env e,
|
adamc@198
|
476 string ";",
|
adamc@198
|
477 newline,
|
adamc@198
|
478 string "tmp;",
|
adamc@198
|
479 newline,
|
adamc@198
|
480 string "})"]
|
adamc@198
|
481 end
|
adamc@188
|
482 | ECon (Default, pc, eo) =>
|
adamc@181
|
483 let
|
adamc@196
|
484 val (xd, xc, xn) = patConInfo env pc
|
adamc@181
|
485 in
|
adamc@182
|
486 box [string "({",
|
adamc@181
|
487 newline,
|
adamc@181
|
488 string "struct",
|
adamc@181
|
489 space,
|
adamc@185
|
490 string xd,
|
adamc@181
|
491 space,
|
adamc@181
|
492 string "*tmp",
|
adamc@181
|
493 space,
|
adamc@181
|
494 string "=",
|
adamc@181
|
495 space,
|
adamc@311
|
496 string "uw_malloc(ctx, sizeof(struct ",
|
adamc@185
|
497 string xd,
|
adamc@181
|
498 string "));",
|
adamc@181
|
499 newline,
|
adamc@181
|
500 string "tmp->tag",
|
adamc@181
|
501 space,
|
adamc@181
|
502 string "=",
|
adamc@181
|
503 space,
|
adamc@185
|
504 string xc,
|
adamc@181
|
505 string ";",
|
adamc@181
|
506 newline,
|
adamc@181
|
507 case eo of
|
adamc@181
|
508 NONE => box []
|
adamc@185
|
509 | SOME e => box [string "tmp->data.",
|
adamc@196
|
510 string xn,
|
adamc@181
|
511 space,
|
adamc@181
|
512 string "=",
|
adamc@181
|
513 space,
|
adamc@181
|
514 p_exp env e,
|
adamc@181
|
515 string ";",
|
adamc@181
|
516 newline],
|
adamc@181
|
517 string "tmp;",
|
adamc@181
|
518 newline,
|
adamc@181
|
519 string "})"]
|
adamc@181
|
520 end
|
adamc@297
|
521 | ENone _ => string "NULL"
|
adamc@290
|
522 | ESome (t, e) =>
|
adamc@290
|
523 (case #1 t of
|
adamc@290
|
524 TDatatype _ => p_exp' par env e
|
adamc@290
|
525 | TFfi ("Basis", "string") => p_exp' par env e
|
adamc@290
|
526 | _ => box [string "({",
|
adamc@290
|
527 newline,
|
adamc@290
|
528 p_typ env t,
|
adamc@290
|
529 space,
|
adamc@290
|
530 string "*tmp",
|
adamc@290
|
531 space,
|
adamc@290
|
532 string "=",
|
adamc@290
|
533 space,
|
adamc@311
|
534 string "uw_malloc(ctx, sizeof(",
|
adamc@290
|
535 p_typ env t,
|
adamc@290
|
536 string "));",
|
adamc@290
|
537 newline,
|
adamc@290
|
538 string "*tmp",
|
adamc@290
|
539 space,
|
adamc@290
|
540 string "=",
|
adamc@290
|
541 p_exp' par env e,
|
adamc@290
|
542 string ";",
|
adamc@290
|
543 newline,
|
adamc@290
|
544 string "tmp;",
|
adamc@290
|
545 newline,
|
adamc@290
|
546 string "})"])
|
adamc@109
|
547
|
adamc@311
|
548 | EFfi (m, x) => box [string "uw_", string m, string "_", string x]
|
adamc@283
|
549 | EError (e, t) =>
|
adamc@283
|
550 box [string "({",
|
adamc@283
|
551 newline,
|
adamc@283
|
552 p_typ env t,
|
adamc@283
|
553 space,
|
adamc@283
|
554 string "tmp;",
|
adamc@283
|
555 newline,
|
adamc@311
|
556 string "uw_error(ctx, FATAL, \"",
|
adamc@292
|
557 string (ErrorMsg.spanToString loc),
|
adamc@292
|
558 string ": %s\", ",
|
adamc@283
|
559 p_exp env e,
|
adamc@283
|
560 string ");",
|
adamc@283
|
561 newline,
|
adamc@283
|
562 string "tmp;",
|
adamc@283
|
563 newline,
|
adamc@283
|
564 string "})"]
|
adamc@311
|
565 | EFfiApp (m, x, es) => box [string "uw_",
|
adamc@53
|
566 string m,
|
adamc@53
|
567 string "_",
|
adamc@53
|
568 string x,
|
adamc@117
|
569 string "(ctx, ",
|
adamc@53
|
570 p_list (p_exp env) es,
|
adamc@53
|
571 string ")"]
|
adamc@129
|
572 | EApp (e1, e2) =>
|
adamc@129
|
573 let
|
adamc@129
|
574 fun unravel (f, acc) =
|
adamc@129
|
575 case #1 f of
|
adamc@129
|
576 EApp (f', arg) => unravel (f', arg :: acc)
|
adamc@129
|
577 | _ => (f, acc)
|
adamc@129
|
578
|
adamc@129
|
579 val (f, args) = unravel (e1, [e2])
|
adamc@129
|
580 in
|
adamc@129
|
581 parenIf par (box [p_exp' true env e1,
|
adamc@129
|
582 string "(ctx,",
|
adamc@129
|
583 space,
|
adamc@129
|
584 p_list_sep (box [string ",", space]) (p_exp env) args,
|
adamc@129
|
585 string ")"])
|
adamc@129
|
586 end
|
adamc@29
|
587
|
adamc@29
|
588 | ERecord (i, xes) => box [string "({",
|
adamc@29
|
589 space,
|
adamc@29
|
590 string "struct",
|
adamc@29
|
591 space,
|
adamc@311
|
592 string ("__uws_" ^ Int.toString i),
|
adamc@29
|
593 space,
|
adamc@181
|
594 string "tmp",
|
adamc@29
|
595 space,
|
adamc@29
|
596 string "=",
|
adamc@29
|
597 space,
|
adamc@29
|
598 string "{",
|
adamc@29
|
599 p_list (fn (_, e) =>
|
adamc@29
|
600 p_exp env e) xes,
|
adamc@29
|
601 string "};",
|
adamc@29
|
602 space,
|
adamc@181
|
603 string "tmp;",
|
adamc@29
|
604 space,
|
adamc@29
|
605 string "})" ]
|
adamc@29
|
606 | EField (e, x) =>
|
adamc@29
|
607 box [p_exp' true env e,
|
adamc@311
|
608 string ".__uwf_",
|
adamc@29
|
609 string x]
|
adamc@29
|
610
|
adamc@182
|
611 | ECase (e, pes, {disc, result}) =>
|
adamc@182
|
612 let
|
adamc@182
|
613 val final = newGoto ()
|
adamc@182
|
614
|
adamc@182
|
615 val body = foldl (fn ((p, e), body) =>
|
adamc@182
|
616 let
|
adamc@182
|
617 val exit = newGoto ()
|
adamc@182
|
618 val (pr, _) = p_pat_preamble env p
|
adamc@182
|
619 val (p, env) = p_pat (env,
|
adamc@182
|
620 box [string "goto",
|
adamc@182
|
621 space,
|
adamc@182
|
622 exit,
|
adamc@182
|
623 string ";"],
|
adamc@182
|
624 0) p
|
adamc@182
|
625 in
|
adamc@182
|
626 box [body,
|
adamc@182
|
627 box [string "{",
|
adamc@182
|
628 newline,
|
adamc@182
|
629 pr,
|
adamc@182
|
630 newline,
|
adamc@182
|
631 p,
|
adamc@182
|
632 newline,
|
adamc@182
|
633 string "result",
|
adamc@182
|
634 space,
|
adamc@182
|
635 string "=",
|
adamc@182
|
636 space,
|
adamc@182
|
637 p_exp env e,
|
adamc@182
|
638 string ";",
|
adamc@182
|
639 newline,
|
adamc@182
|
640 string "goto",
|
adamc@182
|
641 space,
|
adamc@182
|
642 final,
|
adamc@182
|
643 string ";",
|
adamc@182
|
644 newline,
|
adamc@182
|
645 string "}"],
|
adamc@182
|
646 newline,
|
adamc@182
|
647 exit,
|
adamc@182
|
648 string ":",
|
adamc@182
|
649 newline]
|
adamc@182
|
650 end) (box []) pes
|
adamc@182
|
651 in
|
adamc@182
|
652 box [string "({",
|
adamc@182
|
653 newline,
|
adamc@182
|
654 p_typ env disc,
|
adamc@182
|
655 space,
|
adamc@182
|
656 string "disc0",
|
adamc@182
|
657 space,
|
adamc@182
|
658 string "=",
|
adamc@182
|
659 space,
|
adamc@182
|
660 p_exp env e,
|
adamc@182
|
661 string ";",
|
adamc@182
|
662 newline,
|
adamc@182
|
663 p_typ env result,
|
adamc@182
|
664 space,
|
adamc@182
|
665 string "result;",
|
adamc@182
|
666 newline,
|
adamc@182
|
667 body,
|
adamc@311
|
668 string "uw_error(ctx, FATAL, \"",
|
adamc@182
|
669 string (ErrorMsg.spanToString loc),
|
adamc@182
|
670 string ": pattern match failure\");",
|
adamc@182
|
671 newline,
|
adamc@182
|
672 final,
|
adamc@182
|
673 string ":",
|
adamc@182
|
674 space,
|
adamc@182
|
675 string "result;",
|
adamc@182
|
676 newline,
|
adamc@182
|
677 string "})"]
|
adamc@182
|
678 end
|
adamc@181
|
679
|
adamc@311
|
680 | EWrite e => box [string "(uw_write(ctx, ",
|
adamc@102
|
681 p_exp env e,
|
adamc@311
|
682 string "), uw_unit_v)"]
|
adamc@102
|
683
|
adamc@106
|
684 | ESeq (e1, e2) => box [string "(",
|
adamc@106
|
685 p_exp env e1,
|
adamc@106
|
686 string ",",
|
adamc@106
|
687 space,
|
adamc@106
|
688 p_exp env e2,
|
adamc@106
|
689 string ")"]
|
adamc@269
|
690 | ELet (x, t, e1, e2) => box [string "({",
|
adamc@269
|
691 newline,
|
adamc@269
|
692 p_typ env t,
|
adamc@269
|
693 space,
|
adamc@311
|
694 string "__uwr_",
|
adamc@272
|
695 string x,
|
adamc@272
|
696 string "_",
|
adamc@272
|
697 string (Int.toString (E.countERels env)),
|
adamc@269
|
698 space,
|
adamc@269
|
699 string "=",
|
adamc@269
|
700 space,
|
adamc@269
|
701 p_exp env e1,
|
adamc@269
|
702 string ";",
|
adamc@269
|
703 newline,
|
adamc@269
|
704 p_exp (E.pushERel env x t) e2,
|
adamc@269
|
705 string ";",
|
adamc@269
|
706 newline,
|
adamc@269
|
707 string "})"]
|
adamc@269
|
708
|
adamc@282
|
709 | EQuery {exps, tables, rnum, state, query, body, initial, prepared} =>
|
adamc@278
|
710 let
|
adamc@311
|
711 val exps = map (fn (x, t) => ("__uwf_" ^ x, t)) exps
|
adamc@278
|
712 val tables = ListUtil.mapConcat (fn (x, xts) =>
|
adamc@311
|
713 map (fn (x', t) => ("__uwf_" ^ x ^ ".__uwf_" ^ x', t)) xts)
|
adamc@278
|
714 tables
|
adamc@278
|
715
|
adamc@278
|
716 val outputs = exps @ tables
|
adamc@278
|
717 in
|
adamc@278
|
718 box [string "({",
|
adamc@278
|
719 newline,
|
adamc@311
|
720 string "PGconn *conn = uw_get_db(ctx);",
|
adamc@278
|
721 newline,
|
adamc@282
|
722 case prepared of
|
adamc@282
|
723 NONE => box [string "char *query = ",
|
adamc@282
|
724 p_exp env query,
|
adamc@282
|
725 string ";",
|
adamc@282
|
726 newline]
|
adamc@282
|
727 | SOME _ =>
|
adamc@282
|
728 let
|
adamc@282
|
729 val ets = getPargs query
|
adamc@282
|
730 in
|
adamc@282
|
731 box [p_list_sepi newline
|
adamc@282
|
732 (fn i => fn (e, t) =>
|
adamc@282
|
733 box [p_sql_type t,
|
adamc@282
|
734 space,
|
adamc@282
|
735 string "arg",
|
adamc@282
|
736 string (Int.toString (i + 1)),
|
adamc@282
|
737 space,
|
adamc@282
|
738 string "=",
|
adamc@282
|
739 space,
|
adamc@282
|
740 p_exp env e,
|
adamc@282
|
741 string ";"])
|
adamc@282
|
742 ets,
|
adamc@282
|
743 newline,
|
adamc@282
|
744 newline,
|
adamc@282
|
745
|
adamc@282
|
746 string "const char *paramValues[] = { ",
|
adamc@282
|
747 p_list_sepi (box [string ",", space])
|
adamc@282
|
748 (fn i => fn (_, t) => p_ensql t (box [string "arg",
|
adamc@282
|
749 string (Int.toString (i + 1))]))
|
adamc@282
|
750 ets,
|
adamc@282
|
751 string " };",
|
adamc@282
|
752 newline,
|
adamc@282
|
753 newline]
|
adamc@282
|
754 end,
|
adamc@278
|
755 string "int n, i;",
|
adamc@278
|
756 newline,
|
adamc@278
|
757 p_typ env state,
|
adamc@278
|
758 space,
|
adamc@278
|
759 string "acc",
|
adamc@278
|
760 space,
|
adamc@278
|
761 string "=",
|
adamc@278
|
762 space,
|
adamc@278
|
763 p_exp env initial,
|
adamc@278
|
764 string ";",
|
adamc@278
|
765 newline,
|
adamc@282
|
766 string "PGresult *res = ",
|
adamc@282
|
767 case prepared of
|
adamc@295
|
768 NONE => string "PQexecParams(conn, query, 0, NULL, NULL, NULL, NULL, 0);"
|
adamc@311
|
769 | SOME n => box [string "PQexecPrepared(conn, \"uw",
|
adamc@282
|
770 string (Int.toString n),
|
adamc@282
|
771 string "\", ",
|
adamc@282
|
772 string (Int.toString (length (getPargs query))),
|
adamc@295
|
773 string ", paramValues, NULL, NULL, 0);"],
|
adamc@278
|
774 newline,
|
adamc@278
|
775 newline,
|
adamc@277
|
776
|
adamc@311
|
777 string "if (res == NULL) uw_error(ctx, FATAL, \"Out of memory allocating query result.\");",
|
adamc@278
|
778 newline,
|
adamc@278
|
779 newline,
|
adamc@277
|
780
|
adamc@278
|
781 string "if (PQresultStatus(res) != PGRES_TUPLES_OK) {",
|
adamc@278
|
782 newline,
|
adamc@278
|
783 box [string "PQclear(res);",
|
adamc@278
|
784 newline,
|
adamc@311
|
785 string "uw_error(ctx, FATAL, \"",
|
adamc@278
|
786 string (ErrorMsg.spanToString loc),
|
adamc@282
|
787 string ": Query failed:\\n%s\\n%s\", ",
|
adamc@282
|
788 case prepared of
|
adamc@282
|
789 NONE => string "query"
|
adamc@282
|
790 | SOME _ => p_exp env query,
|
adamc@282
|
791 string ", PQerrorMessage(conn));",
|
adamc@278
|
792 newline],
|
adamc@278
|
793 string "}",
|
adamc@278
|
794 newline,
|
adamc@278
|
795 newline,
|
adamc@277
|
796
|
adamc@278
|
797 string "n = PQntuples(res);",
|
adamc@278
|
798 newline,
|
adamc@278
|
799 string "for (i = 0; i < n; ++i) {",
|
adamc@278
|
800 newline,
|
adamc@278
|
801 box [string "struct",
|
adamc@278
|
802 space,
|
adamc@311
|
803 string "__uws_",
|
adamc@278
|
804 string (Int.toString rnum),
|
adamc@278
|
805 space,
|
adamc@311
|
806 string "__uwr_r_",
|
adamc@278
|
807 string (Int.toString (E.countERels env)),
|
adamc@278
|
808 string ";",
|
adamc@278
|
809 newline,
|
adamc@278
|
810 p_typ env state,
|
adamc@278
|
811 space,
|
adamc@311
|
812 string "__uwr_acc_",
|
adamc@278
|
813 string (Int.toString (E.countERels env + 1)),
|
adamc@278
|
814 space,
|
adamc@278
|
815 string "=",
|
adamc@278
|
816 space,
|
adamc@278
|
817 string "acc;",
|
adamc@278
|
818 newline,
|
adamc@278
|
819 newline,
|
adamc@278
|
820
|
adamc@278
|
821 p_list_sepi (box []) (fn i =>
|
adamc@278
|
822 fn (proj, t) =>
|
adamc@311
|
823 box [string "__uwr_r_",
|
adamc@278
|
824 string (Int.toString (E.countERels env)),
|
adamc@278
|
825 string ".",
|
adamc@278
|
826 string proj,
|
adamc@278
|
827 space,
|
adamc@278
|
828 string "=",
|
adamc@278
|
829 space,
|
adamc@278
|
830 p_unsql env t
|
adamc@278
|
831 (box [string "PQgetvalue(res, i, ",
|
adamc@278
|
832 string (Int.toString i),
|
adamc@278
|
833 string ")"]),
|
adamc@278
|
834 string ";",
|
adamc@278
|
835 newline]) outputs,
|
adamc@278
|
836
|
adamc@278
|
837 newline,
|
adamc@278
|
838 newline,
|
adamc@278
|
839
|
adamc@278
|
840 string "acc",
|
adamc@278
|
841 space,
|
adamc@278
|
842 string "=",
|
adamc@278
|
843 space,
|
adamc@278
|
844 p_exp (E.pushERel
|
adamc@278
|
845 (E.pushERel env "r" (TRecord rnum, loc))
|
adamc@278
|
846 "acc" state)
|
adamc@278
|
847 body,
|
adamc@278
|
848 string ";",
|
adamc@278
|
849 newline],
|
adamc@278
|
850 string "}",
|
adamc@278
|
851 newline,
|
adamc@278
|
852 newline,
|
adamc@278
|
853 string "PQclear(res);",
|
adamc@278
|
854 newline,
|
adamc@278
|
855 string "acc;",
|
adamc@278
|
856 newline,
|
adamc@278
|
857 string "})"]
|
adamc@278
|
858 end
|
adamc@106
|
859
|
adamc@307
|
860 | EDml {dml, prepared} =>
|
adamc@307
|
861 box [string "({",
|
adamc@307
|
862 newline,
|
adamc@311
|
863 string "PGconn *conn = uw_get_db(ctx);",
|
adamc@307
|
864 newline,
|
adamc@307
|
865 case prepared of
|
adamc@307
|
866 NONE => box [string "char *dml = ",
|
adamc@307
|
867 p_exp env dml,
|
adamc@307
|
868 string ";",
|
adamc@307
|
869 newline]
|
adamc@307
|
870 | SOME _ =>
|
adamc@307
|
871 let
|
adamc@307
|
872 val ets = getPargs dml
|
adamc@307
|
873 in
|
adamc@307
|
874 box [p_list_sepi newline
|
adamc@307
|
875 (fn i => fn (e, t) =>
|
adamc@307
|
876 box [p_sql_type t,
|
adamc@307
|
877 space,
|
adamc@307
|
878 string "arg",
|
adamc@307
|
879 string (Int.toString (i + 1)),
|
adamc@307
|
880 space,
|
adamc@307
|
881 string "=",
|
adamc@307
|
882 space,
|
adamc@307
|
883 p_exp env e,
|
adamc@307
|
884 string ";"])
|
adamc@307
|
885 ets,
|
adamc@307
|
886 newline,
|
adamc@307
|
887 newline,
|
adamc@307
|
888
|
adamc@307
|
889 string "const char *paramValues[] = { ",
|
adamc@307
|
890 p_list_sepi (box [string ",", space])
|
adamc@307
|
891 (fn i => fn (_, t) => p_ensql t (box [string "arg",
|
adamc@307
|
892 string (Int.toString (i + 1))]))
|
adamc@307
|
893 ets,
|
adamc@307
|
894 string " };",
|
adamc@307
|
895 newline,
|
adamc@307
|
896 newline]
|
adamc@307
|
897 end,
|
adamc@307
|
898 newline,
|
adamc@307
|
899 newline,
|
adamc@307
|
900 string "PGresult *res = ",
|
adamc@307
|
901 case prepared of
|
adamc@307
|
902 NONE => string "PQexecParams(conn, dml, 0, NULL, NULL, NULL, NULL, 0);"
|
adamc@311
|
903 | SOME n => box [string "PQexecPrepared(conn, \"uw",
|
adamc@307
|
904 string (Int.toString n),
|
adamc@307
|
905 string "\", ",
|
adamc@307
|
906 string (Int.toString (length (getPargs dml))),
|
adamc@307
|
907 string ", paramValues, NULL, NULL, 0);"],
|
adamc@307
|
908 newline,
|
adamc@307
|
909 newline,
|
adamc@307
|
910
|
adamc@311
|
911 string "if (res == NULL) uw_error(ctx, FATAL, \"Out of memory allocating DML result.\");",
|
adamc@307
|
912 newline,
|
adamc@307
|
913 newline,
|
adamc@307
|
914
|
adamc@307
|
915 string "if (PQresultStatus(res) != PGRES_COMMAND_OK) {",
|
adamc@307
|
916 newline,
|
adamc@307
|
917 box [string "PQclear(res);",
|
adamc@307
|
918 newline,
|
adamc@311
|
919 string "uw_error(ctx, FATAL, \"",
|
adamc@307
|
920 string (ErrorMsg.spanToString loc),
|
adamc@307
|
921 string ": DML failed:\\n%s\\n%s\", ",
|
adamc@307
|
922 case prepared of
|
adamc@307
|
923 NONE => string "dml"
|
adamc@307
|
924 | SOME _ => p_exp env dml,
|
adamc@307
|
925 string ", PQerrorMessage(conn));",
|
adamc@307
|
926 newline],
|
adamc@307
|
927 string "}",
|
adamc@307
|
928 newline,
|
adamc@307
|
929 newline,
|
adamc@307
|
930
|
adamc@307
|
931 string "PQclear(res);",
|
adamc@307
|
932 newline,
|
adamc@311
|
933 string "uw_unit_v;",
|
adamc@307
|
934 newline,
|
adamc@307
|
935 string "})"]
|
adamc@307
|
936
|
adamc@29
|
937 and p_exp env = p_exp' false env
|
adamc@29
|
938
|
adamc@129
|
939 fun p_fun env (fx, n, args, ran, e) =
|
adamc@129
|
940 let
|
adamc@129
|
941 val nargs = length args
|
adamc@129
|
942 val env' = foldl (fn ((x, dom), env) => E.pushERel env x dom) env args
|
adamc@129
|
943 in
|
adamc@129
|
944 box [string "static",
|
adamc@129
|
945 space,
|
adamc@129
|
946 p_typ env ran,
|
adamc@129
|
947 space,
|
adamc@311
|
948 string ("__uwn_" ^ fx ^ "_" ^ Int.toString n),
|
adamc@129
|
949 string "(",
|
adamc@129
|
950 p_list_sep (box [string ",", space]) (fn x => x)
|
adamc@311
|
951 (string "uw_context ctx" :: ListUtil.mapi (fn (i, (_, dom)) =>
|
adamc@129
|
952 box [p_typ env dom,
|
adamc@129
|
953 space,
|
adamc@129
|
954 p_rel env' (nargs - i - 1)]) args),
|
adamc@129
|
955 string ")",
|
adamc@129
|
956 space,
|
adamc@129
|
957 string "{",
|
adamc@129
|
958 newline,
|
adamc@129
|
959 box[string "return(",
|
adamc@129
|
960 p_exp env' e,
|
adamc@129
|
961 string ");"],
|
adamc@129
|
962 newline,
|
adamc@129
|
963 string "}"]
|
adamc@129
|
964 end
|
adamc@129
|
965
|
adamc@129
|
966 fun p_decl env (dAll as (d, _) : decl) =
|
adamc@29
|
967 case d of
|
adamc@29
|
968 DStruct (n, xts) =>
|
adamc@196
|
969 let
|
adamc@196
|
970 val env = E.declBinds env dAll
|
adamc@196
|
971 in
|
adamc@196
|
972 box [string "struct",
|
adamc@196
|
973 space,
|
adamc@311
|
974 string ("__uws_" ^ Int.toString n),
|
adamc@196
|
975 space,
|
adamc@196
|
976 string "{",
|
adamc@196
|
977 newline,
|
adamc@196
|
978 p_list_sep (box []) (fn (x, t) => box [p_typ env t,
|
adamc@196
|
979 space,
|
adamc@311
|
980 string "__uwf_",
|
adamc@196
|
981 string x,
|
adamc@196
|
982 string ";",
|
adamc@196
|
983 newline]) xts,
|
adamc@196
|
984 string "};"]
|
adamc@196
|
985 end
|
adamc@188
|
986 | DDatatype (Enum, x, n, xncs) =>
|
adamc@188
|
987 box [string "enum",
|
adamc@188
|
988 space,
|
adamc@311
|
989 string ("__uwe_" ^ x ^ "_" ^ Int.toString n),
|
adamc@188
|
990 space,
|
adamc@188
|
991 string "{",
|
adamc@188
|
992 space,
|
adamc@311
|
993 p_list_sep (box [string ",", space]) (fn (x, n, _) => string ("__uwc_" ^ x ^ "_" ^ Int.toString n)) xncs,
|
adamc@188
|
994 space,
|
adamc@188
|
995 string "};"]
|
adamc@198
|
996 | DDatatype (Option, _, _, _) => box []
|
adamc@188
|
997 | DDatatype (Default, x, n, xncs) =>
|
adamc@165
|
998 let
|
adamc@165
|
999 val xncsArgs = List.mapPartial (fn (x, n, NONE) => NONE
|
adamc@165
|
1000 | (x, n, SOME t) => SOME (x, n, t)) xncs
|
adamc@165
|
1001 in
|
adamc@165
|
1002 box [string "enum",
|
adamc@165
|
1003 space,
|
adamc@311
|
1004 string ("__uwe_" ^ x ^ "_" ^ Int.toString n),
|
adamc@165
|
1005 space,
|
adamc@165
|
1006 string "{",
|
adamc@165
|
1007 space,
|
adamc@311
|
1008 p_list_sep (box [string ",", space]) (fn (x, n, _) => string ("__uwc_" ^ x ^ "_" ^ Int.toString n)) xncs,
|
adamc@165
|
1009 space,
|
adamc@165
|
1010 string "};",
|
adamc@165
|
1011 newline,
|
adamc@165
|
1012 newline,
|
adamc@165
|
1013 string "struct",
|
adamc@165
|
1014 space,
|
adamc@311
|
1015 string ("__uwd_" ^ x ^ "_" ^ Int.toString n),
|
adamc@165
|
1016 space,
|
adamc@165
|
1017 string "{",
|
adamc@165
|
1018 newline,
|
adamc@165
|
1019 string "enum",
|
adamc@165
|
1020 space,
|
adamc@311
|
1021 string ("__uwe_" ^ x ^ "_" ^ Int.toString n),
|
adamc@165
|
1022 space,
|
adamc@165
|
1023 string "tag;",
|
adamc@165
|
1024 newline,
|
adamc@165
|
1025 box (case xncsArgs of
|
adamc@165
|
1026 [] => []
|
adamc@165
|
1027 | _ => [string "union",
|
adamc@165
|
1028 space,
|
adamc@165
|
1029 string "{",
|
adamc@165
|
1030 newline,
|
adamc@165
|
1031 p_list_sep newline (fn (x, n, t) => box [p_typ env t,
|
adamc@165
|
1032 space,
|
adamc@311
|
1033 string ("uw_" ^ x),
|
adamc@165
|
1034 string ";"]) xncsArgs,
|
adamc@165
|
1035 newline,
|
adamc@165
|
1036 string "}",
|
adamc@165
|
1037 space,
|
adamc@165
|
1038 string "data;",
|
adamc@165
|
1039 newline]),
|
adamc@165
|
1040 string "};"]
|
adamc@188
|
1041 end
|
adamc@29
|
1042
|
adamc@196
|
1043 | DDatatypeForward _ => box []
|
adamc@196
|
1044
|
adamc@29
|
1045 | DVal (x, n, t, e) =>
|
adamc@29
|
1046 box [p_typ env t,
|
adamc@29
|
1047 space,
|
adamc@311
|
1048 string ("__uwn_" ^ x ^ "_" ^ Int.toString n),
|
adamc@29
|
1049 space,
|
adamc@29
|
1050 string "=",
|
adamc@29
|
1051 space,
|
adamc@29
|
1052 p_exp env e,
|
adamc@29
|
1053 string ";"]
|
adamc@129
|
1054 | DFun vi => p_fun env vi
|
adamc@129
|
1055 | DFunRec vis =>
|
adamc@29
|
1056 let
|
adamc@129
|
1057 val env = E.declBinds env dAll
|
adamc@29
|
1058 in
|
adamc@129
|
1059 box [p_list_sep newline (fn (fx, n, args, ran, _) =>
|
adamc@129
|
1060 box [string "static",
|
adamc@129
|
1061 space,
|
adamc@129
|
1062 p_typ env ran,
|
adamc@129
|
1063 space,
|
adamc@311
|
1064 string ("__uwn_" ^ fx ^ "_" ^ Int.toString n),
|
adamc@311
|
1065 string "(uw_context,",
|
adamc@129
|
1066 space,
|
adamc@129
|
1067 p_list_sep (box [string ",", space])
|
adamc@129
|
1068 (fn (_, dom) => p_typ env dom) args,
|
adamc@129
|
1069 string ");"]) vis,
|
adamc@29
|
1070 newline,
|
adamc@129
|
1071 p_list_sep newline (p_fun env) vis,
|
adamc@129
|
1072 newline]
|
adamc@29
|
1073 end
|
adamc@273
|
1074 | DTable (x, _) => box [string "/* SQL table ",
|
adamc@273
|
1075 string x,
|
adamc@273
|
1076 string " */",
|
adamc@273
|
1077 newline]
|
adamc@311
|
1078 | DDatabase s => box [string "static void uw_db_validate(uw_context);",
|
adamc@272
|
1079 newline,
|
adamc@311
|
1080 string "static void uw_db_prepare(uw_context);",
|
adamc@282
|
1081 newline,
|
adamc@275
|
1082 newline,
|
adamc@311
|
1083 string "void uw_db_init(uw_context ctx) {",
|
adamc@273
|
1084 newline,
|
adamc@272
|
1085 string "PGconn *conn = PQconnectdb(\"",
|
adamc@272
|
1086 string (String.toString s),
|
adamc@272
|
1087 string "\");",
|
adamc@272
|
1088 newline,
|
adamc@311
|
1089 string "if (conn == NULL) uw_error(ctx, BOUNDED_RETRY, ",
|
adamc@272
|
1090 string "\"libpq can't allocate a connection.\");",
|
adamc@272
|
1091 newline,
|
adamc@272
|
1092 string "if (PQstatus(conn) != CONNECTION_OK) {",
|
adamc@272
|
1093 newline,
|
adamc@272
|
1094 box [string "char msg[1024];",
|
adamc@272
|
1095 newline,
|
adamc@272
|
1096 string "strncpy(msg, PQerrorMessage(conn), 1024);",
|
adamc@272
|
1097 newline,
|
adamc@272
|
1098 string "msg[1023] = 0;",
|
adamc@272
|
1099 newline,
|
adamc@272
|
1100 string "PQfinish(conn);",
|
adamc@272
|
1101 newline,
|
adamc@311
|
1102 string "uw_error(ctx, BOUNDED_RETRY, ",
|
adamc@272
|
1103 string "\"Connection to Postgres server failed: %s\", msg);"],
|
adamc@272
|
1104 newline,
|
adamc@272
|
1105 string "}",
|
adamc@272
|
1106 newline,
|
adamc@311
|
1107 string "uw_set_db(ctx, conn);",
|
adamc@272
|
1108 newline,
|
adamc@311
|
1109 string "uw_db_validate(ctx);",
|
adamc@275
|
1110 newline,
|
adamc@311
|
1111 string "uw_db_prepare(ctx);",
|
adamc@282
|
1112 newline,
|
adamc@272
|
1113 string "}",
|
adamc@272
|
1114 newline,
|
adamc@272
|
1115 newline,
|
adamc@311
|
1116 string "void uw_db_close(uw_context ctx) {",
|
adamc@272
|
1117 newline,
|
adamc@311
|
1118 string "PQfinish(uw_get_db(ctx));",
|
adamc@272
|
1119 newline,
|
adamc@272
|
1120 string "}",
|
adamc@272
|
1121 newline]
|
adamc@29
|
1122
|
adamc@282
|
1123 | DPreparedStatements ss =>
|
adamc@311
|
1124 box [string "static void uw_db_prepare(uw_context ctx) {",
|
adamc@282
|
1125 newline,
|
adamc@311
|
1126 string "PGconn *conn = uw_get_db(ctx);",
|
adamc@282
|
1127 newline,
|
adamc@282
|
1128 string "PGresult *res;",
|
adamc@282
|
1129 newline,
|
adamc@282
|
1130 newline,
|
adamc@282
|
1131
|
adamc@282
|
1132 p_list_sepi newline (fn i => fn (s, n) =>
|
adamc@311
|
1133 box [string "res = PQprepare(conn, \"uw",
|
adamc@282
|
1134 string (Int.toString i),
|
adamc@282
|
1135 string "\", \"",
|
adamc@282
|
1136 string (String.toString s),
|
adamc@282
|
1137 string "\", ",
|
adamc@282
|
1138 string (Int.toString n),
|
adamc@282
|
1139 string ", NULL);",
|
adamc@282
|
1140 newline,
|
adamc@282
|
1141 string "if (PQresultStatus(res) != PGRES_COMMAND_OK) {",
|
adamc@282
|
1142 newline,
|
adamc@282
|
1143 box [string "char msg[1024];",
|
adamc@282
|
1144 newline,
|
adamc@282
|
1145 string "strncpy(msg, PQerrorMessage(conn), 1024);",
|
adamc@282
|
1146 newline,
|
adamc@282
|
1147 string "msg[1023] = 0;",
|
adamc@282
|
1148 newline,
|
adamc@282
|
1149 string "PQclear(res);",
|
adamc@282
|
1150 newline,
|
adamc@282
|
1151 string "PQfinish(conn);",
|
adamc@282
|
1152 newline,
|
adamc@311
|
1153 string "uw_error(ctx, FATAL, \"Unable to create prepared statement:\\n",
|
adamc@282
|
1154 string (String.toString s),
|
adamc@282
|
1155 string "\\n%s\", msg);",
|
adamc@282
|
1156 newline],
|
adamc@282
|
1157 string "}",
|
adamc@282
|
1158 newline,
|
adamc@282
|
1159 string "PQclear(res);",
|
adamc@282
|
1160 newline])
|
adamc@282
|
1161 ss,
|
adamc@282
|
1162
|
adamc@282
|
1163 string "}"]
|
adamc@282
|
1164
|
adamc@144
|
1165 datatype 'a search =
|
adamc@144
|
1166 Found of 'a
|
adamc@144
|
1167 | NotFound
|
adamc@144
|
1168 | Error
|
adamc@120
|
1169
|
adamc@275
|
1170 fun p_sqltype' env (tAll as (t, loc)) =
|
adamc@275
|
1171 case t of
|
adamc@275
|
1172 TFfi ("Basis", "int") => "int8"
|
adamc@275
|
1173 | TFfi ("Basis", "float") => "float8"
|
adamc@275
|
1174 | TFfi ("Basis", "string") => "text"
|
adamc@275
|
1175 | TFfi ("Basis", "bool") => "bool"
|
adamc@275
|
1176 | _ => (ErrorMsg.errorAt loc "Don't know SQL equivalent of type";
|
adamc@275
|
1177 Print.eprefaces' [("Type", p_typ env tAll)];
|
adamc@275
|
1178 "ERROR")
|
adamc@275
|
1179
|
adamc@275
|
1180 fun p_sqltype env t = string (p_sqltype' env t)
|
adamc@101
|
1181
|
adamc@101
|
1182 fun p_file env (ds, ps) =
|
adamc@29
|
1183 let
|
adamc@101
|
1184 val (pds, env) = ListUtil.foldlMap (fn (d, env) =>
|
adamc@31
|
1185 (p_decl env d,
|
adamc@31
|
1186 E.declBinds env d))
|
adamc@101
|
1187 env ds
|
adamc@144
|
1188
|
adamc@144
|
1189 val fields = foldl (fn ((ek, _, _, ts), fields) =>
|
adamc@144
|
1190 case ek of
|
adamc@144
|
1191 Core.Link => fields
|
adamc@144
|
1192 | Core.Action =>
|
adamc@280
|
1193 case List.nth (ts, length ts - 2) of
|
adamc@144
|
1194 (TRecord i, _) =>
|
adamc@144
|
1195 let
|
adamc@144
|
1196 val xts = E.lookupStruct env i
|
adamc@144
|
1197 val xtsSet = SS.addList (SS.empty, map #1 xts)
|
adamc@144
|
1198 in
|
adamc@144
|
1199 foldl (fn ((x, _), fields) =>
|
adamc@144
|
1200 let
|
adamc@144
|
1201 val xtsSet' = Option.getOpt (SM.find (fields, x), SS.empty)
|
adamc@144
|
1202 in
|
adamc@144
|
1203 SM.insert (fields, x, SS.union (SS.delete (xtsSet, x),
|
adamc@144
|
1204 xtsSet'))
|
adamc@144
|
1205 end) fields xts
|
adamc@144
|
1206 end
|
adamc@144
|
1207 | _ => raise Fail "CjrPrint: Last argument of action isn't record")
|
adamc@144
|
1208 SM.empty ps
|
adamc@144
|
1209
|
adamc@144
|
1210 val fnums = SM.foldli (fn (x, xs, fnums) =>
|
adamc@144
|
1211 let
|
adamc@144
|
1212 val unusable = SS.foldl (fn (x', unusable) =>
|
adamc@144
|
1213 case SM.find (fnums, x') of
|
adamc@144
|
1214 NONE => unusable
|
adamc@144
|
1215 | SOME n => IS.add (unusable, n))
|
adamc@144
|
1216 IS.empty xs
|
adamc@144
|
1217
|
adamc@144
|
1218 fun findAvailable n =
|
adamc@144
|
1219 if IS.member (unusable, n) then
|
adamc@144
|
1220 findAvailable (n + 1)
|
adamc@144
|
1221 else
|
adamc@144
|
1222 n
|
adamc@144
|
1223 in
|
adamc@144
|
1224 SM.insert (fnums, x, findAvailable 0)
|
adamc@144
|
1225 end)
|
adamc@144
|
1226 SM.empty fields
|
adamc@144
|
1227
|
adamc@144
|
1228 fun makeSwitch (fnums, i) =
|
adamc@144
|
1229 case SM.foldl (fn (n, NotFound) => Found n
|
adamc@144
|
1230 | (n, Error) => Error
|
adamc@144
|
1231 | (n, Found n') => if n = n' then
|
adamc@144
|
1232 Found n'
|
adamc@144
|
1233 else
|
adamc@144
|
1234 Error) NotFound fnums of
|
adamc@144
|
1235 NotFound => box [string "return",
|
adamc@144
|
1236 space,
|
adamc@144
|
1237 string "-1;"]
|
adamc@144
|
1238 | Found n => box [string "return",
|
adamc@144
|
1239 space,
|
adamc@144
|
1240 string (Int.toString n),
|
adamc@144
|
1241 string ";"]
|
adamc@144
|
1242 | Error =>
|
adamc@144
|
1243 let
|
adamc@144
|
1244 val cmap = SM.foldli (fn (x, n, cmap) =>
|
adamc@144
|
1245 let
|
adamc@144
|
1246 val ch = if i < size x then
|
adamc@144
|
1247 String.sub (x, i)
|
adamc@144
|
1248 else
|
adamc@144
|
1249 chr 0
|
adamc@144
|
1250
|
adamc@144
|
1251 val fnums = case CM.find (cmap, ch) of
|
adamc@144
|
1252 NONE => SM.empty
|
adamc@144
|
1253 | SOME fnums => fnums
|
adamc@144
|
1254 val fnums = SM.insert (fnums, x, n)
|
adamc@144
|
1255 in
|
adamc@144
|
1256 CM.insert (cmap, ch, fnums)
|
adamc@144
|
1257 end)
|
adamc@144
|
1258 CM.empty fnums
|
adamc@144
|
1259
|
adamc@144
|
1260 val cmap = CM.listItemsi cmap
|
adamc@144
|
1261 in
|
adamc@144
|
1262 case cmap of
|
adamc@144
|
1263 [(_, fnums)] =>
|
adamc@144
|
1264 box [string "if",
|
adamc@144
|
1265 space,
|
adamc@144
|
1266 string "(name[",
|
adamc@144
|
1267 string (Int.toString i),
|
adamc@144
|
1268 string "]",
|
adamc@144
|
1269 space,
|
adamc@144
|
1270 string "==",
|
adamc@144
|
1271 space,
|
adamc@144
|
1272 string "0)",
|
adamc@144
|
1273 space,
|
adamc@144
|
1274 string "return",
|
adamc@144
|
1275 space,
|
adamc@144
|
1276 string "-1;",
|
adamc@144
|
1277 newline,
|
adamc@144
|
1278 makeSwitch (fnums, i+1)]
|
adamc@144
|
1279 | _ =>
|
adamc@144
|
1280 box [string "switch",
|
adamc@144
|
1281 space,
|
adamc@144
|
1282 string "(name[",
|
adamc@144
|
1283 string (Int.toString i),
|
adamc@144
|
1284 string "])",
|
adamc@144
|
1285 space,
|
adamc@144
|
1286 string "{",
|
adamc@144
|
1287 newline,
|
adamc@144
|
1288 box (map (fn (ch, fnums) =>
|
adamc@144
|
1289 box [string "case",
|
adamc@144
|
1290 space,
|
adamc@144
|
1291 if ch = chr 0 then
|
adamc@144
|
1292 string "0:"
|
adamc@144
|
1293 else
|
adamc@144
|
1294 box [string "'",
|
adamc@144
|
1295 string (Char.toString ch),
|
adamc@144
|
1296 string "':"],
|
adamc@144
|
1297 newline,
|
adamc@144
|
1298 makeSwitch (fnums, i+1),
|
adamc@144
|
1299 newline]) cmap),
|
adamc@144
|
1300 string "default:",
|
adamc@144
|
1301 newline,
|
adamc@144
|
1302 string "return",
|
adamc@144
|
1303 space,
|
adamc@144
|
1304 string "-1;",
|
adamc@144
|
1305 newline,
|
adamc@144
|
1306 string "}"]
|
adamc@144
|
1307 end
|
adamc@144
|
1308
|
adamc@186
|
1309 fun capitalize s =
|
adamc@186
|
1310 if s = "" then
|
adamc@186
|
1311 ""
|
adamc@186
|
1312 else
|
adamc@186
|
1313 str (Char.toUpper (String.sub (s, 0))) ^ String.extract (s, 1, NONE)
|
adamc@186
|
1314
|
adamc@144
|
1315 fun unurlify (t, loc) =
|
adamc@144
|
1316 case t of
|
adamc@311
|
1317 TFfi (m, t) => string ("uw_" ^ m ^ "_unurlify" ^ capitalize t ^ "(ctx, &request)")
|
adamc@144
|
1318
|
adamc@311
|
1319 | TRecord 0 => string "uw_unit_v"
|
adamc@144
|
1320 | TRecord i =>
|
adamc@144
|
1321 let
|
adamc@144
|
1322 val xts = E.lookupStruct env i
|
adamc@144
|
1323 in
|
adamc@144
|
1324 box [string "({",
|
adamc@144
|
1325 newline,
|
adamc@144
|
1326 box (map (fn (x, t) =>
|
adamc@144
|
1327 box [p_typ env t,
|
adamc@144
|
1328 space,
|
adamc@144
|
1329 string x,
|
adamc@144
|
1330 space,
|
adamc@144
|
1331 string "=",
|
adamc@144
|
1332 space,
|
adamc@144
|
1333 unurlify t,
|
adamc@144
|
1334 string ";",
|
adamc@144
|
1335 newline]) xts),
|
adamc@144
|
1336 string "struct",
|
adamc@144
|
1337 space,
|
adamc@311
|
1338 string "__uws_",
|
adamc@144
|
1339 string (Int.toString i),
|
adamc@144
|
1340 space,
|
adamc@181
|
1341 string "tmp",
|
adamc@144
|
1342 space,
|
adamc@144
|
1343 string "=",
|
adamc@144
|
1344 space,
|
adamc@144
|
1345 string "{",
|
adamc@144
|
1346 space,
|
adamc@144
|
1347 p_list_sep (box [string ",", space]) (fn (x, _) => string x) xts,
|
adamc@144
|
1348 space,
|
adamc@144
|
1349 string "};",
|
adamc@144
|
1350 newline,
|
adamc@181
|
1351 string "tmp;",
|
adamc@144
|
1352 newline,
|
adamc@144
|
1353 string "})"]
|
adamc@144
|
1354 end
|
adamc@144
|
1355
|
adamc@188
|
1356 | TDatatype (Enum, i, _) =>
|
adamc@188
|
1357 let
|
adamc@188
|
1358 val (x, xncs) = E.lookupDatatype env i
|
adamc@188
|
1359
|
adamc@188
|
1360 fun doEm xncs =
|
adamc@188
|
1361 case xncs of
|
adamc@311
|
1362 [] => string ("(uw_error(ctx, FATAL, \"Error unurlifying datatype " ^ x ^ "\"), (enum __uwe_"
|
adamc@188
|
1363 ^ x ^ "_" ^ Int.toString i ^ ")0)")
|
adamc@188
|
1364 | (x', n, to) :: rest =>
|
adamc@188
|
1365 box [string "((!strncmp(request, \"",
|
adamc@188
|
1366 string x',
|
adamc@188
|
1367 string "\", ",
|
adamc@188
|
1368 string (Int.toString (size x')),
|
adamc@188
|
1369 string ") && (request[",
|
adamc@188
|
1370 string (Int.toString (size x')),
|
adamc@188
|
1371 string "] == 0 || request[",
|
adamc@188
|
1372 string (Int.toString (size x')),
|
adamc@311
|
1373 string ("] == '/')) ? __uwc_" ^ x' ^ "_" ^ Int.toString n),
|
adamc@188
|
1374 space,
|
adamc@188
|
1375 string ":",
|
adamc@188
|
1376 space,
|
adamc@188
|
1377 doEm rest,
|
adamc@188
|
1378 string ")"]
|
adamc@188
|
1379 in
|
adamc@188
|
1380 doEm xncs
|
adamc@188
|
1381 end
|
adamc@188
|
1382
|
adamc@198
|
1383 | TDatatype (Option, i, xncs) =>
|
adamc@198
|
1384 let
|
adamc@198
|
1385 val (x, _) = E.lookupDatatype env i
|
adamc@198
|
1386
|
adamc@198
|
1387 val (no_arg, has_arg, t) =
|
adamc@198
|
1388 case !xncs of
|
adamc@198
|
1389 [(no_arg, _, NONE), (has_arg, _, SOME t)] =>
|
adamc@198
|
1390 (no_arg, has_arg, t)
|
adamc@198
|
1391 | [(has_arg, _, SOME t), (no_arg, _, NONE)] =>
|
adamc@198
|
1392 (no_arg, has_arg, t)
|
adamc@198
|
1393 | _ => raise Fail "CjrPrint: unfooify misclassified Option datatype"
|
adamc@198
|
1394 in
|
adamc@198
|
1395 box [string "(request[0] == '/' ? ++request : request,",
|
adamc@198
|
1396 newline,
|
adamc@198
|
1397 string "((!strncmp(request, \"",
|
adamc@198
|
1398 string no_arg,
|
adamc@198
|
1399 string "\", ",
|
adamc@198
|
1400 string (Int.toString (size no_arg)),
|
adamc@198
|
1401 string ") && (request[",
|
adamc@198
|
1402 string (Int.toString (size no_arg)),
|
adamc@198
|
1403 string "] == 0 || request[",
|
adamc@198
|
1404 string (Int.toString (size no_arg)),
|
adamc@198
|
1405 string "] == '/')) ? (request",
|
adamc@198
|
1406 space,
|
adamc@198
|
1407 string "+=",
|
adamc@198
|
1408 space,
|
adamc@198
|
1409 string (Int.toString (size no_arg)),
|
adamc@198
|
1410 string ", NULL) : ((!strncmp(request, \"",
|
adamc@198
|
1411 string has_arg,
|
adamc@198
|
1412 string "\", ",
|
adamc@198
|
1413 string (Int.toString (size has_arg)),
|
adamc@198
|
1414 string ") && (request[",
|
adamc@198
|
1415 string (Int.toString (size has_arg)),
|
adamc@198
|
1416 string "] == 0 || request[",
|
adamc@198
|
1417 string (Int.toString (size has_arg)),
|
adamc@198
|
1418 string "] == '/')) ? (request",
|
adamc@198
|
1419 space,
|
adamc@198
|
1420 string "+=",
|
adamc@198
|
1421 space,
|
adamc@198
|
1422 string (Int.toString (size has_arg)),
|
adamc@200
|
1423 string ", (request[0] == '/' ? ++request : NULL), ",
|
adamc@200
|
1424 newline,
|
adamc@198
|
1425
|
adamc@198
|
1426 case #1 t of
|
adamc@198
|
1427 TDatatype _ => unurlify t
|
adamc@199
|
1428 | TFfi ("Basis", "string") => unurlify t
|
adamc@198
|
1429 | _ => box [string "({",
|
adamc@198
|
1430 newline,
|
adamc@198
|
1431 p_typ env t,
|
adamc@198
|
1432 space,
|
adamc@198
|
1433 string "*tmp",
|
adamc@198
|
1434 space,
|
adamc@198
|
1435 string "=",
|
adamc@198
|
1436 space,
|
adamc@311
|
1437 string "uw_malloc(ctx, sizeof(",
|
adamc@198
|
1438 p_typ env t,
|
adamc@198
|
1439 string "));",
|
adamc@198
|
1440 newline,
|
adamc@198
|
1441 string "*tmp",
|
adamc@198
|
1442 space,
|
adamc@198
|
1443 string "=",
|
adamc@198
|
1444 space,
|
adamc@198
|
1445 unurlify t,
|
adamc@198
|
1446 string ";",
|
adamc@198
|
1447 newline,
|
adamc@198
|
1448 string "tmp;",
|
adamc@198
|
1449 newline,
|
adamc@198
|
1450 string "})"],
|
adamc@198
|
1451 string ")",
|
adamc@198
|
1452 newline,
|
adamc@198
|
1453 string ":",
|
adamc@198
|
1454 space,
|
adamc@311
|
1455 string ("(uw_error(ctx, FATAL, \"Error unurlifying datatype " ^ x ^ "\"), NULL))))")]
|
adamc@198
|
1456 end
|
adamc@198
|
1457
|
adamc@188
|
1458 | TDatatype (Default, i, _) =>
|
adamc@166
|
1459 let
|
adamc@166
|
1460 val (x, xncs) = E.lookupDatatype env i
|
adamc@166
|
1461
|
adamc@166
|
1462 fun doEm xncs =
|
adamc@166
|
1463 case xncs of
|
adamc@311
|
1464 [] => string ("(uw_error(ctx, FATAL, \"Error unurlifying datatype " ^ x ^ "\"), NULL)")
|
adamc@167
|
1465 | (x', n, to) :: rest =>
|
adamc@167
|
1466 box [string "((!strncmp(request, \"",
|
adamc@167
|
1467 string x',
|
adamc@167
|
1468 string "\", ",
|
adamc@167
|
1469 string (Int.toString (size x')),
|
adamc@167
|
1470 string ") && (request[",
|
adamc@167
|
1471 string (Int.toString (size x')),
|
adamc@167
|
1472 string "] == 0 || request[",
|
adamc@167
|
1473 string (Int.toString (size x')),
|
adamc@167
|
1474 string "] == '/')) ? ({",
|
adamc@166
|
1475 newline,
|
adamc@167
|
1476 string "struct",
|
adamc@167
|
1477 space,
|
adamc@311
|
1478 string ("__uwd_" ^ x ^ "_" ^ Int.toString i),
|
adamc@166
|
1479 space,
|
adamc@311
|
1480 string "*tmp = uw_malloc(ctx, sizeof(struct __uwd_",
|
adamc@167
|
1481 string x,
|
adamc@167
|
1482 string "_",
|
adamc@167
|
1483 string (Int.toString i),
|
adamc@167
|
1484 string "));",
|
adamc@166
|
1485 newline,
|
adamc@181
|
1486 string "tmp->tag",
|
adamc@166
|
1487 space,
|
adamc@166
|
1488 string "=",
|
adamc@166
|
1489 space,
|
adamc@311
|
1490 string ("__uwc_" ^ x' ^ "_" ^ Int.toString n),
|
adamc@166
|
1491 string ";",
|
adamc@166
|
1492 newline,
|
adamc@166
|
1493 string "request",
|
adamc@166
|
1494 space,
|
adamc@166
|
1495 string "+=",
|
adamc@166
|
1496 space,
|
adamc@167
|
1497 string (Int.toString (size x')),
|
adamc@166
|
1498 string ";",
|
adamc@166
|
1499 newline,
|
adamc@200
|
1500 string "if (request[0] == '/') ++request;",
|
adamc@200
|
1501 newline,
|
adamc@166
|
1502 case to of
|
adamc@166
|
1503 NONE => box []
|
adamc@311
|
1504 | SOME t => box [string "tmp->data.uw_",
|
adamc@167
|
1505 string x',
|
adamc@166
|
1506 space,
|
adamc@166
|
1507 string "=",
|
adamc@166
|
1508 space,
|
adamc@166
|
1509 unurlify t,
|
adamc@166
|
1510 string ";",
|
adamc@166
|
1511 newline],
|
adamc@181
|
1512 string "tmp;",
|
adamc@166
|
1513 newline,
|
adamc@166
|
1514 string "})",
|
adamc@166
|
1515 space,
|
adamc@166
|
1516 string ":",
|
adamc@166
|
1517 space,
|
adamc@166
|
1518 doEm rest,
|
adamc@166
|
1519 string ")"]
|
adamc@166
|
1520 in
|
adamc@166
|
1521 doEm xncs
|
adamc@166
|
1522 end
|
adamc@166
|
1523
|
adamc@144
|
1524 | _ => (ErrorMsg.errorAt loc "Unable to choose a URL decoding function";
|
adamc@144
|
1525 space)
|
adamc@144
|
1526
|
adamc@144
|
1527
|
adamc@144
|
1528 fun p_page (ek, s, n, ts) =
|
adamc@144
|
1529 let
|
adamc@144
|
1530 val (ts, defInputs, inputsVar) =
|
adamc@144
|
1531 case ek of
|
adamc@314
|
1532 Core.Link => (List.take (ts, length ts - 1), string "", string "")
|
adamc@144
|
1533 | Core.Action =>
|
adamc@280
|
1534 case List.nth (ts, length ts - 2) of
|
adamc@144
|
1535 (TRecord i, _) =>
|
adamc@144
|
1536 let
|
adamc@144
|
1537 val xts = E.lookupStruct env i
|
adamc@144
|
1538 in
|
adamc@280
|
1539 (List.take (ts, length ts - 2),
|
adamc@144
|
1540 box [box (map (fn (x, t) => box [p_typ env t,
|
adamc@144
|
1541 space,
|
adamc@311
|
1542 string "uw_input_",
|
adamc@144
|
1543 string x,
|
adamc@144
|
1544 string ";",
|
adamc@144
|
1545 newline]) xts),
|
adamc@144
|
1546 newline,
|
adamc@144
|
1547 box (map (fn (x, t) =>
|
adamc@144
|
1548 let
|
adamc@144
|
1549 val n = case SM.find (fnums, x) of
|
adamc@144
|
1550 NONE => raise Fail "CjrPrint: Can't find in fnums"
|
adamc@144
|
1551 | SOME n => n
|
adamc@190
|
1552
|
adamc@190
|
1553 val f = case t of
|
adamc@190
|
1554 (TFfi ("Basis", "bool"), _) => "optional_"
|
adamc@190
|
1555 | _ => ""
|
adamc@144
|
1556 in
|
adamc@311
|
1557 box [string "request = uw_get_",
|
adamc@190
|
1558 string f,
|
adamc@190
|
1559 string "input(ctx, ",
|
adamc@144
|
1560 string (Int.toString n),
|
adamc@144
|
1561 string ");",
|
adamc@144
|
1562 newline,
|
adamc@144
|
1563 string "if (request == NULL) {",
|
adamc@144
|
1564 newline,
|
adamc@144
|
1565 box [string "printf(\"Missing input ",
|
adamc@144
|
1566 string x,
|
adamc@144
|
1567 string "\\n\");",
|
adamc@144
|
1568 newline,
|
adamc@144
|
1569 string "exit(1);"],
|
adamc@144
|
1570 newline,
|
adamc@144
|
1571 string "}",
|
adamc@144
|
1572 newline,
|
adamc@311
|
1573 string "uw_input_",
|
adamc@144
|
1574 string x,
|
adamc@144
|
1575 space,
|
adamc@144
|
1576 string "=",
|
adamc@144
|
1577 space,
|
adamc@144
|
1578 unurlify t,
|
adamc@144
|
1579 string ";",
|
adamc@144
|
1580 newline]
|
adamc@144
|
1581 end) xts),
|
adamc@311
|
1582 string "struct __uws_",
|
adamc@144
|
1583 string (Int.toString i),
|
adamc@144
|
1584 space,
|
adamc@311
|
1585 string "uw_inputs",
|
adamc@144
|
1586 space,
|
adamc@144
|
1587 string "= {",
|
adamc@144
|
1588 newline,
|
adamc@311
|
1589 box (map (fn (x, _) => box [string "uw_input_",
|
adamc@144
|
1590 string x,
|
adamc@144
|
1591 string ",",
|
adamc@144
|
1592 newline]) xts),
|
adamc@144
|
1593 string "};",
|
adamc@144
|
1594 newline],
|
adamc@144
|
1595 box [string ",",
|
adamc@144
|
1596 space,
|
adamc@311
|
1597 string "uw_inputs"])
|
adamc@144
|
1598 end
|
adamc@144
|
1599
|
adamc@144
|
1600 | _ => raise Fail "CjrPrint: Last argument to an action isn't a record"
|
adamc@144
|
1601 in
|
adamc@144
|
1602 box [string "if (!strncmp(request, \"",
|
adamc@144
|
1603 string (String.toString s),
|
adamc@144
|
1604 string "\", ",
|
adamc@144
|
1605 string (Int.toString (size s)),
|
adamc@198
|
1606 string ") && (request[",
|
adamc@198
|
1607 string (Int.toString (size s)),
|
adamc@198
|
1608 string "] == 0 || request[",
|
adamc@198
|
1609 string (Int.toString (size s)),
|
adamc@198
|
1610 string "] == '/')) {",
|
adamc@144
|
1611 newline,
|
adamc@144
|
1612 string "request += ",
|
adamc@144
|
1613 string (Int.toString (size s)),
|
adamc@144
|
1614 string ";",
|
adamc@144
|
1615 newline,
|
adamc@144
|
1616 string "if (*request == '/') ++request;",
|
adamc@144
|
1617 newline,
|
adamc@144
|
1618 box [string "{",
|
adamc@144
|
1619 newline,
|
adamc@144
|
1620 box (ListUtil.mapi (fn (i, t) => box [p_typ env t,
|
adamc@144
|
1621 space,
|
adamc@144
|
1622 string "arg",
|
adamc@144
|
1623 string (Int.toString i),
|
adamc@144
|
1624 space,
|
adamc@144
|
1625 string "=",
|
adamc@144
|
1626 space,
|
adamc@144
|
1627 unurlify t,
|
adamc@144
|
1628 string ";",
|
adamc@144
|
1629 newline]) ts),
|
adamc@144
|
1630 defInputs,
|
adamc@144
|
1631 p_enamed env n,
|
adamc@144
|
1632 string "(",
|
adamc@144
|
1633 p_list_sep (box [string ",", space])
|
adamc@144
|
1634 (fn x => x)
|
adamc@272
|
1635 (string "ctx"
|
adamc@280
|
1636 :: ListUtil.mapi (fn (i, _) => string ("arg" ^ Int.toString i)) ts),
|
adamc@144
|
1637 inputsVar,
|
adamc@311
|
1638 string ", uw_unit_v);",
|
adamc@144
|
1639 newline,
|
adamc@144
|
1640 string "return;",
|
adamc@144
|
1641 newline,
|
adamc@144
|
1642 string "}",
|
adamc@144
|
1643 newline,
|
adamc@144
|
1644 string "}"]
|
adamc@144
|
1645 ]
|
adamc@144
|
1646 end
|
adamc@144
|
1647
|
adamc@144
|
1648 val pds' = map p_page ps
|
adamc@275
|
1649
|
adamc@275
|
1650 val tables = List.mapPartial (fn (DTable (s, xts), _) => SOME (s, xts)
|
adamc@275
|
1651 | _ => NONE) ds
|
adamc@275
|
1652
|
adamc@275
|
1653 val validate =
|
adamc@311
|
1654 box [string "static void uw_db_validate(uw_context ctx) {",
|
adamc@275
|
1655 newline,
|
adamc@311
|
1656 string "PGconn *conn = uw_get_db(ctx);",
|
adamc@275
|
1657 newline,
|
adamc@275
|
1658 string "PGresult *res;",
|
adamc@275
|
1659 newline,
|
adamc@275
|
1660 newline,
|
adamc@275
|
1661 p_list_sep newline
|
adamc@275
|
1662 (fn (s, xts) =>
|
adamc@275
|
1663 let
|
adamc@275
|
1664 val q = "SELECT COUNT(*) FROM pg_class WHERE relname = '"
|
adamc@275
|
1665 ^ s ^ "'"
|
adamc@275
|
1666
|
adamc@275
|
1667 val q' = String.concat ["SELECT COUNT(*) FROM pg_attribute WHERE attrelid = (SELECT oid FROM pg_class WHERE relname = '",
|
adamc@275
|
1668 s,
|
adamc@275
|
1669 "') AND (",
|
adamc@275
|
1670 String.concatWith " OR "
|
adamc@275
|
1671 (map (fn (x, t) =>
|
adamc@311
|
1672 String.concat ["(attname = 'uw_",
|
adamc@275
|
1673 CharVector.map
|
adamc@275
|
1674 Char.toLower x,
|
adamc@275
|
1675 "' AND atttypid = (SELECT oid FROM pg_type",
|
adamc@275
|
1676 " WHERE typname = '",
|
adamc@275
|
1677 p_sqltype' env t,
|
adamc@275
|
1678 "'))"]) xts),
|
adamc@275
|
1679 ")"]
|
adamc@275
|
1680
|
adamc@275
|
1681 val q'' = String.concat ["SELECT COUNT(*) FROM pg_attribute WHERE attrelid = (SELECT oid FROM pg_class WHERE relname = '",
|
adamc@275
|
1682 s,
|
adamc@275
|
1683 "') AND attnum >= 0"]
|
adamc@275
|
1684 in
|
adamc@275
|
1685 box [string "res = PQexec(conn, \"",
|
adamc@275
|
1686 string q,
|
adamc@275
|
1687 string "\");",
|
adamc@275
|
1688 newline,
|
adamc@275
|
1689 newline,
|
adamc@275
|
1690 string "if (res == NULL) {",
|
adamc@275
|
1691 newline,
|
adamc@275
|
1692 box [string "PQfinish(conn);",
|
adamc@275
|
1693 newline,
|
adamc@311
|
1694 string "uw_error(ctx, FATAL, \"Out of memory allocating query result.\");",
|
adamc@275
|
1695 newline],
|
adamc@275
|
1696 string "}",
|
adamc@275
|
1697 newline,
|
adamc@275
|
1698 newline,
|
adamc@275
|
1699 string "if (PQresultStatus(res) != PGRES_TUPLES_OK) {",
|
adamc@275
|
1700 newline,
|
adamc@275
|
1701 box [string "char msg[1024];",
|
adamc@275
|
1702 newline,
|
adamc@275
|
1703 string "strncpy(msg, PQerrorMessage(conn), 1024);",
|
adamc@275
|
1704 newline,
|
adamc@275
|
1705 string "msg[1023] = 0;",
|
adamc@275
|
1706 newline,
|
adamc@275
|
1707 string "PQclear(res);",
|
adamc@275
|
1708 newline,
|
adamc@275
|
1709 string "PQfinish(conn);",
|
adamc@275
|
1710 newline,
|
adamc@311
|
1711 string "uw_error(ctx, FATAL, \"Query failed:\\n",
|
adamc@275
|
1712 string q,
|
adamc@275
|
1713 string "\\n%s\", msg);",
|
adamc@275
|
1714 newline],
|
adamc@275
|
1715 string "}",
|
adamc@275
|
1716 newline,
|
adamc@275
|
1717 newline,
|
adamc@275
|
1718 string "if (strcmp(PQgetvalue(res, 0, 0), \"1\")) {",
|
adamc@275
|
1719 newline,
|
adamc@275
|
1720 box [string "PQclear(res);",
|
adamc@275
|
1721 newline,
|
adamc@275
|
1722 string "PQfinish(conn);",
|
adamc@275
|
1723 newline,
|
adamc@311
|
1724 string "uw_error(ctx, FATAL, \"Table '",
|
adamc@275
|
1725 string s,
|
adamc@275
|
1726 string "' does not exist.\");",
|
adamc@275
|
1727 newline],
|
adamc@275
|
1728 string "}",
|
adamc@275
|
1729 newline,
|
adamc@275
|
1730 newline,
|
adamc@275
|
1731 string "PQclear(res);",
|
adamc@275
|
1732 newline,
|
adamc@275
|
1733
|
adamc@275
|
1734 string "res = PQexec(conn, \"",
|
adamc@275
|
1735 string q',
|
adamc@275
|
1736 string "\");",
|
adamc@275
|
1737 newline,
|
adamc@275
|
1738 newline,
|
adamc@275
|
1739 string "if (res == NULL) {",
|
adamc@275
|
1740 newline,
|
adamc@275
|
1741 box [string "PQfinish(conn);",
|
adamc@275
|
1742 newline,
|
adamc@311
|
1743 string "uw_error(ctx, FATAL, \"Out of memory allocating query result.\");",
|
adamc@275
|
1744 newline],
|
adamc@275
|
1745 string "}",
|
adamc@275
|
1746 newline,
|
adamc@275
|
1747 newline,
|
adamc@275
|
1748 string "if (PQresultStatus(res) != PGRES_TUPLES_OK) {",
|
adamc@275
|
1749 newline,
|
adamc@275
|
1750 box [string "char msg[1024];",
|
adamc@275
|
1751 newline,
|
adamc@275
|
1752 string "strncpy(msg, PQerrorMessage(conn), 1024);",
|
adamc@275
|
1753 newline,
|
adamc@275
|
1754 string "msg[1023] = 0;",
|
adamc@275
|
1755 newline,
|
adamc@275
|
1756 string "PQclear(res);",
|
adamc@275
|
1757 newline,
|
adamc@275
|
1758 string "PQfinish(conn);",
|
adamc@275
|
1759 newline,
|
adamc@311
|
1760 string "uw_error(ctx, FATAL, \"Query failed:\\n",
|
adamc@275
|
1761 string q',
|
adamc@275
|
1762 string "\\n%s\", msg);",
|
adamc@275
|
1763 newline],
|
adamc@275
|
1764 string "}",
|
adamc@275
|
1765 newline,
|
adamc@275
|
1766 newline,
|
adamc@275
|
1767 string "if (strcmp(PQgetvalue(res, 0, 0), \"",
|
adamc@275
|
1768 string (Int.toString (length xts)),
|
adamc@275
|
1769 string "\")) {",
|
adamc@275
|
1770 newline,
|
adamc@275
|
1771 box [string "PQclear(res);",
|
adamc@275
|
1772 newline,
|
adamc@275
|
1773 string "PQfinish(conn);",
|
adamc@275
|
1774 newline,
|
adamc@311
|
1775 string "uw_error(ctx, FATAL, \"Table '",
|
adamc@275
|
1776 string s,
|
adamc@275
|
1777 string "' has the wrong column types.\");",
|
adamc@275
|
1778 newline],
|
adamc@275
|
1779 string "}",
|
adamc@275
|
1780 newline,
|
adamc@275
|
1781 newline,
|
adamc@275
|
1782 string "PQclear(res);",
|
adamc@275
|
1783 newline,
|
adamc@275
|
1784 newline,
|
adamc@275
|
1785
|
adamc@275
|
1786 string "res = PQexec(conn, \"",
|
adamc@275
|
1787 string q'',
|
adamc@275
|
1788 string "\");",
|
adamc@275
|
1789 newline,
|
adamc@275
|
1790 newline,
|
adamc@275
|
1791 string "if (res == NULL) {",
|
adamc@275
|
1792 newline,
|
adamc@275
|
1793 box [string "PQfinish(conn);",
|
adamc@275
|
1794 newline,
|
adamc@311
|
1795 string "uw_error(ctx, FATAL, \"Out of memory allocating query result.\");",
|
adamc@275
|
1796 newline],
|
adamc@275
|
1797 string "}",
|
adamc@275
|
1798 newline,
|
adamc@275
|
1799 newline,
|
adamc@275
|
1800 string "if (PQresultStatus(res) != PGRES_TUPLES_OK) {",
|
adamc@275
|
1801 newline,
|
adamc@275
|
1802 box [string "char msg[1024];",
|
adamc@275
|
1803 newline,
|
adamc@275
|
1804 string "strncpy(msg, PQerrorMessage(conn), 1024);",
|
adamc@275
|
1805 newline,
|
adamc@275
|
1806 string "msg[1023] = 0;",
|
adamc@275
|
1807 newline,
|
adamc@275
|
1808 string "PQclear(res);",
|
adamc@275
|
1809 newline,
|
adamc@275
|
1810 string "PQfinish(conn);",
|
adamc@275
|
1811 newline,
|
adamc@311
|
1812 string "uw_error(ctx, FATAL, \"Query failed:\\n",
|
adamc@275
|
1813 string q'',
|
adamc@275
|
1814 string "\\n%s\", msg);",
|
adamc@275
|
1815 newline],
|
adamc@275
|
1816 string "}",
|
adamc@275
|
1817 newline,
|
adamc@275
|
1818 newline,
|
adamc@275
|
1819 string "if (strcmp(PQgetvalue(res, 0, 0), \"",
|
adamc@275
|
1820 string (Int.toString (length xts)),
|
adamc@275
|
1821 string "\")) {",
|
adamc@275
|
1822 newline,
|
adamc@275
|
1823 box [string "PQclear(res);",
|
adamc@275
|
1824 newline,
|
adamc@275
|
1825 string "PQfinish(conn);",
|
adamc@275
|
1826 newline,
|
adamc@311
|
1827 string "uw_error(ctx, FATAL, \"Table '",
|
adamc@275
|
1828 string s,
|
adamc@275
|
1829 string "' has extra columns.\");",
|
adamc@275
|
1830 newline],
|
adamc@275
|
1831 string "}",
|
adamc@275
|
1832 newline,
|
adamc@275
|
1833 newline,
|
adamc@275
|
1834 string "PQclear(res);",
|
adamc@275
|
1835 newline]
|
adamc@275
|
1836 end) tables,
|
adamc@275
|
1837 string "}"]
|
adamc@29
|
1838 in
|
adamc@144
|
1839 box [string "#include <stdio.h>",
|
adamc@144
|
1840 newline,
|
adamc@144
|
1841 string "#include <stdlib.h>",
|
adamc@144
|
1842 newline,
|
adamc@272
|
1843 string "#include <string.h>",
|
adamc@272
|
1844 newline,
|
adamc@272
|
1845 string "#include <postgresql/libpq-fe.h>",
|
adamc@272
|
1846 newline,
|
adamc@144
|
1847 newline,
|
adamc@244
|
1848 string "#include \"urweb.h\"",
|
adamc@101
|
1849 newline,
|
adamc@101
|
1850 newline,
|
adamc@101
|
1851 p_list_sep newline (fn x => x) pds,
|
adamc@101
|
1852 newline,
|
adamc@311
|
1853 string "int uw_inputs_len = ",
|
adamc@144
|
1854 string (Int.toString (SM.foldl Int.max 0 fnums + 1)),
|
adamc@144
|
1855 string ";",
|
adamc@144
|
1856 newline,
|
adamc@144
|
1857 newline,
|
adamc@311
|
1858 string "int uw_input_num(char *name) {",
|
adamc@144
|
1859 newline,
|
adamc@144
|
1860 makeSwitch (fnums, 0),
|
adamc@144
|
1861 string "}",
|
adamc@144
|
1862 newline,
|
adamc@144
|
1863 newline,
|
adamc@311
|
1864 string "void uw_handle(uw_context ctx, char *request) {",
|
adamc@101
|
1865 newline,
|
adamc@101
|
1866 p_list_sep newline (fn x => x) pds',
|
adamc@101
|
1867 newline,
|
adamc@101
|
1868 string "}",
|
adamc@275
|
1869 newline,
|
adamc@275
|
1870 newline,
|
adamc@275
|
1871 validate,
|
adamc@101
|
1872 newline]
|
adamc@29
|
1873 end
|
adamc@29
|
1874
|
adamc@274
|
1875 fun p_sql env (ds, _) =
|
adamc@274
|
1876 let
|
adamc@274
|
1877 val (pps, _) = ListUtil.foldlMap
|
adamc@274
|
1878 (fn (dAll as (d, _), env) =>
|
adamc@274
|
1879 let
|
adamc@274
|
1880 val pp = case d of
|
adamc@274
|
1881 DTable (s, xts) =>
|
adamc@274
|
1882 box [string "CREATE TABLE ",
|
adamc@274
|
1883 string s,
|
adamc@274
|
1884 string "(",
|
adamc@274
|
1885 p_list (fn (x, t) =>
|
adamc@311
|
1886 box [string "uw_",
|
adamc@275
|
1887 string (CharVector.map Char.toLower x),
|
adamc@274
|
1888 space,
|
adamc@274
|
1889 p_sqltype env t,
|
adamc@274
|
1890 space,
|
adamc@274
|
1891 string "NOT",
|
adamc@274
|
1892 space,
|
adamc@274
|
1893 string "NULL"]) xts,
|
adamc@274
|
1894 string ");",
|
adamc@274
|
1895 newline,
|
adamc@274
|
1896 newline]
|
adamc@274
|
1897 | _ => box []
|
adamc@274
|
1898 in
|
adamc@274
|
1899 (pp, E.declBinds env dAll)
|
adamc@274
|
1900 end)
|
adamc@274
|
1901 env ds
|
adamc@274
|
1902 in
|
adamc@274
|
1903 box pps
|
adamc@274
|
1904 end
|
adamc@274
|
1905
|
adamc@29
|
1906 end
|