adamc@1114
|
1 (* Copyright (c) 2008-2010, 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@316
|
60 val ident = String.translate (fn #"'" => "PRIME"
|
adamc@316
|
61 | ch => str ch)
|
adamc@316
|
62
|
adamc@316
|
63 val p_ident = string o ident
|
adamc@316
|
64
|
adamc@463
|
65 fun isUnboxable (t : typ) =
|
adamc@463
|
66 case #1 t of
|
adamc@463
|
67 TDatatype (Default, _, _) => true
|
adamc@463
|
68 | TFfi ("Basis", "string") => true
|
adamc@463
|
69 | _ => false
|
adamc@463
|
70
|
adamc@29
|
71 fun p_typ' par env (t, loc) =
|
adamc@29
|
72 case t of
|
adamc@476
|
73 TFun (t1, t2) => (EM.errorAt loc "Function type remains";
|
adamc@476
|
74 string "<FUNCTION>")
|
adamc@29
|
75 | TRecord i => box [string "struct",
|
adamc@29
|
76 space,
|
adamc@311
|
77 string "__uws_",
|
adamc@29
|
78 string (Int.toString i)]
|
adamc@188
|
79 | TDatatype (Enum, n, _) =>
|
adamc@188
|
80 (box [string "enum",
|
adamc@188
|
81 space,
|
adamc@1257
|
82 string ("__uwe_" ^ ident (#1 (E.lookupDatatype env n)) ^ "_" ^ Int.toString n)]
|
adamc@311
|
83 handle CjrEnv.UnboundNamed _ => string ("__uwd_UNBOUND__" ^ Int.toString n))
|
adamc@198
|
84 | TDatatype (Option, n, xncs) =>
|
adamc@198
|
85 (case ListUtil.search #3 (!xncs) of
|
adamc@198
|
86 NONE => raise Fail "CjrPrint: TDatatype marked Option has no constructor with an argument"
|
adamc@198
|
87 | SOME t =>
|
adamc@897
|
88 if isUnboxable t then
|
adamc@897
|
89 p_typ' par env t
|
adamc@897
|
90 else
|
adamc@897
|
91 box [p_typ' par env t,
|
adamc@897
|
92 string "*"])
|
adamc@188
|
93 | TDatatype (Default, n, _) =>
|
adamc@165
|
94 (box [string "struct",
|
adamc@165
|
95 space,
|
adamc@1257
|
96 string ("__uwd_" ^ ident (#1 (E.lookupDatatype env n)) ^ "_" ^ Int.toString n ^ "*")]
|
adamc@311
|
97 handle CjrEnv.UnboundNamed _ => string ("__uwd_UNBOUND__" ^ Int.toString n))
|
adamc@316
|
98 | TFfi (m, x) => box [string "uw_", p_ident m, string "_", p_ident x]
|
adamc@288
|
99 | TOption t =>
|
adamc@463
|
100 if isUnboxable t then
|
adamc@463
|
101 p_typ' par env t
|
adamc@463
|
102 else
|
adamc@463
|
103 box [p_typ' par env t,
|
adamc@463
|
104 string "*"]
|
adamc@757
|
105 | TList (_, i) => box [string "struct",
|
adamc@757
|
106 space,
|
adamc@757
|
107 string "__uws_",
|
adamc@757
|
108 string (Int.toString i),
|
adamc@757
|
109 string "*"]
|
adamc@29
|
110
|
adamc@29
|
111 and p_typ env = p_typ' false env
|
adamc@29
|
112
|
adamc@316
|
113 fun p_rel env n = string ("__uwr_" ^ ident (#1 (E.lookupERel env n)) ^ "_" ^ Int.toString (E.countERels env - n - 1))
|
adamc@311
|
114 handle CjrEnv.UnboundRel _ => string ("__uwr_UNBOUND_" ^ Int.toString (E.countERels env - n - 1))
|
adamc@29
|
115
|
adamc@109
|
116 fun p_enamed env n =
|
adamc@316
|
117 string ("__uwn_" ^ ident (#1 (E.lookupENamed env n)) ^ "_" ^ Int.toString n)
|
adamc@311
|
118 handle CjrEnv.UnboundNamed _ => string ("__uwn_UNBOUND_" ^ Int.toString n)
|
adamc@109
|
119
|
adamc@182
|
120 fun p_con_named env n =
|
adamc@316
|
121 string ("__uwc_" ^ ident (#1 (E.lookupConstructor env n)) ^ "_" ^ Int.toString n)
|
adamc@311
|
122 handle CjrEnv.UnboundNamed _ => string ("__uwc_UNBOUND_" ^ Int.toString n)
|
adamc@182
|
123
|
adamc@182
|
124 fun p_pat_preamble env (p, _) =
|
adamc@182
|
125 case p of
|
adamc@182
|
126 PWild => (box [],
|
adamc@182
|
127 env)
|
adamc@182
|
128 | PVar (x, t) => (box [p_typ env t,
|
adamc@182
|
129 space,
|
adamc@311
|
130 string "__uwr_",
|
adamc@316
|
131 p_ident x,
|
adamc@182
|
132 string "_",
|
adamc@182
|
133 string (Int.toString (E.countERels env)),
|
adamc@182
|
134 string ";",
|
adamc@182
|
135 newline],
|
adamc@196
|
136 E.pushERel env x t)
|
adamc@182
|
137 | PPrim _ => (box [], env)
|
adamc@188
|
138 | PCon (_, _, NONE) => (box [], env)
|
adamc@188
|
139 | PCon (_, _, SOME p) => p_pat_preamble env p
|
adamc@182
|
140 | PRecord xps =>
|
adamc@182
|
141 foldl (fn ((_, p, _), (pp, env)) =>
|
adamc@182
|
142 let
|
adamc@182
|
143 val (pp', env) = p_pat_preamble env p
|
adamc@182
|
144 in
|
adamc@182
|
145 (box [pp', pp], env)
|
adamc@182
|
146 end) (box [], env) xps
|
adamc@288
|
147 | PNone _ => (box [], env)
|
adamc@288
|
148 | PSome (_, p) => p_pat_preamble env p
|
adamc@182
|
149
|
adamc@182
|
150 fun p_patCon env pc =
|
adamc@182
|
151 case pc of
|
adamc@182
|
152 PConVar n => p_con_named env n
|
adamc@316
|
153 | PConFfi {mod = m, con, ...} => string ("uw_" ^ ident m ^ "_" ^ ident con)
|
adamc@182
|
154
|
adamc@757
|
155 fun p_pat (env, exit, depth) (p, loc) =
|
adamc@182
|
156 case p of
|
adamc@182
|
157 PWild =>
|
adamc@182
|
158 (box [], env)
|
adamc@182
|
159 | PVar (x, t) =>
|
adamc@311
|
160 (box [string "__uwr_",
|
adamc@316
|
161 p_ident x,
|
adamc@182
|
162 string "_",
|
adamc@182
|
163 string (Int.toString (E.countERels env)),
|
adamc@182
|
164 space,
|
adamc@182
|
165 string "=",
|
adamc@182
|
166 space,
|
adamc@182
|
167 string "disc",
|
adamc@182
|
168 string (Int.toString depth),
|
adamc@182
|
169 string ";"],
|
adamc@182
|
170 E.pushERel env x t)
|
adamc@182
|
171 | PPrim (Prim.Int n) =>
|
adamc@182
|
172 (box [string "if",
|
adamc@182
|
173 space,
|
adamc@182
|
174 string "(disc",
|
adamc@182
|
175 string (Int.toString depth),
|
adamc@182
|
176 space,
|
adamc@182
|
177 string "!=",
|
adamc@182
|
178 space,
|
adamc@276
|
179 Prim.p_t_GCC (Prim.Int n),
|
adamc@182
|
180 string ")",
|
adamc@182
|
181 space,
|
adamc@182
|
182 exit],
|
adamc@182
|
183 env)
|
adamc@182
|
184 | PPrim (Prim.String s) =>
|
adamc@182
|
185 (box [string "if",
|
adamc@182
|
186 space,
|
adamc@182
|
187 string "(strcmp(disc",
|
adamc@182
|
188 string (Int.toString depth),
|
adamc@182
|
189 string ",",
|
adamc@182
|
190 space,
|
adamc@276
|
191 Prim.p_t_GCC (Prim.String s),
|
adamc@182
|
192 string "))",
|
adamc@182
|
193 space,
|
adamc@182
|
194 exit],
|
adamc@182
|
195 env)
|
adamc@947
|
196 | PPrim (Prim.Char ch) =>
|
adamc@947
|
197 (box [string "if",
|
adamc@947
|
198 space,
|
adamc@947
|
199 string "(disc",
|
adamc@947
|
200 string (Int.toString depth),
|
adamc@947
|
201 space,
|
adamc@947
|
202 string "!=",
|
adamc@947
|
203 space,
|
adamc@947
|
204 Prim.p_t_GCC (Prim.Char ch),
|
adamc@947
|
205 string ")",
|
adamc@947
|
206 space,
|
adamc@947
|
207 exit],
|
adamc@947
|
208 env)
|
adamc@182
|
209 | PPrim _ => raise Fail "CjrPrint: Disallowed PPrim primitive"
|
adamc@182
|
210
|
adamc@188
|
211 | PCon (dk, pc, po) =>
|
adamc@182
|
212 let
|
adamc@182
|
213 val (p, env) =
|
adamc@182
|
214 case po of
|
adamc@182
|
215 NONE => (box [], env)
|
adamc@182
|
216 | SOME p =>
|
adamc@182
|
217 let
|
adamc@182
|
218 val (p, env) = p_pat (env, exit, depth + 1) p
|
adamc@182
|
219
|
adamc@182
|
220 val (x, to) = case pc of
|
adamc@182
|
221 PConVar n =>
|
adamc@182
|
222 let
|
adamc@182
|
223 val (x, to, _) = E.lookupConstructor env n
|
adamc@182
|
224 in
|
adamc@316
|
225 ("uw_" ^ ident x, to)
|
adamc@182
|
226 end
|
adamc@188
|
227 | PConFfi {mod = m, con, arg, ...} =>
|
adamc@316
|
228 ("uw_" ^ ident m ^ "_" ^ ident con, arg)
|
adamc@182
|
229
|
adamc@182
|
230 val t = case to of
|
adamc@182
|
231 NONE => raise Fail "CjrPrint: Constructor mismatch"
|
adamc@182
|
232 | SOME t => t
|
adamc@182
|
233 in
|
adamc@182
|
234 (box [string "{",
|
adamc@182
|
235 newline,
|
adamc@182
|
236 p_typ env t,
|
adamc@182
|
237 space,
|
adamc@182
|
238 string "disc",
|
adamc@182
|
239 string (Int.toString (depth + 1)),
|
adamc@182
|
240 space,
|
adamc@182
|
241 string "=",
|
adamc@182
|
242 space,
|
adamc@198
|
243 case dk of
|
adamc@198
|
244 Enum => raise Fail "CjrPrint: Looking at argument of no-argument constructor"
|
adamc@198
|
245 | Default => box [string "disc",
|
adamc@198
|
246 string (Int.toString depth),
|
adamc@198
|
247 string "->data.",
|
adamc@198
|
248 string x]
|
adamc@198
|
249 | Option =>
|
adamc@463
|
250 if isUnboxable t then
|
adamc@463
|
251 box [string "disc",
|
adamc@463
|
252 string (Int.toString depth)]
|
adamc@463
|
253 else
|
adamc@463
|
254 box [string "*disc",
|
adamc@463
|
255 string (Int.toString depth)],
|
adamc@182
|
256 string ";",
|
adamc@182
|
257 newline,
|
adamc@182
|
258 p,
|
adamc@182
|
259 newline,
|
adamc@182
|
260 string "}"],
|
adamc@182
|
261 env)
|
adamc@182
|
262 end
|
adamc@182
|
263 in
|
adamc@182
|
264 (box [string "if",
|
adamc@182
|
265 space,
|
adamc@182
|
266 string "(disc",
|
adamc@182
|
267 string (Int.toString depth),
|
adamc@198
|
268 case (dk, po) of
|
adamc@198
|
269 (Enum, _) => box [space,
|
adamc@198
|
270 string "!=",
|
adamc@198
|
271 space,
|
adamc@198
|
272 p_patCon env pc]
|
adamc@198
|
273 | (Default, _) => box [string "->tag",
|
adamc@198
|
274 space,
|
adamc@198
|
275 string "!=",
|
adamc@198
|
276 space,
|
adamc@198
|
277 p_patCon env pc]
|
adamc@198
|
278 | (Option, NONE) => box [space,
|
adamc@198
|
279 string "!=",
|
adamc@198
|
280 space,
|
adamc@198
|
281 string "NULL"]
|
adamc@198
|
282 | (Option, SOME _) => box [space,
|
adamc@198
|
283 string "==",
|
adamc@198
|
284 space,
|
adamc@198
|
285 string "NULL"],
|
adamc@182
|
286 string ")",
|
adamc@182
|
287 space,
|
adamc@182
|
288 exit,
|
adamc@182
|
289 newline,
|
adamc@182
|
290 p],
|
adamc@182
|
291 env)
|
adamc@182
|
292 end
|
adamc@182
|
293
|
adamc@182
|
294 | PRecord xps =>
|
adamc@182
|
295 let
|
adamc@182
|
296 val (xps, env) =
|
adamc@182
|
297 ListUtil.foldlMap (fn ((x, p, t), env) =>
|
adamc@182
|
298 let
|
adamc@182
|
299 val (p, env) = p_pat (env, exit, depth + 1) p
|
adamc@182
|
300
|
adamc@182
|
301 val p = box [string "{",
|
adamc@182
|
302 newline,
|
adamc@182
|
303 p_typ env t,
|
adamc@182
|
304 space,
|
adamc@182
|
305 string "disc",
|
adamc@182
|
306 string (Int.toString (depth + 1)),
|
adamc@182
|
307 space,
|
adamc@182
|
308 string "=",
|
adamc@182
|
309 space,
|
adamc@182
|
310 string "disc",
|
adamc@182
|
311 string (Int.toString depth),
|
adamc@311
|
312 string ".__uwf_",
|
adamc@316
|
313 p_ident x,
|
adamc@182
|
314 string ";",
|
adamc@182
|
315 newline,
|
adamc@182
|
316 p,
|
adamc@182
|
317 newline,
|
adamc@182
|
318 string "}"]
|
adamc@182
|
319 in
|
adamc@182
|
320 (p, env)
|
adamc@182
|
321 end) env xps
|
adamc@182
|
322 in
|
adamc@182
|
323 (p_list_sep newline (fn x => x) xps,
|
adamc@182
|
324 env)
|
adamc@182
|
325 end
|
adamc@182
|
326
|
adamc@288
|
327 | PNone t =>
|
adamc@288
|
328 (box [string "if",
|
adamc@288
|
329 space,
|
adamc@288
|
330 string "(disc",
|
adamc@288
|
331 string (Int.toString depth),
|
adamc@288
|
332 space,
|
adamc@288
|
333 string "!=",
|
adamc@288
|
334 space,
|
adamc@288
|
335 string "NULL)",
|
adamc@288
|
336 space,
|
adamc@288
|
337 exit,
|
adamc@288
|
338 newline],
|
adamc@288
|
339 env)
|
adamc@288
|
340
|
adamc@288
|
341 | PSome (t, p) =>
|
adamc@288
|
342 let
|
adamc@288
|
343 val (p, env) =
|
adamc@288
|
344 let
|
adamc@288
|
345 val (p, env) = p_pat (env, exit, depth + 1) p
|
adamc@288
|
346 in
|
adamc@288
|
347 (box [string "{",
|
adamc@288
|
348 newline,
|
adamc@288
|
349 p_typ env t,
|
adamc@288
|
350 space,
|
adamc@288
|
351 string "disc",
|
adamc@288
|
352 string (Int.toString (depth + 1)),
|
adamc@288
|
353 space,
|
adamc@288
|
354 string "=",
|
adamc@288
|
355 space,
|
adamc@463
|
356 if isUnboxable t then
|
adamc@463
|
357 box [string "disc",
|
adamc@463
|
358 string (Int.toString depth)]
|
adamc@463
|
359 else
|
adamc@463
|
360 box [string "*disc",
|
adamc@463
|
361 string (Int.toString depth)],
|
adamc@288
|
362 string ";",
|
adamc@288
|
363 newline,
|
adamc@288
|
364 p,
|
adamc@288
|
365 newline,
|
adamc@288
|
366 string "}"],
|
adamc@288
|
367 env)
|
adamc@288
|
368 end
|
adamc@288
|
369 in
|
adamc@288
|
370 (box [string "if",
|
adamc@288
|
371 space,
|
adamc@288
|
372 string "(disc",
|
adamc@288
|
373 string (Int.toString depth),
|
adamc@288
|
374 space,
|
adamc@288
|
375 string "==",
|
adamc@288
|
376 space,
|
adamc@288
|
377 string "NULL)",
|
adamc@288
|
378 space,
|
adamc@288
|
379 exit,
|
adamc@288
|
380 newline,
|
adamc@288
|
381 p],
|
adamc@288
|
382 env)
|
adamc@288
|
383 end
|
adamc@288
|
384
|
adamc@182
|
385 local
|
adamc@182
|
386 val count = ref 0
|
adamc@182
|
387 in
|
adamc@182
|
388 fun newGoto () =
|
adamc@182
|
389 let
|
adamc@182
|
390 val r = !count
|
adamc@182
|
391 in
|
adamc@182
|
392 count := r + 1;
|
adamc@182
|
393 string ("L" ^ Int.toString r)
|
adamc@182
|
394 end
|
adamc@182
|
395 end
|
adamc@182
|
396
|
adamc@185
|
397 fun patConInfo env pc =
|
adamc@185
|
398 case pc of
|
adamc@185
|
399 PConVar n =>
|
adamc@185
|
400 let
|
adamc@185
|
401 val (x, _, dn) = E.lookupConstructor env n
|
adamc@185
|
402 val (dx, _) = E.lookupDatatype env dn
|
adamc@185
|
403 in
|
adamc@316
|
404 ("__uwd_" ^ ident dx ^ "_" ^ Int.toString dn,
|
adamc@316
|
405 "__uwc_" ^ ident x ^ "_" ^ Int.toString n,
|
adamc@316
|
406 "uw_" ^ ident x)
|
adamc@185
|
407 end
|
adamc@186
|
408 | PConFfi {mod = m, datatyp, con, ...} =>
|
adamc@316
|
409 ("uw_" ^ ident m ^ "_" ^ ident datatyp,
|
adamc@316
|
410 "uw_" ^ ident m ^ "_" ^ ident con,
|
adamc@316
|
411 "uw_" ^ ident con)
|
adamc@185
|
412
|
adamc@743
|
413 fun p_unsql wontLeakStrings env (tAll as (t, loc)) e eLen =
|
adamc@278
|
414 case t of
|
adamc@311
|
415 TFfi ("Basis", "int") => box [string "uw_Basis_stringToInt_error(ctx, ", e, string ")"]
|
adamc@311
|
416 | TFfi ("Basis", "float") => box [string "uw_Basis_stringToFloat_error(ctx, ", e, string ")"]
|
adamc@324
|
417 | TFfi ("Basis", "string") =>
|
adamc@324
|
418 if wontLeakStrings then
|
adamc@324
|
419 e
|
adamc@324
|
420 else
|
adamc@737
|
421 box [string "uw_strdup(ctx, ", e, string ")"]
|
adamc@311
|
422 | TFfi ("Basis", "bool") => box [string "uw_Basis_stringToBool_error(ctx, ", e, string ")"]
|
adamc@438
|
423 | TFfi ("Basis", "time") => box [string "uw_Basis_stringToTime_error(ctx, ", e, string ")"]
|
adamc@743
|
424 | TFfi ("Basis", "blob") => box [string "uw_Basis_stringToBlob_error(ctx, ",
|
adamc@743
|
425 e,
|
adamc@743
|
426 string ", ",
|
adamc@743
|
427 eLen,
|
adamc@743
|
428 string ")"]
|
adamc@678
|
429 | TFfi ("Basis", "channel") => box [string "uw_Basis_stringToChannel_error(ctx, ", e, string ")"]
|
adamc@682
|
430 | TFfi ("Basis", "client") => box [string "uw_Basis_stringToClient_error(ctx, ", e, string ")"]
|
adamc@467
|
431
|
adamc@278
|
432 | _ => (ErrorMsg.errorAt loc "Don't know how to unmarshal type from SQL";
|
adamc@278
|
433 Print.eprefaces' [("Type", p_typ env tAll)];
|
adamc@278
|
434 string "ERROR")
|
adamc@278
|
435
|
adamc@467
|
436 fun p_getcol wontLeakStrings env (tAll as (t, loc)) i =
|
adamc@467
|
437 case t of
|
adamc@467
|
438 TOption t =>
|
adamc@747
|
439 box [string "(PQgetisnull(res, i, ",
|
adamc@467
|
440 string (Int.toString i),
|
adamc@467
|
441 string ") ? NULL : ",
|
adamc@467
|
442 case t of
|
adamc@467
|
443 (TFfi ("Basis", "string"), _) => p_getcol wontLeakStrings env t i
|
adamc@467
|
444 | _ => box [string "({",
|
adamc@467
|
445 newline,
|
adamc@467
|
446 p_typ env t,
|
adamc@467
|
447 space,
|
adamc@467
|
448 string "*tmp = uw_malloc(ctx, sizeof(",
|
adamc@467
|
449 p_typ env t,
|
adamc@467
|
450 string "));",
|
adamc@467
|
451 newline,
|
adamc@467
|
452 string "*tmp = ",
|
adamc@467
|
453 p_getcol wontLeakStrings env t i,
|
adamc@467
|
454 string ";",
|
adamc@467
|
455 newline,
|
adamc@467
|
456 string "tmp;",
|
adamc@467
|
457 newline,
|
adamc@467
|
458 string "})"],
|
adamc@467
|
459 string ")"]
|
adamc@467
|
460 | _ =>
|
adamc@747
|
461 box [string "(PQgetisnull(res, i, ",
|
adamc@747
|
462 string (Int.toString i),
|
adamc@747
|
463 string ") ? ",
|
adamc@747
|
464 box [string "({",
|
adamc@747
|
465 p_typ env tAll,
|
adamc@747
|
466 space,
|
adamc@747
|
467 string "tmp;",
|
adamc@747
|
468 newline,
|
adamc@747
|
469 string "uw_error(ctx, FATAL, \"Unexpectedly NULL field #",
|
adamc@747
|
470 string (Int.toString i),
|
adamc@747
|
471 string "\");",
|
adamc@747
|
472 newline,
|
adamc@747
|
473 string "tmp;",
|
adamc@747
|
474 newline,
|
adamc@747
|
475 string "})"],
|
adamc@747
|
476 string " : ",
|
adamc@747
|
477 p_unsql wontLeakStrings env tAll
|
adamc@747
|
478 (box [string "PQgetvalue(res, i, ",
|
adamc@747
|
479 string (Int.toString i),
|
adamc@747
|
480 string ")"])
|
adamc@747
|
481 (box [string "PQgetlength(res, i, ",
|
adamc@747
|
482 string (Int.toString i),
|
adamc@747
|
483 string ")"]),
|
adamc@747
|
484 string ")"]
|
adamc@467
|
485
|
adamc@867
|
486 datatype sql_type = datatype Settings.sql_type
|
adamc@867
|
487 val isBlob = Settings.isBlob
|
adamc@737
|
488
|
adamc@739
|
489 fun isFile (t : typ) =
|
adamc@737
|
490 case #1 t of
|
adamc@739
|
491 TFfi ("Basis", "file") => true
|
adamc@737
|
492 | _ => false
|
adamc@737
|
493
|
adamc@1011
|
494 fun p_sql_type t = string (Settings.p_sql_ctype t)
|
adamc@282
|
495
|
adamc@282
|
496 fun getPargs (e, _) =
|
adamc@282
|
497 case e of
|
adamc@282
|
498 EPrim (Prim.String _) => []
|
adamc@282
|
499 | EFfiApp ("Basis", "strcat", [e1, e2]) => getPargs e1 @ getPargs e2
|
adamc@282
|
500
|
adamc@282
|
501 | EFfiApp ("Basis", "sqlifyInt", [e]) => [(e, Int)]
|
adamc@282
|
502 | EFfiApp ("Basis", "sqlifyFloat", [e]) => [(e, Float)]
|
adamc@282
|
503 | EFfiApp ("Basis", "sqlifyString", [e]) => [(e, String)]
|
adamc@282
|
504 | EFfiApp ("Basis", "sqlifyBool", [e]) => [(e, Bool)]
|
adamc@439
|
505 | EFfiApp ("Basis", "sqlifyTime", [e]) => [(e, Time)]
|
adamc@737
|
506 | EFfiApp ("Basis", "sqlifyBlob", [e]) => [(e, Blob)]
|
adamc@678
|
507 | EFfiApp ("Basis", "sqlifyChannel", [e]) => [(e, Channel)]
|
adamc@682
|
508 | EFfiApp ("Basis", "sqlifyClient", [e]) => [(e, Client)]
|
adamc@468
|
509
|
adamc@678
|
510 | ECase (e,
|
adamc@678
|
511 [((PNone _, _),
|
adamc@678
|
512 (EPrim (Prim.String "NULL"), _)),
|
adamc@678
|
513 ((PSome (_, (PVar _, _)), _),
|
adamc@678
|
514 (EFfiApp (m, x, [(ERel 0, _)]), _))],
|
adamc@678
|
515 _) => map (fn (x, y) => (x, Nullable y)) (getPargs (EFfiApp (m, x, [e]), #2 e))
|
adamc@468
|
516
|
adamc@491
|
517 | ECase (e,
|
adamc@491
|
518 [((PCon (_, PConFfi {mod = "Basis", con = "True", ...}, _), _),
|
adamc@491
|
519 (EPrim (Prim.String "TRUE"), _)),
|
adamc@491
|
520 ((PCon (_, PConFfi {mod = "Basis", con = "False", ...}, _), _),
|
adamc@491
|
521 (EPrim (Prim.String "FALSE"), _))],
|
adamc@491
|
522 _) => [(e, Bool)]
|
adamc@282
|
523
|
adamc@282
|
524 | _ => raise Fail "CjrPrint: getPargs"
|
adamc@282
|
525
|
adamc@324
|
526 fun notLeaky env allowHeapAllocated =
|
adamc@324
|
527 let
|
adamc@638
|
528 fun nl ok (t, _) =
|
adamc@324
|
529 case t of
|
adamc@324
|
530 TFun _ => false
|
adamc@324
|
531 | TRecord n =>
|
adamc@324
|
532 let
|
adamc@324
|
533 val xts = E.lookupStruct env n
|
adamc@324
|
534 in
|
adamc@638
|
535 List.all (fn (_, t) => nl ok t) xts
|
adamc@324
|
536 end
|
adamc@638
|
537 | TDatatype (dk, n, ref cons) =>
|
adamc@638
|
538 IS.member (ok, n)
|
adamc@638
|
539 orelse
|
adamc@638
|
540 ((allowHeapAllocated orelse dk = Enum)
|
adamc@638
|
541 andalso
|
adamc@638
|
542 let
|
adamc@638
|
543 val ok' = IS.add (ok, n)
|
adamc@638
|
544 in
|
adamc@638
|
545 List.all (fn (_, _, to) => case to of
|
adamc@638
|
546 NONE => true
|
adamc@638
|
547 | SOME t => nl ok' t) cons
|
adamc@638
|
548 end)
|
adamc@324
|
549 | TFfi ("Basis", "string") => false
|
adamc@742
|
550 | TFfi ("Basis", "blob") => allowHeapAllocated
|
adamc@324
|
551 | TFfi _ => true
|
adamc@638
|
552 | TOption t => allowHeapAllocated andalso nl ok t
|
adamc@757
|
553 | TList (t, _) => allowHeapAllocated andalso nl ok t
|
adamc@324
|
554 in
|
adamc@638
|
555 nl IS.empty
|
adamc@324
|
556 end
|
adamc@324
|
557
|
adamc@463
|
558 fun capitalize s =
|
adamc@463
|
559 if s = "" then
|
adamc@463
|
560 ""
|
adamc@463
|
561 else
|
adamc@463
|
562 str (Char.toUpper (String.sub (s, 0))) ^ String.extract (s, 1, NONE)
|
adamc@463
|
563
|
adamc@1023
|
564 fun unurlify fromClient env (t, loc) =
|
adamc@463
|
565 let
|
adamc@463
|
566 fun unurlify' rf t =
|
adamc@463
|
567 case t of
|
adamc@1109
|
568 TFfi ("Basis", "unit") => string "uw_Basis_unurlifyUnit(ctx, &request)"
|
adamc@1023
|
569 | TFfi ("Basis", "string") => string (if fromClient then
|
adamc@1023
|
570 "uw_Basis_unurlifyString_fromClient(ctx, &request)"
|
adamc@1023
|
571 else
|
adamc@1023
|
572 "uw_Basis_unurlifyString(ctx, &request)")
|
adamc@463
|
573 | TFfi (m, t) => string ("uw_" ^ ident m ^ "_unurlify" ^ capitalize t ^ "(ctx, &request)")
|
adamc@463
|
574
|
adamc@1109
|
575 | TRecord 0 => string "uw_Basis_unurlifyUnit(ctx, &request)"
|
adamc@463
|
576 | TRecord i =>
|
adamc@463
|
577 let
|
adamc@463
|
578 val xts = E.lookupStruct env i
|
adamc@463
|
579 in
|
adamc@463
|
580 box [string "({",
|
adamc@463
|
581 newline,
|
adamc@463
|
582 box (map (fn (x, t) =>
|
adamc@463
|
583 box [p_typ env t,
|
adamc@463
|
584 space,
|
adamc@463
|
585 string "uwr_",
|
adamc@463
|
586 string x,
|
adamc@463
|
587 space,
|
adamc@463
|
588 string "=",
|
adamc@463
|
589 space,
|
adamc@463
|
590 unurlify' rf (#1 t),
|
adamc@463
|
591 string ";",
|
adamc@463
|
592 newline]) xts),
|
adamc@463
|
593 string "struct",
|
adamc@463
|
594 space,
|
adamc@463
|
595 string "__uws_",
|
adamc@463
|
596 string (Int.toString i),
|
adamc@463
|
597 space,
|
adamc@463
|
598 string "tmp",
|
adamc@463
|
599 space,
|
adamc@463
|
600 string "=",
|
adamc@463
|
601 space,
|
adamc@463
|
602 string "{",
|
adamc@463
|
603 space,
|
adamc@463
|
604 p_list_sep (box [string ",", space]) (fn (x, _) => box [string "uwr_",
|
adamc@463
|
605 string x]) xts,
|
adamc@463
|
606 space,
|
adamc@463
|
607 string "};",
|
adamc@463
|
608 newline,
|
adamc@463
|
609 string "tmp;",
|
adamc@463
|
610 newline,
|
adamc@463
|
611 string "})"]
|
adamc@463
|
612 end
|
adamc@463
|
613
|
adamc@463
|
614 | TDatatype (Enum, i, _) =>
|
adamc@463
|
615 let
|
adamc@463
|
616 val (x, xncs) = E.lookupDatatype env i
|
adamc@463
|
617
|
adamc@463
|
618 fun doEm xncs =
|
adamc@463
|
619 case xncs of
|
adamc@463
|
620 [] => string ("(uw_error(ctx, FATAL, \"Error unurlifying datatype "
|
adamc@463
|
621 ^ x ^ "\"), (enum __uwe_"
|
adamc@463
|
622 ^ x ^ "_" ^ Int.toString i ^ ")0)")
|
adamc@463
|
623 | (x', n, to) :: rest =>
|
adamc@463
|
624 box [string "((!strncmp(request, \"",
|
adamc@463
|
625 string x',
|
adamc@463
|
626 string "\", ",
|
adamc@463
|
627 string (Int.toString (size x')),
|
adamc@463
|
628 string ") && (request[",
|
adamc@463
|
629 string (Int.toString (size x')),
|
adamc@463
|
630 string "] == 0 || request[",
|
adamc@463
|
631 string (Int.toString (size x')),
|
adamc@463
|
632 string ("] == '/')) ? __uwc_" ^ ident x' ^ "_" ^ Int.toString n),
|
adamc@463
|
633 space,
|
adamc@463
|
634 string ":",
|
adamc@463
|
635 space,
|
adamc@463
|
636 doEm rest,
|
adamc@463
|
637 string ")"]
|
adamc@463
|
638 in
|
adamc@463
|
639 doEm xncs
|
adamc@463
|
640 end
|
adamc@463
|
641
|
adamc@463
|
642 | TDatatype (Option, i, xncs) =>
|
adamc@463
|
643 if IS.member (rf, i) then
|
adamc@463
|
644 box [string "unurlify_",
|
adamc@463
|
645 string (Int.toString i),
|
adamc@463
|
646 string "()"]
|
adamc@463
|
647 else
|
adamc@463
|
648 let
|
adamc@463
|
649 val (x, _) = E.lookupDatatype env i
|
adamc@463
|
650
|
adamc@463
|
651 val (no_arg, has_arg, t) =
|
adamc@463
|
652 case !xncs of
|
adamc@463
|
653 [(no_arg, _, NONE), (has_arg, _, SOME t)] =>
|
adamc@463
|
654 (no_arg, has_arg, t)
|
adamc@463
|
655 | [(has_arg, _, SOME t), (no_arg, _, NONE)] =>
|
adamc@463
|
656 (no_arg, has_arg, t)
|
adamc@463
|
657 | _ => raise Fail "CjrPrint: unfooify misclassified Option datatype"
|
adamc@463
|
658
|
adamc@463
|
659 val rf = IS.add (rf, i)
|
adamc@463
|
660 in
|
adamc@463
|
661 box [string "({",
|
adamc@463
|
662 space,
|
adamc@463
|
663 p_typ env t,
|
adamc@463
|
664 space,
|
adamc@463
|
665 string "*unurlify_",
|
adamc@463
|
666 string (Int.toString i),
|
adamc@463
|
667 string "(void) {",
|
adamc@463
|
668 newline,
|
adamc@463
|
669 box [string "return (request[0] == '/' ? ++request : request,",
|
adamc@463
|
670 newline,
|
adamc@463
|
671 string "((!strncmp(request, \"",
|
adamc@463
|
672 string no_arg,
|
adamc@463
|
673 string "\", ",
|
adamc@463
|
674 string (Int.toString (size no_arg)),
|
adamc@463
|
675 string ") && (request[",
|
adamc@463
|
676 string (Int.toString (size no_arg)),
|
adamc@463
|
677 string "] == 0 || request[",
|
adamc@463
|
678 string (Int.toString (size no_arg)),
|
adamc@463
|
679 string "] == '/')) ? (request",
|
adamc@463
|
680 space,
|
adamc@463
|
681 string "+=",
|
adamc@463
|
682 space,
|
adamc@463
|
683 string (Int.toString (size no_arg)),
|
adamc@463
|
684 string ", NULL) : ((!strncmp(request, \"",
|
adamc@463
|
685 string has_arg,
|
adamc@463
|
686 string "\", ",
|
adamc@463
|
687 string (Int.toString (size has_arg)),
|
adamc@463
|
688 string ") && (request[",
|
adamc@463
|
689 string (Int.toString (size has_arg)),
|
adamc@463
|
690 string "] == 0 || request[",
|
adamc@463
|
691 string (Int.toString (size has_arg)),
|
adamc@463
|
692 string "] == '/')) ? (request",
|
adamc@463
|
693 space,
|
adamc@463
|
694 string "+=",
|
adamc@463
|
695 space,
|
adamc@463
|
696 string (Int.toString (size has_arg)),
|
adamc@463
|
697 string ", (request[0] == '/' ? ++request : NULL), ",
|
adamc@463
|
698 newline,
|
adamc@463
|
699
|
adamc@463
|
700 if isUnboxable t then
|
adamc@463
|
701 unurlify' rf (#1 t)
|
adamc@463
|
702 else
|
adamc@463
|
703 box [string "({",
|
adamc@463
|
704 newline,
|
adamc@463
|
705 p_typ env t,
|
adamc@463
|
706 space,
|
adamc@463
|
707 string "*tmp",
|
adamc@463
|
708 space,
|
adamc@463
|
709 string "=",
|
adamc@463
|
710 space,
|
adamc@463
|
711 string "uw_malloc(ctx, sizeof(",
|
adamc@463
|
712 p_typ env t,
|
adamc@463
|
713 string "));",
|
adamc@463
|
714 newline,
|
adamc@463
|
715 string "*tmp",
|
adamc@463
|
716 space,
|
adamc@463
|
717 string "=",
|
adamc@463
|
718 space,
|
adamc@463
|
719 unurlify' rf (#1 t),
|
adamc@463
|
720 string ";",
|
adamc@463
|
721 newline,
|
adamc@463
|
722 string "tmp;",
|
adamc@463
|
723 newline,
|
adamc@463
|
724 string "})"],
|
adamc@463
|
725 string ")",
|
adamc@463
|
726 newline,
|
adamc@463
|
727 string ":",
|
adamc@463
|
728 space,
|
adamc@463
|
729 string ("(uw_error(ctx, FATAL, \"Error unurlifying datatype " ^ x
|
adamc@463
|
730 ^ "\"), NULL))));"),
|
adamc@463
|
731 newline],
|
adamc@463
|
732 string "}",
|
adamc@463
|
733 newline,
|
adamc@463
|
734 newline,
|
adamc@463
|
735
|
adamc@463
|
736 string "unurlify_",
|
adamc@463
|
737 string (Int.toString i),
|
adamc@463
|
738 string "();",
|
adamc@463
|
739 newline,
|
adamc@463
|
740 string "})"]
|
adamc@463
|
741 end
|
adamc@463
|
742
|
adamc@463
|
743 | TDatatype (Default, i, _) =>
|
adamc@463
|
744 if IS.member (rf, i) then
|
adamc@463
|
745 box [string "unurlify_",
|
adamc@463
|
746 string (Int.toString i),
|
adamc@463
|
747 string "()"]
|
adamc@463
|
748 else
|
adamc@463
|
749 let
|
adamc@463
|
750 val (x, xncs) = E.lookupDatatype env i
|
adamc@463
|
751
|
adamc@463
|
752 val rf = IS.add (rf, i)
|
adamc@463
|
753
|
adamc@463
|
754 fun doEm xncs =
|
adamc@463
|
755 case xncs of
|
adamc@463
|
756 [] => string ("(uw_error(ctx, FATAL, \"Error unurlifying datatype "
|
adamc@463
|
757 ^ x ^ "\"), NULL)")
|
adamc@463
|
758 | (x', n, to) :: rest =>
|
adamc@463
|
759 box [string "((!strncmp(request, \"",
|
adamc@463
|
760 string x',
|
adamc@463
|
761 string "\", ",
|
adamc@463
|
762 string (Int.toString (size x')),
|
adamc@463
|
763 string ") && (request[",
|
adamc@463
|
764 string (Int.toString (size x')),
|
adamc@463
|
765 string "] == 0 || request[",
|
adamc@463
|
766 string (Int.toString (size x')),
|
adamc@463
|
767 string "] == '/')) ? ({",
|
adamc@463
|
768 newline,
|
adamc@463
|
769 string "struct",
|
adamc@463
|
770 space,
|
adamc@463
|
771 string ("__uwd_" ^ ident x ^ "_" ^ Int.toString i),
|
adamc@463
|
772 space,
|
adamc@463
|
773 string "*tmp = uw_malloc(ctx, sizeof(struct __uwd_",
|
adamc@463
|
774 string x,
|
adamc@463
|
775 string "_",
|
adamc@463
|
776 string (Int.toString i),
|
adamc@463
|
777 string "));",
|
adamc@463
|
778 newline,
|
adamc@463
|
779 string "tmp->tag",
|
adamc@463
|
780 space,
|
adamc@463
|
781 string "=",
|
adamc@463
|
782 space,
|
adamc@463
|
783 string ("__uwc_" ^ ident x' ^ "_" ^ Int.toString n),
|
adamc@463
|
784 string ";",
|
adamc@463
|
785 newline,
|
adamc@463
|
786 string "request",
|
adamc@463
|
787 space,
|
adamc@463
|
788 string "+=",
|
adamc@463
|
789 space,
|
adamc@463
|
790 string (Int.toString (size x')),
|
adamc@463
|
791 string ";",
|
adamc@463
|
792 newline,
|
adamc@463
|
793 string "if (request[0] == '/') ++request;",
|
adamc@463
|
794 newline,
|
adamc@463
|
795 case to of
|
adamc@463
|
796 NONE => box []
|
adamc@463
|
797 | SOME (t, _) => box [string "tmp->data.uw_",
|
adamc@463
|
798 p_ident x',
|
adamc@463
|
799 space,
|
adamc@463
|
800 string "=",
|
adamc@463
|
801 space,
|
adamc@463
|
802 unurlify' rf t,
|
adamc@463
|
803 string ";",
|
adamc@463
|
804 newline],
|
adamc@463
|
805 string "tmp;",
|
adamc@463
|
806 newline,
|
adamc@463
|
807 string "})",
|
adamc@463
|
808 space,
|
adamc@463
|
809 string ":",
|
adamc@463
|
810 space,
|
adamc@463
|
811 doEm rest,
|
adamc@463
|
812 string ")"]
|
adamc@463
|
813 in
|
adamc@463
|
814 box [string "({",
|
adamc@463
|
815 space,
|
adamc@463
|
816 p_typ env (t, ErrorMsg.dummySpan),
|
adamc@463
|
817 space,
|
adamc@463
|
818 string "unurlify_",
|
adamc@463
|
819 string (Int.toString i),
|
adamc@463
|
820 string "(void) {",
|
adamc@463
|
821 newline,
|
adamc@463
|
822 box [string "return",
|
adamc@463
|
823 space,
|
adamc@463
|
824 doEm xncs,
|
adamc@463
|
825 string ";",
|
adamc@463
|
826 newline],
|
adamc@463
|
827 string "}",
|
adamc@463
|
828 newline,
|
adamc@463
|
829 newline,
|
adamc@463
|
830
|
adamc@463
|
831 string "unurlify_",
|
adamc@463
|
832 string (Int.toString i),
|
adamc@463
|
833 string "();",
|
adamc@463
|
834 newline,
|
adamc@463
|
835 string "})"]
|
adamc@463
|
836 end
|
adamc@463
|
837
|
adamc@758
|
838 | TList (t', i) =>
|
adamc@758
|
839 if IS.member (rf, i) then
|
adamc@758
|
840 box [string "unurlify_list_",
|
adamc@758
|
841 string (Int.toString i),
|
adamc@758
|
842 string "()"]
|
adamc@758
|
843 else
|
adamc@758
|
844 let
|
adamc@758
|
845 val rf = IS.add (rf, i)
|
adamc@758
|
846 in
|
adamc@758
|
847 box [string "({",
|
adamc@758
|
848 space,
|
adamc@758
|
849 p_typ env (t, loc),
|
adamc@758
|
850 space,
|
adamc@758
|
851 string "unurlify_list_",
|
adamc@758
|
852 string (Int.toString i),
|
adamc@758
|
853 string "(void) {",
|
adamc@758
|
854 newline,
|
adamc@758
|
855 box [string "return (request[0] == '/' ? ++request : request,",
|
adamc@758
|
856 newline,
|
adamc@758
|
857 string "((!strncmp(request, \"Nil\", 3) && (request[3] == 0 ",
|
adamc@758
|
858 string "|| request[3] == '/')) ? (request",
|
adamc@758
|
859 space,
|
adamc@758
|
860 string "+=",
|
adamc@758
|
861 space,
|
adamc@758
|
862 string "3, NULL) : ((!strncmp(request, \"Cons\", 4) && (request[4] == 0 ",
|
adamc@758
|
863 string "|| request[4] == '/')) ? (request",
|
adamc@758
|
864 space,
|
adamc@758
|
865 string "+=",
|
adamc@758
|
866 space,
|
adamc@758
|
867 string "4, (request[0] == '/' ? ++request : NULL), ",
|
adamc@758
|
868 newline,
|
adamc@758
|
869
|
adamc@758
|
870 string "({",
|
adamc@758
|
871 newline,
|
adamc@758
|
872 p_typ env (t, loc),
|
adamc@758
|
873 space,
|
adamc@758
|
874 string "tmp",
|
adamc@758
|
875 space,
|
adamc@758
|
876 string "=",
|
adamc@758
|
877 space,
|
adamc@758
|
878 string "uw_malloc(ctx, sizeof(struct __uws_",
|
adamc@758
|
879 string (Int.toString i),
|
adamc@758
|
880 string "));",
|
adamc@758
|
881 newline,
|
adamc@758
|
882 string "*tmp",
|
adamc@758
|
883 space,
|
adamc@758
|
884 string "=",
|
adamc@758
|
885 space,
|
adamc@758
|
886 unurlify' rf (TRecord i),
|
adamc@758
|
887 string ";",
|
adamc@758
|
888 newline,
|
adamc@758
|
889 string "tmp;",
|
adamc@758
|
890 newline,
|
adamc@758
|
891 string "})",
|
adamc@758
|
892 string ")",
|
adamc@758
|
893 newline,
|
adamc@758
|
894 string ":",
|
adamc@758
|
895 space,
|
adamc@758
|
896 string ("(uw_error(ctx, FATAL, \"Error unurlifying list\"), NULL))));"),
|
adamc@758
|
897 newline],
|
adamc@758
|
898 string "}",
|
adamc@758
|
899 newline,
|
adamc@758
|
900 newline,
|
adamc@758
|
901
|
adamc@758
|
902 string "unurlify_list_",
|
adamc@758
|
903 string (Int.toString i),
|
adamc@758
|
904 string "();",
|
adamc@758
|
905 newline,
|
adamc@758
|
906 string "})"]
|
adamc@758
|
907 end
|
adamc@758
|
908
|
adamc@471
|
909 | TOption t =>
|
adamc@471
|
910 box [string "(request[0] == '/' ? ++request : request, ",
|
adamc@471
|
911 string "((!strncmp(request, \"None\", 4) ",
|
adamc@471
|
912 string "&& (request[4] == 0 || request[4] == '/')) ",
|
adamc@931
|
913 string "? (request += (request[4] == 0 ? 4 : 5), NULL) ",
|
adamc@471
|
914 string ": ((!strncmp(request, \"Some\", 4) ",
|
adamc@471
|
915 string "&& request[4] == '/') ",
|
adamc@471
|
916 string "? (request += 5, ",
|
adamc@471
|
917 if isUnboxable t then
|
adamc@471
|
918 unurlify' rf (#1 t)
|
adamc@471
|
919 else
|
adamc@471
|
920 box [string "({",
|
adamc@471
|
921 newline,
|
adamc@471
|
922 p_typ env t,
|
adamc@471
|
923 space,
|
adamc@471
|
924 string "*tmp",
|
adamc@471
|
925 space,
|
adamc@471
|
926 string "=",
|
adamc@471
|
927 space,
|
adamc@471
|
928 string "uw_malloc(ctx, sizeof(",
|
adamc@471
|
929 p_typ env t,
|
adamc@471
|
930 string "));",
|
adamc@471
|
931 newline,
|
adamc@471
|
932 string "*tmp",
|
adamc@471
|
933 space,
|
adamc@471
|
934 string "=",
|
adamc@471
|
935 space,
|
adamc@471
|
936 unurlify' rf (#1 t),
|
adamc@471
|
937 string ";",
|
adamc@471
|
938 newline,
|
adamc@471
|
939 string "tmp;",
|
adamc@471
|
940 newline,
|
adamc@471
|
941 string "})"],
|
adamc@471
|
942 string ") :",
|
adamc@471
|
943 space,
|
adamc@471
|
944 string "(uw_error(ctx, FATAL, \"Error unurlifying option type\"), NULL))))"]
|
adamc@471
|
945
|
adamc@463
|
946 | _ => (ErrorMsg.errorAt loc "Unable to choose a URL decoding function";
|
adamc@463
|
947 space)
|
adamc@463
|
948 in
|
adamc@463
|
949 unurlify' IS.empty t
|
adamc@463
|
950 end
|
adamc@463
|
951
|
adamc@905
|
952 val urlify1 = ref 0
|
adamc@905
|
953
|
adamc@610
|
954 fun urlify env t =
|
adamc@610
|
955 let
|
adamc@905
|
956 fun urlify' rf rfl level (t as (_, loc)) =
|
adamc@610
|
957 case #1 t of
|
adamc@610
|
958 TFfi ("Basis", "unit") => box []
|
adamc@610
|
959 | TFfi (m, t) => box [string ("uw_" ^ ident m ^ "_urlify" ^ capitalize t
|
adamc@610
|
960 ^ "_w(ctx, it" ^ Int.toString level ^ ");"),
|
adamc@610
|
961 newline]
|
adamc@610
|
962
|
adamc@610
|
963 | TRecord 0 => box []
|
adamc@610
|
964 | TRecord i =>
|
adamc@610
|
965 let
|
adamc@611
|
966 fun empty (t, _) =
|
adamc@611
|
967 case t of
|
adamc@611
|
968 TFfi ("Basis", "unit") => true
|
adamc@611
|
969 | TRecord 0 => true
|
adamc@611
|
970 | TRecord j =>
|
adamc@611
|
971 List.all (fn (_, t) => empty t) (E.lookupStruct env j)
|
adamc@611
|
972 | _ => false
|
adamc@611
|
973
|
adamc@610
|
974 val xts = E.lookupStruct env i
|
adamc@611
|
975
|
adamc@613
|
976 val (blocks, _) = foldl
|
adamc@613
|
977 (fn ((x, t), (blocks, printingSinceLastSlash)) =>
|
adamc@613
|
978 let
|
adamc@613
|
979 val thisEmpty = empty t
|
adamc@613
|
980 in
|
adamc@613
|
981 if thisEmpty then
|
adamc@613
|
982 (blocks, printingSinceLastSlash)
|
adamc@613
|
983 else
|
adamc@613
|
984 (box [string "{",
|
adamc@613
|
985 newline,
|
adamc@613
|
986 p_typ env t,
|
adamc@613
|
987 space,
|
adamc@613
|
988 string ("it" ^ Int.toString (level + 1)),
|
adamc@613
|
989 space,
|
adamc@613
|
990 string "=",
|
adamc@613
|
991 space,
|
adamc@613
|
992 string ("it" ^ Int.toString level ^ ".__uwf_" ^ x ^ ";"),
|
adamc@613
|
993 newline,
|
adamc@613
|
994 box (if printingSinceLastSlash then
|
adamc@613
|
995 [string "uw_write(ctx, \"/\");",
|
adamc@613
|
996 newline]
|
adamc@613
|
997 else
|
adamc@613
|
998 []),
|
adamc@905
|
999 urlify' rf rfl (level + 1) t,
|
adamc@613
|
1000 string "}",
|
adamc@613
|
1001 newline] :: blocks,
|
adamc@613
|
1002 true)
|
adamc@613
|
1003 end)
|
adamc@613
|
1004 ([], false) xts
|
adamc@610
|
1005 in
|
adamc@613
|
1006 box (rev blocks)
|
adamc@610
|
1007 end
|
adamc@610
|
1008
|
adamc@638
|
1009 | TDatatype (Enum, i, _) =>
|
adamc@638
|
1010 let
|
adamc@610
|
1011 val (x, xncs) = E.lookupDatatype env i
|
adamc@610
|
1012
|
adamc@610
|
1013 fun doEm xncs =
|
adamc@610
|
1014 case xncs of
|
adamc@638
|
1015 [] => box [string ("uw_error(ctx, FATAL, \"Error urlifying datatype "
|
adamc@638
|
1016 ^ x ^ "\");"),
|
adamc@638
|
1017 newline]
|
adamc@610
|
1018 | (x', n, to) :: rest =>
|
adamc@638
|
1019 box [string ("if (it" ^ Int.toString level
|
adamc@638
|
1020 ^ "==__uwc_" ^ ident x' ^ "_" ^ Int.toString n ^ ") {"),
|
adamc@638
|
1021 newline,
|
adamc@638
|
1022 box [string ("uw_write(ctx, \"" ^ x' ^ "\");"),
|
adamc@638
|
1023 newline],
|
adamc@638
|
1024 string "} else {",
|
adamc@638
|
1025 newline,
|
adamc@638
|
1026 box [doEm rest,
|
adamc@638
|
1027 newline],
|
adamc@638
|
1028 string "}"]
|
adamc@610
|
1029 in
|
adamc@610
|
1030 doEm xncs
|
adamc@638
|
1031 end
|
adamc@610
|
1032
|
adamc@639
|
1033 | TDatatype (Option, i, xncs) =>
|
adamc@639
|
1034 if IS.member (rf, i) then
|
adamc@639
|
1035 box [string "urlify_",
|
adamc@610
|
1036 string (Int.toString i),
|
adamc@639
|
1037 string "(it",
|
adamc@639
|
1038 string (Int.toString level),
|
adamc@639
|
1039 string ");",
|
adamc@639
|
1040 newline]
|
adamc@610
|
1041 else
|
adamc@610
|
1042 let
|
adamc@610
|
1043 val (x, _) = E.lookupDatatype env i
|
adamc@610
|
1044
|
adamc@610
|
1045 val (no_arg, has_arg, t) =
|
adamc@610
|
1046 case !xncs of
|
adamc@610
|
1047 [(no_arg, _, NONE), (has_arg, _, SOME t)] =>
|
adamc@610
|
1048 (no_arg, has_arg, t)
|
adamc@610
|
1049 | [(has_arg, _, SOME t), (no_arg, _, NONE)] =>
|
adamc@610
|
1050 (no_arg, has_arg, t)
|
adamc@639
|
1051 | _ => raise Fail "CjrPrint: urlify misclassified Option datatype"
|
adamc@610
|
1052
|
adamc@610
|
1053 val rf = IS.add (rf, i)
|
adamc@610
|
1054 in
|
adamc@610
|
1055 box [string "({",
|
adamc@610
|
1056 space,
|
adamc@639
|
1057 string "void",
|
adamc@639
|
1058 space,
|
adamc@639
|
1059 string "urlify_",
|
adamc@639
|
1060 string (Int.toString i),
|
adamc@639
|
1061 string "(",
|
adamc@610
|
1062 p_typ env t,
|
adamc@610
|
1063 space,
|
adamc@639
|
1064 if isUnboxable t then
|
adamc@639
|
1065 box []
|
adamc@639
|
1066 else
|
adamc@639
|
1067 string "*",
|
adamc@639
|
1068 string "it0) {",
|
adamc@610
|
1069 newline,
|
adamc@639
|
1070 box [string "if (it0) {",
|
adamc@905
|
1071 newline,
|
adamc@639
|
1072 if isUnboxable t then
|
adamc@905
|
1073 urlify' rf rfl 0 t
|
adamc@610
|
1074 else
|
adamc@639
|
1075 box [p_typ env t,
|
adamc@610
|
1076 space,
|
adamc@639
|
1077 string "it1",
|
adamc@610
|
1078 space,
|
adamc@610
|
1079 string "=",
|
adamc@610
|
1080 space,
|
adamc@639
|
1081 string "*it0;",
|
adamc@610
|
1082 newline,
|
adamc@639
|
1083 string "uw_write(ctx, \"",
|
adamc@639
|
1084 string has_arg,
|
adamc@639
|
1085 string "/\");",
|
adamc@639
|
1086 newline,
|
adamc@905
|
1087 urlify' rf rfl 1 t,
|
adamc@610
|
1088 string ";",
|
adamc@639
|
1089 newline],
|
adamc@639
|
1090 string "} else {",
|
adamc@905
|
1091 box [newline,
|
adamc@905
|
1092 string "uw_write(ctx, \"",
|
adamc@639
|
1093 string no_arg,
|
adamc@639
|
1094 string "\");",
|
adamc@639
|
1095 newline],
|
adamc@639
|
1096 string "}",
|
adamc@610
|
1097 newline],
|
adamc@610
|
1098 string "}",
|
adamc@610
|
1099 newline,
|
adamc@610
|
1100 newline,
|
adamc@610
|
1101
|
adamc@639
|
1102 string "urlify_",
|
adamc@610
|
1103 string (Int.toString i),
|
adamc@639
|
1104 string "(it",
|
adamc@639
|
1105 string (Int.toString level),
|
adamc@639
|
1106 string ");",
|
adamc@610
|
1107 newline,
|
adamc@639
|
1108 string "});",
|
adamc@639
|
1109 newline]
|
adamc@639
|
1110 end
|
adamc@610
|
1111
|
adamc@640
|
1112 | TDatatype (Default, i, _) =>
|
adamc@640
|
1113 if IS.member (rf, i) then
|
adamc@640
|
1114 box [string "urlify_",
|
adamc@610
|
1115 string (Int.toString i),
|
adamc@640
|
1116 string "(it",
|
adamc@640
|
1117 string (Int.toString level),
|
adamc@640
|
1118 string ");",
|
adamc@640
|
1119 newline]
|
adamc@610
|
1120 else
|
adamc@610
|
1121 let
|
adamc@610
|
1122 val (x, xncs) = E.lookupDatatype env i
|
adamc@610
|
1123
|
adamc@610
|
1124 val rf = IS.add (rf, i)
|
adamc@610
|
1125
|
adamc@610
|
1126 fun doEm xncs =
|
adamc@610
|
1127 case xncs of
|
adamc@640
|
1128 [] => box [string ("uw_error(ctx, FATAL, \"Error urlifying datatype "
|
adamc@640
|
1129 ^ x ^ " (%d)\", it0->data);"),
|
adamc@640
|
1130 newline]
|
adamc@610
|
1131 | (x', n, to) :: rest =>
|
adamc@640
|
1132 box [string "if",
|
adamc@610
|
1133 space,
|
adamc@640
|
1134 string "(it0->tag==__uwc_",
|
adamc@640
|
1135 string (ident x'),
|
adamc@610
|
1136 string "_",
|
adamc@640
|
1137 string (Int.toString n),
|
adamc@640
|
1138 string ") {",
|
adamc@610
|
1139 newline,
|
adamc@610
|
1140 case to of
|
adamc@640
|
1141 NONE => box [string "uw_write(ctx, \"",
|
adamc@640
|
1142 string x',
|
adamc@640
|
1143 string "\");",
|
adamc@640
|
1144 newline]
|
adamc@640
|
1145 | SOME t => box [string "uw_write(ctx, \"",
|
adamc@640
|
1146 string x',
|
adamc@640
|
1147 string "/\");",
|
adamc@640
|
1148 newline,
|
adamc@640
|
1149 p_typ env t,
|
adamc@640
|
1150 space,
|
adamc@640
|
1151 string "it1",
|
adamc@640
|
1152 space,
|
adamc@640
|
1153 string "=",
|
adamc@640
|
1154 space,
|
adamc@640
|
1155 string "it0->data.uw_",
|
adamc@640
|
1156 string x',
|
adamc@640
|
1157 string ";",
|
adamc@640
|
1158 newline,
|
adamc@905
|
1159 urlify' rf rfl 1 t,
|
adamc@640
|
1160 newline],
|
adamc@640
|
1161 string "} else {",
|
adamc@610
|
1162 newline,
|
adamc@640
|
1163 box [doEm rest,
|
adamc@640
|
1164 newline],
|
adamc@640
|
1165 string "}",
|
adamc@640
|
1166 newline]
|
adamc@610
|
1167 in
|
adamc@610
|
1168 box [string "({",
|
adamc@610
|
1169 space,
|
adamc@640
|
1170 string "void",
|
adamc@610
|
1171 space,
|
adamc@640
|
1172 string "urlify_",
|
adamc@610
|
1173 string (Int.toString i),
|
adamc@640
|
1174 string "(",
|
adamc@640
|
1175 p_typ env t,
|
adamc@640
|
1176 space,
|
adamc@640
|
1177 string "it0) {",
|
adamc@610
|
1178 newline,
|
adamc@640
|
1179 box [doEm xncs,
|
adamc@610
|
1180 newline],
|
adamc@640
|
1181 newline,
|
adamc@610
|
1182 string "}",
|
adamc@610
|
1183 newline,
|
adamc@640
|
1184
|
adamc@640
|
1185 string "urlify_",
|
adamc@640
|
1186 string (Int.toString i),
|
adamc@640
|
1187 string "(it",
|
adamc@640
|
1188 string (Int.toString level),
|
adamc@640
|
1189 string ");",
|
adamc@610
|
1190 newline,
|
adamc@640
|
1191 string "});",
|
adamc@640
|
1192 newline]
|
adamc@640
|
1193 end
|
adamc@610
|
1194
|
adamc@641
|
1195 | TOption t =>
|
adamc@641
|
1196 box [string "if (it",
|
adamc@641
|
1197 string (Int.toString level),
|
adamc@641
|
1198 string ") {",
|
adamc@641
|
1199 if isUnboxable t then
|
adamc@641
|
1200 box [string "uw_write(ctx, \"Some/\");",
|
adamc@641
|
1201 newline,
|
adamc@905
|
1202 urlify' rf rfl level t]
|
adamc@610
|
1203 else
|
adamc@641
|
1204 box [p_typ env t,
|
adamc@610
|
1205 space,
|
adamc@641
|
1206 string "it",
|
adamc@641
|
1207 string (Int.toString (level + 1)),
|
adamc@610
|
1208 space,
|
adamc@610
|
1209 string "=",
|
adamc@610
|
1210 space,
|
adamc@641
|
1211 string "*it",
|
adamc@641
|
1212 string (Int.toString level),
|
adamc@610
|
1213 string ";",
|
adamc@610
|
1214 newline,
|
adamc@641
|
1215 string "uw_write(ctx, \"Some/\");",
|
adamc@610
|
1216 newline,
|
adamc@905
|
1217 urlify' rf rfl (level + 1) t,
|
adamc@641
|
1218 string ";",
|
adamc@641
|
1219 newline],
|
adamc@641
|
1220 string "} else {",
|
adamc@905
|
1221 box [newline,
|
adamc@905
|
1222 string "uw_write(ctx, \"None\");",
|
adamc@641
|
1223 newline],
|
adamc@641
|
1224 string "}",
|
adamc@641
|
1225 newline]
|
adamc@610
|
1226
|
adamc@905
|
1227 | TList (t, i) =>
|
adamc@905
|
1228 if IS.member (rfl, i) then
|
adamc@905
|
1229 box [string "urlifyl_",
|
adamc@905
|
1230 string (Int.toString i),
|
adamc@905
|
1231 string "(it",
|
adamc@905
|
1232 string (Int.toString level),
|
adamc@905
|
1233 string ");",
|
adamc@905
|
1234 newline]
|
adamc@905
|
1235 else
|
adamc@905
|
1236 let
|
adamc@905
|
1237 val rfl = IS.add (rfl, i)
|
adamc@905
|
1238 in
|
adamc@905
|
1239 box [string "({",
|
adamc@905
|
1240 space,
|
adamc@905
|
1241 string "void",
|
adamc@905
|
1242 space,
|
adamc@905
|
1243 string "urlifyl_",
|
adamc@905
|
1244 string (Int.toString i),
|
adamc@905
|
1245 string "(struct __uws_",
|
adamc@905
|
1246 string (Int.toString i),
|
adamc@905
|
1247 space,
|
adamc@905
|
1248 string "*it0) {",
|
adamc@905
|
1249 newline,
|
adamc@905
|
1250 box [string "if (it0) {",
|
adamc@905
|
1251 newline,
|
adamc@905
|
1252 p_typ env t,
|
adamc@905
|
1253 space,
|
adamc@905
|
1254 string "it1",
|
adamc@905
|
1255 space,
|
adamc@905
|
1256 string "=",
|
adamc@905
|
1257 space,
|
adamc@905
|
1258 string "it0->__uwf_1;",
|
adamc@905
|
1259 newline,
|
adamc@905
|
1260 string "uw_write(ctx, \"Cons/\");",
|
adamc@905
|
1261 newline,
|
adamc@905
|
1262 urlify' rf rfl 1 t,
|
adamc@905
|
1263 string ";",
|
adamc@905
|
1264 newline,
|
adamc@905
|
1265 string "uw_write(ctx, \"/\");",
|
adamc@905
|
1266 newline,
|
adamc@905
|
1267 string "urlifyl_",
|
adamc@905
|
1268 string (Int.toString i),
|
adamc@905
|
1269 string "(it0->__uwf_2);",
|
adamc@905
|
1270 newline,
|
adamc@905
|
1271 string "} else {",
|
adamc@905
|
1272 newline,
|
adamc@905
|
1273 box [string "uw_write(ctx, \"Nil\");",
|
adamc@905
|
1274 newline],
|
adamc@905
|
1275 string "}",
|
adamc@905
|
1276 newline],
|
adamc@905
|
1277 string "}",
|
adamc@905
|
1278 newline,
|
adamc@905
|
1279 newline,
|
adamc@905
|
1280
|
adamc@905
|
1281 string "urlifyl_",
|
adamc@905
|
1282 string (Int.toString i),
|
adamc@905
|
1283 string "(it",
|
adamc@905
|
1284 string (Int.toString level),
|
adamc@905
|
1285 string ");",
|
adamc@905
|
1286 newline,
|
adamc@905
|
1287 string "});",
|
adamc@905
|
1288 newline]
|
adamc@905
|
1289 end
|
adamc@905
|
1290
|
adamc@610
|
1291 | _ => (ErrorMsg.errorAt loc "Unable to choose a URL encoding function";
|
adamc@610
|
1292 space)
|
adamc@610
|
1293 in
|
adamc@905
|
1294 urlify' IS.empty IS.empty 0 t
|
adamc@610
|
1295 end
|
adamc@610
|
1296
|
adamc@867
|
1297 fun sql_type_in env (tAll as (t, loc)) =
|
adamc@867
|
1298 case t of
|
adamc@867
|
1299 TFfi ("Basis", "int") => Int
|
adamc@867
|
1300 | TFfi ("Basis", "float") => Float
|
adamc@867
|
1301 | TFfi ("Basis", "string") => String
|
adamc@1011
|
1302 | TFfi ("Basis", "char") => Char
|
adamc@867
|
1303 | TFfi ("Basis", "bool") => Bool
|
adamc@867
|
1304 | TFfi ("Basis", "time") => Time
|
adamc@867
|
1305 | TFfi ("Basis", "blob") => Blob
|
adamc@867
|
1306 | TFfi ("Basis", "channel") => Channel
|
adamc@867
|
1307 | TFfi ("Basis", "client") => Client
|
adamc@867
|
1308 | TOption t' => Nullable (sql_type_in env t')
|
adamc@867
|
1309 | _ => (ErrorMsg.errorAt loc "Don't know SQL equivalent of type";
|
adamc@867
|
1310 Print.eprefaces' [("Type", p_typ env tAll)];
|
adamc@867
|
1311 Int)
|
adamc@867
|
1312
|
adamc@182
|
1313 fun p_exp' par env (e, loc) =
|
adamc@29
|
1314 case e of
|
adamc@276
|
1315 EPrim p => Prim.p_t_GCC p
|
adamc@29
|
1316 | ERel n => p_rel env n
|
adamc@109
|
1317 | ENamed n => p_enamed env n
|
adamc@188
|
1318 | ECon (Enum, pc, _) => p_patCon env pc
|
adamc@198
|
1319 | ECon (Option, pc, NONE) => string "NULL"
|
adamc@198
|
1320 | ECon (Option, pc, SOME e) =>
|
adamc@198
|
1321 let
|
adamc@198
|
1322 val to = case pc of
|
adamc@198
|
1323 PConVar n => #2 (E.lookupConstructor env n)
|
adamc@198
|
1324 | PConFfi {arg, ...} => arg
|
adamc@198
|
1325
|
adamc@198
|
1326 val t = case to of
|
adamc@198
|
1327 NONE => raise Fail "CjrPrint: ECon argument status mismatch"
|
adamc@198
|
1328 | SOME t => t
|
adamc@198
|
1329 in
|
adamc@463
|
1330 if isUnboxable t then
|
adamc@463
|
1331 p_exp' par env e
|
adamc@463
|
1332 else
|
adamc@463
|
1333 box [string "({",
|
adamc@463
|
1334 newline,
|
adamc@463
|
1335 p_typ env t,
|
adamc@463
|
1336 space,
|
adamc@463
|
1337 string "*tmp",
|
adamc@463
|
1338 space,
|
adamc@463
|
1339 string "=",
|
adamc@463
|
1340 space,
|
adamc@463
|
1341 string "uw_malloc(ctx, sizeof(",
|
adamc@463
|
1342 p_typ env t,
|
adamc@463
|
1343 string "));",
|
adamc@463
|
1344 newline,
|
adamc@463
|
1345 string "*tmp",
|
adamc@463
|
1346 space,
|
adamc@463
|
1347 string "=",
|
adamc@463
|
1348 p_exp' par env e,
|
adamc@463
|
1349 string ";",
|
adamc@463
|
1350 newline,
|
adamc@463
|
1351 string "tmp;",
|
adamc@463
|
1352 newline,
|
adamc@463
|
1353 string "})"]
|
adamc@198
|
1354 end
|
adamc@188
|
1355 | ECon (Default, pc, eo) =>
|
adamc@181
|
1356 let
|
adamc@196
|
1357 val (xd, xc, xn) = patConInfo env pc
|
adamc@181
|
1358 in
|
adamc@182
|
1359 box [string "({",
|
adamc@181
|
1360 newline,
|
adamc@181
|
1361 string "struct",
|
adamc@181
|
1362 space,
|
adamc@185
|
1363 string xd,
|
adamc@181
|
1364 space,
|
adamc@181
|
1365 string "*tmp",
|
adamc@181
|
1366 space,
|
adamc@181
|
1367 string "=",
|
adamc@181
|
1368 space,
|
adamc@311
|
1369 string "uw_malloc(ctx, sizeof(struct ",
|
adamc@185
|
1370 string xd,
|
adamc@181
|
1371 string "));",
|
adamc@181
|
1372 newline,
|
adamc@181
|
1373 string "tmp->tag",
|
adamc@181
|
1374 space,
|
adamc@181
|
1375 string "=",
|
adamc@181
|
1376 space,
|
adamc@185
|
1377 string xc,
|
adamc@181
|
1378 string ";",
|
adamc@181
|
1379 newline,
|
adamc@181
|
1380 case eo of
|
adamc@181
|
1381 NONE => box []
|
adamc@185
|
1382 | SOME e => box [string "tmp->data.",
|
adamc@196
|
1383 string xn,
|
adamc@181
|
1384 space,
|
adamc@181
|
1385 string "=",
|
adamc@181
|
1386 space,
|
adamc@181
|
1387 p_exp env e,
|
adamc@181
|
1388 string ";",
|
adamc@181
|
1389 newline],
|
adamc@181
|
1390 string "tmp;",
|
adamc@181
|
1391 newline,
|
adamc@181
|
1392 string "})"]
|
adamc@181
|
1393 end
|
adamc@297
|
1394 | ENone _ => string "NULL"
|
adamc@290
|
1395 | ESome (t, e) =>
|
adamc@463
|
1396 if isUnboxable t then
|
adamc@463
|
1397 p_exp' par env e
|
adamc@463
|
1398 else
|
adamc@463
|
1399 box [string "({",
|
adamc@463
|
1400 newline,
|
adamc@463
|
1401 p_typ env t,
|
adamc@463
|
1402 space,
|
adamc@463
|
1403 string "*tmp",
|
adamc@463
|
1404 space,
|
adamc@463
|
1405 string "=",
|
adamc@463
|
1406 space,
|
adamc@463
|
1407 string "uw_malloc(ctx, sizeof(",
|
adamc@463
|
1408 p_typ env t,
|
adamc@463
|
1409 string "));",
|
adamc@463
|
1410 newline,
|
adamc@463
|
1411 string "*tmp",
|
adamc@463
|
1412 space,
|
adamc@463
|
1413 string "=",
|
adamc@463
|
1414 p_exp' par env e,
|
adamc@463
|
1415 string ";",
|
adamc@463
|
1416 newline,
|
adamc@463
|
1417 string "tmp;",
|
adamc@463
|
1418 newline,
|
adamc@463
|
1419 string "})"]
|
adamc@109
|
1420
|
adamc@316
|
1421 | EFfi (m, x) => box [string "uw_", p_ident m, string "_", p_ident x]
|
adamc@283
|
1422 | EError (e, t) =>
|
adamc@283
|
1423 box [string "({",
|
adamc@283
|
1424 newline,
|
adamc@283
|
1425 p_typ env t,
|
adamc@283
|
1426 space,
|
adamc@283
|
1427 string "tmp;",
|
adamc@283
|
1428 newline,
|
adamc@311
|
1429 string "uw_error(ctx, FATAL, \"",
|
adamc@292
|
1430 string (ErrorMsg.spanToString loc),
|
adamc@292
|
1431 string ": %s\", ",
|
adamc@283
|
1432 p_exp env e,
|
adamc@283
|
1433 string ");",
|
adamc@283
|
1434 newline,
|
adamc@283
|
1435 string "tmp;",
|
adamc@283
|
1436 newline,
|
adamc@283
|
1437 string "})"]
|
adamc@741
|
1438 | EReturnBlob {blob, mimeType, t} =>
|
adamc@741
|
1439 box [string "({",
|
adamc@741
|
1440 newline,
|
adamc@741
|
1441 p_typ env t,
|
adamc@741
|
1442 space,
|
adamc@741
|
1443 string "tmp;",
|
adamc@741
|
1444 newline,
|
adamc@741
|
1445 string "uw_return_blob(ctx, ",
|
adamc@741
|
1446 p_exp env blob,
|
adamc@741
|
1447 string ", ",
|
adamc@741
|
1448 p_exp env mimeType,
|
adamc@741
|
1449 string ");",
|
adamc@741
|
1450 newline,
|
adamc@741
|
1451 string "tmp;",
|
adamc@741
|
1452 newline,
|
adamc@741
|
1453 string "})"]
|
adamc@1065
|
1454 | ERedirect (e, t) =>
|
adamc@1065
|
1455 box [string "({",
|
adamc@1065
|
1456 newline,
|
adamc@1065
|
1457 p_typ env t,
|
adamc@1065
|
1458 space,
|
adamc@1065
|
1459 string "tmp;",
|
adamc@1065
|
1460 newline,
|
adamc@1065
|
1461 string "uw_redirect(ctx, ",
|
adamc@1065
|
1462 p_exp env e,
|
adamc@1065
|
1463 string ");",
|
adamc@1065
|
1464 newline,
|
adamc@1065
|
1465 string "tmp;",
|
adamc@1065
|
1466 newline,
|
adamc@1065
|
1467 string "})"]
|
adamc@476
|
1468 | EApp ((EError (e, (TFun (_, ran), _)), loc), _) =>
|
adamc@476
|
1469 p_exp env (EError (e, ran), loc)
|
adamc@741
|
1470 | EApp ((EReturnBlob {blob, mimeType, t = (TFun (_, ran), _)}, loc), _) =>
|
adamc@741
|
1471 p_exp env (EReturnBlob {blob = blob, mimeType = mimeType, t = ran}, loc)
|
adamc@476
|
1472
|
adamc@922
|
1473 | EFfiApp ("Basis", "strcat", [e1, e2]) =>
|
adamc@922
|
1474 let
|
adamc@922
|
1475 fun flatten e =
|
adamc@922
|
1476 case #1 e of
|
adamc@922
|
1477 EFfiApp ("Basis", "strcat", [e1, e2]) => flatten e1 @ flatten e2
|
adamc@922
|
1478 | _ => [e]
|
adamc@922
|
1479 in
|
adamc@922
|
1480 case flatten e1 @ flatten e2 of
|
adamc@922
|
1481 [e1, e2] => box [string "uw_Basis_strcat(ctx, ",
|
adamc@922
|
1482 p_exp env e1,
|
adamc@922
|
1483 string ",",
|
adamc@922
|
1484 p_exp env e2,
|
adamc@922
|
1485 string ")"]
|
adamc@922
|
1486 | es => box [string "uw_Basis_mstrcat(ctx, ",
|
adamc@922
|
1487 p_list (p_exp env) es,
|
adamc@922
|
1488 string ", NULL)"]
|
adamc@922
|
1489 end
|
adamc@922
|
1490
|
adamc@765
|
1491 | EFfiApp (m, x, []) => box [string "uw_",
|
adamc@765
|
1492 p_ident m,
|
adamc@765
|
1493 string "_",
|
adamc@765
|
1494 p_ident x,
|
adamc@765
|
1495 string "(ctx)"]
|
adamc@765
|
1496
|
adamc@311
|
1497 | EFfiApp (m, x, es) => box [string "uw_",
|
adamc@316
|
1498 p_ident m,
|
adamc@53
|
1499 string "_",
|
adamc@316
|
1500 p_ident x,
|
adamc@117
|
1501 string "(ctx, ",
|
adamc@53
|
1502 p_list (p_exp env) es,
|
adamc@53
|
1503 string ")"]
|
adamc@316
|
1504 | EApp (f, args) =>
|
adamc@316
|
1505 parenIf par (box [p_exp' true env f,
|
adamc@316
|
1506 string "(ctx,",
|
adamc@316
|
1507 space,
|
adamc@316
|
1508 p_list_sep (box [string ",", space]) (p_exp env) args,
|
adamc@316
|
1509 string ")"])
|
adamc@29
|
1510
|
adamc@387
|
1511 | EUnop (s, e1) =>
|
adamc@387
|
1512 parenIf par (box [string s,
|
adamc@387
|
1513 space,
|
adamc@387
|
1514 p_exp' true env e1])
|
adamc@387
|
1515
|
adamc@387
|
1516 | EBinop (s, e1, e2) =>
|
adamc@389
|
1517 if Char.isAlpha (String.sub (s, size s - 1)) then
|
adamc@389
|
1518 box [string s,
|
adamc@390
|
1519 string "(",
|
adamc@389
|
1520 p_exp env e1,
|
adamc@389
|
1521 string ",",
|
adamc@389
|
1522 space,
|
adamc@389
|
1523 p_exp env e2,
|
adamc@389
|
1524 string ")"]
|
adamc@389
|
1525 else
|
adamc@389
|
1526 parenIf par (box [p_exp' true env e1,
|
adamc@389
|
1527 space,
|
adamc@389
|
1528 string s,
|
adamc@389
|
1529 space,
|
adamc@389
|
1530 p_exp' true env e2])
|
adamc@387
|
1531
|
adamc@29
|
1532 | ERecord (i, xes) => box [string "({",
|
adamc@29
|
1533 space,
|
adamc@29
|
1534 string "struct",
|
adamc@29
|
1535 space,
|
adamc@311
|
1536 string ("__uws_" ^ Int.toString i),
|
adamc@29
|
1537 space,
|
adamc@181
|
1538 string "tmp",
|
adamc@29
|
1539 space,
|
adamc@29
|
1540 string "=",
|
adamc@29
|
1541 space,
|
adamc@29
|
1542 string "{",
|
adamc@29
|
1543 p_list (fn (_, e) =>
|
adamc@29
|
1544 p_exp env e) xes,
|
adamc@29
|
1545 string "};",
|
adamc@29
|
1546 space,
|
adamc@181
|
1547 string "tmp;",
|
adamc@29
|
1548 space,
|
adamc@29
|
1549 string "})" ]
|
adamc@29
|
1550 | EField (e, x) =>
|
adamc@29
|
1551 box [p_exp' true env e,
|
adamc@311
|
1552 string ".__uwf_",
|
adamc@316
|
1553 p_ident x]
|
adamc@29
|
1554
|
adamc@182
|
1555 | ECase (e, pes, {disc, result}) =>
|
adamc@182
|
1556 let
|
adamc@182
|
1557 val final = newGoto ()
|
adamc@182
|
1558
|
adamc@182
|
1559 val body = foldl (fn ((p, e), body) =>
|
adamc@182
|
1560 let
|
adamc@182
|
1561 val exit = newGoto ()
|
adamc@182
|
1562 val (pr, _) = p_pat_preamble env p
|
adamc@182
|
1563 val (p, env) = p_pat (env,
|
adamc@182
|
1564 box [string "goto",
|
adamc@182
|
1565 space,
|
adamc@182
|
1566 exit,
|
adamc@182
|
1567 string ";"],
|
adamc@182
|
1568 0) p
|
adamc@182
|
1569 in
|
adamc@182
|
1570 box [body,
|
adamc@182
|
1571 box [string "{",
|
adamc@182
|
1572 newline,
|
adamc@182
|
1573 pr,
|
adamc@182
|
1574 newline,
|
adamc@182
|
1575 p,
|
adamc@182
|
1576 newline,
|
adamc@182
|
1577 string "result",
|
adamc@182
|
1578 space,
|
adamc@182
|
1579 string "=",
|
adamc@182
|
1580 space,
|
adamc@182
|
1581 p_exp env e,
|
adamc@182
|
1582 string ";",
|
adamc@182
|
1583 newline,
|
adamc@182
|
1584 string "goto",
|
adamc@182
|
1585 space,
|
adamc@182
|
1586 final,
|
adamc@182
|
1587 string ";",
|
adamc@182
|
1588 newline,
|
adamc@182
|
1589 string "}"],
|
adamc@182
|
1590 newline,
|
adamc@182
|
1591 exit,
|
adamc@182
|
1592 string ":",
|
adamc@182
|
1593 newline]
|
adamc@182
|
1594 end) (box []) pes
|
adamc@182
|
1595 in
|
adamc@182
|
1596 box [string "({",
|
adamc@182
|
1597 newline,
|
adamc@182
|
1598 p_typ env disc,
|
adamc@182
|
1599 space,
|
adamc@182
|
1600 string "disc0",
|
adamc@182
|
1601 space,
|
adamc@182
|
1602 string "=",
|
adamc@182
|
1603 space,
|
adamc@182
|
1604 p_exp env e,
|
adamc@182
|
1605 string ";",
|
adamc@182
|
1606 newline,
|
adamc@182
|
1607 p_typ env result,
|
adamc@182
|
1608 space,
|
adamc@182
|
1609 string "result;",
|
adamc@182
|
1610 newline,
|
adamc@182
|
1611 body,
|
adamc@311
|
1612 string "uw_error(ctx, FATAL, \"",
|
adamc@182
|
1613 string (ErrorMsg.spanToString loc),
|
adamc@182
|
1614 string ": pattern match failure\");",
|
adamc@182
|
1615 newline,
|
adamc@182
|
1616 final,
|
adamc@182
|
1617 string ":",
|
adamc@182
|
1618 space,
|
adamc@182
|
1619 string "result;",
|
adamc@182
|
1620 newline,
|
adamc@182
|
1621 string "})"]
|
adamc@182
|
1622 end
|
adamc@181
|
1623
|
adamc@311
|
1624 | EWrite e => box [string "(uw_write(ctx, ",
|
adamc@102
|
1625 p_exp env e,
|
adamc@311
|
1626 string "), uw_unit_v)"]
|
adamc@102
|
1627
|
adamc@106
|
1628 | ESeq (e1, e2) => box [string "(",
|
adamc@106
|
1629 p_exp env e1,
|
adamc@106
|
1630 string ",",
|
adamc@106
|
1631 space,
|
adamc@106
|
1632 p_exp env e2,
|
adamc@106
|
1633 string ")"]
|
adamc@269
|
1634 | ELet (x, t, e1, e2) => box [string "({",
|
adamc@269
|
1635 newline,
|
adamc@269
|
1636 p_typ env t,
|
adamc@269
|
1637 space,
|
adamc@311
|
1638 string "__uwr_",
|
adamc@316
|
1639 p_ident x,
|
adamc@272
|
1640 string "_",
|
adamc@272
|
1641 string (Int.toString (E.countERels env)),
|
adamc@269
|
1642 space,
|
adamc@269
|
1643 string "=",
|
adamc@269
|
1644 space,
|
adamc@269
|
1645 p_exp env e1,
|
adamc@269
|
1646 string ";",
|
adamc@269
|
1647 newline,
|
adamc@269
|
1648 p_exp (E.pushERel env x t) e2,
|
adamc@269
|
1649 string ";",
|
adamc@269
|
1650 newline,
|
adamc@269
|
1651 string "})"]
|
adamc@269
|
1652
|
adamc@282
|
1653 | EQuery {exps, tables, rnum, state, query, body, initial, prepared} =>
|
adamc@278
|
1654 let
|
adamc@316
|
1655 val exps = map (fn (x, t) => ("__uwf_" ^ ident x, t)) exps
|
adamc@278
|
1656 val tables = ListUtil.mapConcat (fn (x, xts) =>
|
adamc@316
|
1657 map (fn (x', t) => ("__uwf_" ^ ident x ^ ".__uwf_" ^ ident x', t)) xts)
|
adamc@278
|
1658 tables
|
adamc@638
|
1659
|
adamc@1168
|
1660 val sort = ListMergeSort.sort (fn ((s1, _), (s2, _)) => String.compare (s1, s2) = GREATER)
|
adamc@1168
|
1661 val outputs = sort exps @ sort tables
|
adamc@324
|
1662
|
adamc@324
|
1663 val wontLeakStrings = notLeaky env true state
|
adamc@324
|
1664 val wontLeakAnything = notLeaky env false state
|
adamc@867
|
1665
|
adamc@867
|
1666 val inputs =
|
adamc@867
|
1667 case prepared of
|
adamc@867
|
1668 NONE => []
|
adamc@867
|
1669 | SOME _ => getPargs query
|
adamc@867
|
1670
|
adamc@867
|
1671 fun doCols p_getcol =
|
adamc@867
|
1672 box [string "struct __uws_",
|
adamc@867
|
1673 string (Int.toString rnum),
|
adamc@867
|
1674 string " __uwr_r_",
|
adamc@867
|
1675 string (Int.toString (E.countERels env)),
|
adamc@867
|
1676 string ";",
|
adamc@867
|
1677 newline,
|
adamc@867
|
1678 p_typ env state,
|
adamc@867
|
1679 space,
|
adamc@867
|
1680 string "__uwr_acc_",
|
adamc@867
|
1681 string (Int.toString (E.countERels env + 1)),
|
adamc@867
|
1682 space,
|
adamc@867
|
1683 string "=",
|
adamc@867
|
1684 space,
|
adamc@867
|
1685 string "acc;",
|
adamc@867
|
1686 newline,
|
adamc@867
|
1687 newline,
|
adamc@1114
|
1688
|
adamc@1114
|
1689 if Settings.getDeadlines () then
|
adamc@1114
|
1690 box [string "uw_check_deadline(ctx);",
|
adamc@1114
|
1691 newline]
|
adamc@1114
|
1692 else
|
adamc@1114
|
1693 box [],
|
adamc@1114
|
1694
|
adamc@867
|
1695 p_list_sepi (box []) (fn i =>
|
adamc@867
|
1696 fn (proj, t) =>
|
adamc@867
|
1697 box [string "__uwr_r_",
|
adamc@867
|
1698 string (Int.toString (E.countERels env)),
|
adamc@867
|
1699 string ".",
|
adamc@867
|
1700 string proj,
|
adamc@867
|
1701 space,
|
adamc@867
|
1702 string "=",
|
adamc@867
|
1703 space,
|
adamc@880
|
1704 p_getcol {loc = loc,
|
adamc@880
|
1705 wontLeakStrings = wontLeakStrings,
|
adamc@867
|
1706 col = i,
|
adamc@867
|
1707 typ = sql_type_in env t},
|
adamc@867
|
1708 string ";",
|
adamc@867
|
1709 newline]) outputs,
|
adamc@867
|
1710 newline,
|
adamc@867
|
1711 newline,
|
adamc@867
|
1712
|
adamc@867
|
1713 string "acc",
|
adamc@867
|
1714 space,
|
adamc@867
|
1715 string "=",
|
adamc@867
|
1716 space,
|
adamc@867
|
1717 p_exp (E.pushERel
|
adamc@867
|
1718 (E.pushERel env "r" (TRecord rnum, loc))
|
adamc@867
|
1719 "acc" state)
|
adamc@867
|
1720 body,
|
adamc@867
|
1721 string ";",
|
adamc@867
|
1722 newline]
|
adamc@278
|
1723 in
|
adamc@640
|
1724 box [if wontLeakAnything then
|
adamc@704
|
1725 string "(uw_begin_region(ctx), "
|
adamc@324
|
1726 else
|
adamc@324
|
1727 box [],
|
adamc@324
|
1728 string "({",
|
adamc@278
|
1729 newline,
|
adamc@640
|
1730 p_typ env state,
|
adamc@640
|
1731 space,
|
adamc@640
|
1732 string "acc",
|
adamc@640
|
1733 space,
|
adamc@640
|
1734 string "=",
|
adamc@640
|
1735 space,
|
adamc@640
|
1736 p_exp env initial,
|
adamc@640
|
1737 string ";",
|
adamc@640
|
1738 newline,
|
adamc@867
|
1739 string "int dummy = (uw_begin_region(ctx), 0);",
|
adamc@640
|
1740 newline,
|
adamc@640
|
1741
|
adamc@282
|
1742 case prepared of
|
adamc@867
|
1743 NONE =>
|
adamc@867
|
1744 box [string "char *query = ",
|
adamc@867
|
1745 p_exp env query,
|
adamc@867
|
1746 string ";",
|
adamc@867
|
1747 newline,
|
adamc@867
|
1748 newline,
|
adamc@282
|
1749
|
adamc@867
|
1750 #query (Settings.currentDbms ())
|
adamc@867
|
1751 {loc = loc,
|
adamc@873
|
1752 cols = map (fn (_, t) => sql_type_in env t) outputs,
|
adamc@867
|
1753 doCols = doCols}]
|
adamc@879
|
1754 | SOME {id, query, nested} =>
|
adamc@867
|
1755 box [p_list_sepi newline
|
adamc@867
|
1756 (fn i => fn (e, t) =>
|
adamc@867
|
1757 box [p_sql_type t,
|
adamc@867
|
1758 space,
|
adamc@867
|
1759 string "arg",
|
adamc@867
|
1760 string (Int.toString (i + 1)),
|
adamc@867
|
1761 space,
|
adamc@867
|
1762 string "=",
|
adamc@867
|
1763 space,
|
adamc@867
|
1764 p_exp env e,
|
adamc@867
|
1765 string ";"])
|
adamc@867
|
1766 inputs,
|
adamc@867
|
1767 newline,
|
adamc@867
|
1768 newline,
|
adamc@640
|
1769
|
adamc@867
|
1770 #queryPrepared (Settings.currentDbms ())
|
adamc@867
|
1771 {loc = loc,
|
adamc@867
|
1772 id = id,
|
adamc@867
|
1773 query = query,
|
adamc@867
|
1774 inputs = map #2 inputs,
|
adamc@873
|
1775 cols = map (fn (_, t) => sql_type_in env t) outputs,
|
adamc@879
|
1776 doCols = doCols,
|
adamc@879
|
1777 nested = nested}],
|
adamc@278
|
1778 newline,
|
adamc@277
|
1779
|
adamc@324
|
1780 if wontLeakAnything then
|
adamc@324
|
1781 box [string "uw_end_region(ctx);",
|
adamc@324
|
1782 newline]
|
adamc@324
|
1783 else
|
adamc@324
|
1784 box [],
|
adamc@278
|
1785 string "acc;",
|
adamc@278
|
1786 newline,
|
adamc@704
|
1787 string "})",
|
adamc@704
|
1788 if wontLeakAnything then
|
adamc@704
|
1789 string ")"
|
adamc@704
|
1790 else
|
adamc@704
|
1791 box []]
|
adamc@278
|
1792 end
|
adamc@106
|
1793
|
adamc@307
|
1794 | EDml {dml, prepared} =>
|
adamc@337
|
1795 box [string "(uw_begin_region(ctx), ({",
|
adamc@307
|
1796 newline,
|
adamc@307
|
1797 case prepared of
|
adamc@307
|
1798 NONE => box [string "char *dml = ",
|
adamc@307
|
1799 p_exp env dml,
|
adamc@307
|
1800 string ";",
|
adamc@868
|
1801 newline,
|
adamc@868
|
1802 newline,
|
adamc@868
|
1803 #dml (Settings.currentDbms ()) loc]
|
adamc@879
|
1804 | SOME {id, dml = dml'} =>
|
adamc@307
|
1805 let
|
adamc@868
|
1806 val inputs = getPargs dml
|
adamc@307
|
1807 in
|
adamc@307
|
1808 box [p_list_sepi newline
|
adamc@307
|
1809 (fn i => fn (e, t) =>
|
adamc@307
|
1810 box [p_sql_type t,
|
adamc@307
|
1811 space,
|
adamc@307
|
1812 string "arg",
|
adamc@307
|
1813 string (Int.toString (i + 1)),
|
adamc@307
|
1814 space,
|
adamc@307
|
1815 string "=",
|
adamc@307
|
1816 space,
|
adamc@307
|
1817 p_exp env e,
|
adamc@307
|
1818 string ";"])
|
adamc@868
|
1819 inputs,
|
adamc@307
|
1820 newline,
|
adamc@307
|
1821 newline,
|
adamc@307
|
1822
|
adamc@868
|
1823 #dmlPrepared (Settings.currentDbms ()) {loc = loc,
|
adamc@868
|
1824 id = id,
|
adamc@868
|
1825 dml = dml',
|
adamc@868
|
1826 inputs = map #2 inputs}]
|
adamc@307
|
1827 end,
|
adamc@307
|
1828 newline,
|
adamc@307
|
1829 newline,
|
adamc@307
|
1830
|
adamc@337
|
1831 string "uw_end_region(ctx);",
|
adamc@337
|
1832 newline,
|
adamc@311
|
1833 string "uw_unit_v;",
|
adamc@307
|
1834 newline,
|
adamc@337
|
1835 string "}))"]
|
adamc@307
|
1836
|
adamc@338
|
1837 | ENextval {seq, prepared} =>
|
adamc@878
|
1838 box [string "({",
|
adamc@878
|
1839 newline,
|
adamc@878
|
1840 string "uw_Basis_int n;",
|
adamc@878
|
1841 newline,
|
adamc@869
|
1842
|
adamc@878
|
1843 case prepared of
|
adamc@878
|
1844 NONE => #nextval (Settings.currentDbms ()) {loc = loc,
|
adamc@878
|
1845 seqE = p_exp env seq,
|
adamc@878
|
1846 seqName = case #1 seq of
|
adamc@878
|
1847 EPrim (Prim.String s) => SOME s
|
adamc@878
|
1848 | _ => NONE}
|
adamc@879
|
1849 | SOME {id, query} => #nextvalPrepared (Settings.currentDbms ()) {loc = loc,
|
adamc@878
|
1850 id = id,
|
adamc@878
|
1851 query = query},
|
adamc@878
|
1852 newline,
|
adamc@878
|
1853 newline,
|
adamc@869
|
1854
|
adamc@878
|
1855 string "n;",
|
adamc@878
|
1856 newline,
|
adamc@878
|
1857 string "})"]
|
adamc@338
|
1858
|
adamc@1073
|
1859 | ESetval {seq, count} =>
|
adamc@1073
|
1860 box [string "({",
|
adamc@1073
|
1861 newline,
|
adamc@1073
|
1862
|
adamc@1073
|
1863 #setval (Settings.currentDbms ()) {loc = loc,
|
adamc@1073
|
1864 seqE = p_exp env seq,
|
adamc@1073
|
1865 count = p_exp env count},
|
adamc@1073
|
1866 newline,
|
adamc@1073
|
1867 newline,
|
adamc@1073
|
1868
|
adamc@1073
|
1869 string "uw_unit_v;",
|
adamc@1073
|
1870 newline,
|
adamc@1073
|
1871 string "})"]
|
adamc@1073
|
1872
|
adamc@1112
|
1873 | EUnurlify (e, t, true) =>
|
adamc@463
|
1874 let
|
adamc@463
|
1875 fun getIt () =
|
adamc@463
|
1876 if isUnboxable t then
|
adamc@1023
|
1877 unurlify false env t
|
adamc@463
|
1878 else
|
adamc@463
|
1879 box [string "({",
|
adamc@463
|
1880 newline,
|
adamc@463
|
1881 p_typ env t,
|
adamc@463
|
1882 string " *tmp = uw_malloc(ctx, sizeof(",
|
adamc@463
|
1883 p_typ env t,
|
adamc@463
|
1884 string "));",
|
adamc@463
|
1885 newline,
|
adamc@463
|
1886 string "*tmp = ",
|
adamc@1023
|
1887 unurlify false env t,
|
adamc@463
|
1888 string ";",
|
adamc@463
|
1889 newline,
|
adamc@463
|
1890 string "tmp;",
|
adamc@463
|
1891 newline,
|
adamc@463
|
1892 string "})"]
|
adamc@463
|
1893 in
|
adamc@463
|
1894 box [string "({",
|
adamc@463
|
1895 newline,
|
adamc@737
|
1896 string "uw_Basis_string request = uw_maybe_strdup(ctx, ",
|
adamc@463
|
1897 p_exp env e,
|
adamc@492
|
1898 string ");",
|
adamc@463
|
1899 newline,
|
adamc@463
|
1900 newline,
|
adamc@463
|
1901 string "(request ? ",
|
adamc@463
|
1902 getIt (),
|
adamc@463
|
1903 string " : NULL);",
|
adamc@463
|
1904 newline,
|
adamc@463
|
1905 string "})"]
|
adamc@463
|
1906 end
|
adamc@463
|
1907
|
adamc@1112
|
1908 | EUnurlify (e, t, false) =>
|
adamc@1112
|
1909 let
|
adamc@1112
|
1910 fun getIt () =
|
adamc@1112
|
1911 if isUnboxable t then
|
adamc@1112
|
1912 unurlify false env t
|
adamc@1112
|
1913 else
|
adamc@1112
|
1914 box [string "({",
|
adamc@1112
|
1915 newline,
|
adamc@1112
|
1916 p_typ env t,
|
adamc@1112
|
1917 string " *tmp = uw_malloc(ctx, sizeof(",
|
adamc@1112
|
1918 p_typ env t,
|
adamc@1112
|
1919 string "));",
|
adamc@1112
|
1920 newline,
|
adamc@1112
|
1921 string "*tmp = ",
|
adamc@1112
|
1922 unurlify false env t,
|
adamc@1112
|
1923 string ";",
|
adamc@1112
|
1924 newline,
|
adamc@1112
|
1925 string "tmp;",
|
adamc@1112
|
1926 newline,
|
adamc@1112
|
1927 string "})"]
|
adamc@1112
|
1928 in
|
adamc@1112
|
1929 box [string "({",
|
adamc@1112
|
1930 newline,
|
adamc@1112
|
1931 string "uw_Basis_string request = uw_maybe_strdup(ctx, ",
|
adamc@1112
|
1932 p_exp env e,
|
adamc@1112
|
1933 string ");",
|
adamc@1112
|
1934 newline,
|
adamc@1112
|
1935 newline,
|
adamc@1112
|
1936 unurlify false env t,
|
adamc@1112
|
1937 string ";",
|
adamc@1112
|
1938 newline,
|
adamc@1112
|
1939 string "})"]
|
adamc@1112
|
1940 end
|
adamc@1112
|
1941
|
adamc@29
|
1942 and p_exp env = p_exp' false env
|
adamc@29
|
1943
|
adamc@1114
|
1944 fun p_fun isRec env (fx, n, args, ran, e) =
|
adamc@129
|
1945 let
|
adamc@129
|
1946 val nargs = length args
|
adamc@129
|
1947 val env' = foldl (fn ((x, dom), env) => E.pushERel env x dom) env args
|
adamc@129
|
1948 in
|
adamc@129
|
1949 box [string "static",
|
adamc@129
|
1950 space,
|
adamc@129
|
1951 p_typ env ran,
|
adamc@129
|
1952 space,
|
adamc@316
|
1953 string ("__uwn_" ^ ident fx ^ "_" ^ Int.toString n),
|
adamc@129
|
1954 string "(",
|
adamc@129
|
1955 p_list_sep (box [string ",", space]) (fn x => x)
|
adamc@311
|
1956 (string "uw_context ctx" :: ListUtil.mapi (fn (i, (_, dom)) =>
|
adamc@129
|
1957 box [p_typ env dom,
|
adamc@129
|
1958 space,
|
adamc@129
|
1959 p_rel env' (nargs - i - 1)]) args),
|
adamc@129
|
1960 string ")",
|
adamc@129
|
1961 space,
|
adamc@129
|
1962 string "{",
|
adamc@129
|
1963 newline,
|
adamc@1114
|
1964 if isRec andalso Settings.getDeadlines () then
|
adamc@1114
|
1965 box [string "uw_check_deadline(ctx);",
|
adamc@1114
|
1966 newline]
|
adamc@1114
|
1967 else
|
adamc@1114
|
1968 box [],
|
adamc@638
|
1969 box [string "return(",
|
adamc@638
|
1970 p_exp env' e,
|
adamc@638
|
1971 string ");"],
|
adamc@129
|
1972 newline,
|
adamc@129
|
1973 string "}"]
|
adamc@129
|
1974 end
|
adamc@129
|
1975
|
adamc@129
|
1976 fun p_decl env (dAll as (d, _) : decl) =
|
adamc@29
|
1977 case d of
|
adamc@29
|
1978 DStruct (n, xts) =>
|
adamc@196
|
1979 let
|
adamc@196
|
1980 val env = E.declBinds env dAll
|
adamc@196
|
1981 in
|
adamc@196
|
1982 box [string "struct",
|
adamc@196
|
1983 space,
|
adamc@311
|
1984 string ("__uws_" ^ Int.toString n),
|
adamc@196
|
1985 space,
|
adamc@196
|
1986 string "{",
|
adamc@196
|
1987 newline,
|
adamc@196
|
1988 p_list_sep (box []) (fn (x, t) => box [p_typ env t,
|
adamc@196
|
1989 space,
|
adamc@311
|
1990 string "__uwf_",
|
adamc@316
|
1991 p_ident x,
|
adamc@196
|
1992 string ";",
|
adamc@196
|
1993 newline]) xts,
|
adamc@196
|
1994 string "};"]
|
adamc@196
|
1995 end
|
adamc@809
|
1996 | DDatatype dts =>
|
adamc@165
|
1997 let
|
adamc@809
|
1998 val dts = ListMergeSort.sort (fn ((dk1, _, _, _), (dk2, _, _, _)) =>
|
adamc@809
|
1999 dk1 = Enum andalso dk2 <> Enum) dts
|
adamc@809
|
2000
|
adamc@809
|
2001 fun p_one (Enum, x, n, xncs) =
|
adamc@809
|
2002 box [string "enum",
|
adamc@809
|
2003 space,
|
adamc@809
|
2004 string ("__uwe_" ^ ident x ^ "_" ^ Int.toString n),
|
adamc@809
|
2005 space,
|
adamc@809
|
2006 string "{",
|
adamc@809
|
2007 space,
|
adamc@809
|
2008 p_list_sep (box [string ",", space]) (fn (x, n, _) =>
|
adamc@809
|
2009 string ("__uwc_" ^ ident x ^ "_" ^ Int.toString n)) xncs,
|
adamc@809
|
2010 space,
|
adamc@809
|
2011 string "};"]
|
adamc@809
|
2012 | p_one (Option, _, _, _) = box []
|
adamc@809
|
2013 | p_one (Default, x, n, xncs) =
|
adamc@809
|
2014 let
|
adamc@809
|
2015 val xncsArgs = List.mapPartial (fn (x, n, NONE) => NONE
|
adamc@809
|
2016 | (x, n, SOME t) => SOME (x, n, t)) xncs
|
adamc@809
|
2017 in
|
adamc@809
|
2018 box [string "enum",
|
adamc@809
|
2019 space,
|
adamc@809
|
2020 string ("__uwe_" ^ ident x ^ "_" ^ Int.toString n),
|
adamc@809
|
2021 space,
|
adamc@809
|
2022 string "{",
|
adamc@809
|
2023 space,
|
adamc@809
|
2024 p_list_sep (box [string ",", space]) (fn (x, n, _) =>
|
adamc@809
|
2025 string ("__uwc_" ^ ident x ^ "_" ^ Int.toString n))
|
adamc@809
|
2026 xncs,
|
adamc@809
|
2027 space,
|
adamc@809
|
2028 string "};",
|
adamc@809
|
2029 newline,
|
adamc@809
|
2030 newline,
|
adamc@809
|
2031 string "struct",
|
adamc@809
|
2032 space,
|
adamc@809
|
2033 string ("__uwd_" ^ ident x ^ "_" ^ Int.toString n),
|
adamc@809
|
2034 space,
|
adamc@809
|
2035 string "{",
|
adamc@809
|
2036 newline,
|
adamc@809
|
2037 string "enum",
|
adamc@809
|
2038 space,
|
adamc@809
|
2039 string ("__uwe_" ^ ident x ^ "_" ^ Int.toString n),
|
adamc@809
|
2040 space,
|
adamc@809
|
2041 string "tag;",
|
adamc@809
|
2042 newline,
|
adamc@809
|
2043 box (case xncsArgs of
|
adamc@809
|
2044 [] => []
|
adamc@809
|
2045 | _ => [string "union",
|
adamc@809
|
2046 space,
|
adamc@809
|
2047 string "{",
|
adamc@809
|
2048 newline,
|
adamc@809
|
2049 p_list_sep newline (fn (x, n, t) => box [p_typ env t,
|
adamc@809
|
2050 space,
|
adamc@809
|
2051 string ("uw_" ^ ident x),
|
adamc@809
|
2052 string ";"]) xncsArgs,
|
adamc@809
|
2053 newline,
|
adamc@809
|
2054 string "}",
|
adamc@809
|
2055 space,
|
adamc@809
|
2056 string "data;",
|
adamc@809
|
2057 newline]),
|
adamc@809
|
2058 string "};"]
|
adamc@809
|
2059 end
|
adamc@165
|
2060 in
|
adamc@809
|
2061 p_list_sep (box []) p_one dts
|
adamc@188
|
2062 end
|
adamc@29
|
2063
|
adamc@196
|
2064 | DDatatypeForward _ => box []
|
adamc@196
|
2065
|
adamc@29
|
2066 | DVal (x, n, t, e) =>
|
adamc@29
|
2067 box [p_typ env t,
|
adamc@29
|
2068 space,
|
adamc@316
|
2069 string ("__uwn_" ^ ident x ^ "_" ^ Int.toString n),
|
adamc@29
|
2070 space,
|
adamc@29
|
2071 string "=",
|
adamc@29
|
2072 space,
|
adamc@29
|
2073 p_exp env e,
|
adamc@29
|
2074 string ";"]
|
adamc@1114
|
2075 | DFun vi => p_fun false env vi
|
adamc@129
|
2076 | DFunRec vis =>
|
adamc@29
|
2077 let
|
adamc@129
|
2078 val env = E.declBinds env dAll
|
adamc@29
|
2079 in
|
adamc@129
|
2080 box [p_list_sep newline (fn (fx, n, args, ran, _) =>
|
adamc@129
|
2081 box [string "static",
|
adamc@129
|
2082 space,
|
adamc@129
|
2083 p_typ env ran,
|
adamc@129
|
2084 space,
|
adamc@316
|
2085 string ("__uwn_" ^ ident fx ^ "_" ^ Int.toString n),
|
adamc@311
|
2086 string "(uw_context,",
|
adamc@129
|
2087 space,
|
adamc@129
|
2088 p_list_sep (box [string ",", space])
|
adamc@129
|
2089 (fn (_, dom) => p_typ env dom) args,
|
adamc@129
|
2090 string ");"]) vis,
|
adamc@29
|
2091 newline,
|
adamc@1114
|
2092 p_list_sep newline (p_fun true env) vis,
|
adamc@129
|
2093 newline]
|
adamc@29
|
2094 end
|
adamc@707
|
2095 | DTable (x, _, pk, csts) => box [string "/* SQL table ",
|
adamc@707
|
2096 string x,
|
adamc@707
|
2097 space,
|
adamc@707
|
2098 case pk of
|
adamc@707
|
2099 "" => box []
|
adamc@707
|
2100 | _ => box [string "keys",
|
adamc@707
|
2101 space,
|
adamc@707
|
2102 string pk,
|
adamc@707
|
2103 space],
|
adamc@707
|
2104 string "constraints",
|
adamc@707
|
2105 space,
|
adamc@707
|
2106 p_list (fn (x, v) => box [string x,
|
adamc@707
|
2107 space,
|
adamc@707
|
2108 string ":",
|
adamc@707
|
2109 space,
|
adamc@707
|
2110 string v]) csts,
|
adamc@707
|
2111 space,
|
adamc@707
|
2112 string " */",
|
adamc@707
|
2113 newline]
|
adamc@338
|
2114 | DSequence x => box [string "/* SQL sequence ",
|
adamc@338
|
2115 string x,
|
adamc@338
|
2116 string " */",
|
adamc@338
|
2117 newline]
|
adamc@754
|
2118 | DView (x, _, s) => box [string "/* SQL view ",
|
adamc@754
|
2119 string x,
|
adamc@754
|
2120 space,
|
adamc@754
|
2121 string "AS",
|
adamc@754
|
2122 space,
|
adamc@754
|
2123 string s,
|
adamc@754
|
2124 space,
|
adamc@754
|
2125 string " */",
|
adamc@754
|
2126 newline]
|
adamc@870
|
2127 | DDatabase _ => box []
|
adamc@870
|
2128 | DPreparedStatements _ => box []
|
adamc@282
|
2129
|
adamc@569
|
2130 | DJavaScript s => box [string "static char jslib[] = \"",
|
adam@1285
|
2131 string (String.toCString s),
|
adamc@569
|
2132 string "\";"]
|
adamc@725
|
2133 | DCookie s => box [string "/*",
|
adamc@725
|
2134 space,
|
adamc@725
|
2135 string "cookie",
|
adamc@725
|
2136 space,
|
adamc@725
|
2137 string s,
|
adamc@725
|
2138 space,
|
adamc@725
|
2139 string "*/"]
|
adamc@720
|
2140 | DStyle s => box [string "/*",
|
adamc@720
|
2141 space,
|
adamc@720
|
2142 string "style",
|
adamc@720
|
2143 space,
|
adamc@720
|
2144 string s,
|
adamc@720
|
2145 space,
|
adamc@720
|
2146 string "*/"]
|
adamc@569
|
2147
|
adamc@1075
|
2148 | DTask _ => box []
|
adamc@1073
|
2149
|
adamc@144
|
2150 datatype 'a search =
|
adamc@144
|
2151 Found of 'a
|
adamc@144
|
2152 | NotFound
|
adamc@144
|
2153 | Error
|
adamc@120
|
2154
|
adamc@467
|
2155 fun p_sqltype'' env (tAll as (t, loc)) =
|
adamc@275
|
2156 case t of
|
adamc@275
|
2157 TFfi ("Basis", "int") => "int8"
|
adamc@275
|
2158 | TFfi ("Basis", "float") => "float8"
|
adamc@275
|
2159 | TFfi ("Basis", "string") => "text"
|
adamc@275
|
2160 | TFfi ("Basis", "bool") => "bool"
|
adamc@438
|
2161 | TFfi ("Basis", "time") => "timestamp"
|
adamc@737
|
2162 | TFfi ("Basis", "blob") => "bytea"
|
adamc@682
|
2163 | TFfi ("Basis", "channel") => "int8"
|
adamc@682
|
2164 | TFfi ("Basis", "client") => "int4"
|
adamc@275
|
2165 | _ => (ErrorMsg.errorAt loc "Don't know SQL equivalent of type";
|
adamc@275
|
2166 Print.eprefaces' [("Type", p_typ env tAll)];
|
adamc@275
|
2167 "ERROR")
|
adamc@275
|
2168
|
adamc@467
|
2169 fun p_sqltype' env (tAll as (t, loc)) =
|
adamc@467
|
2170 case t of
|
adamc@467
|
2171 (TOption t, _) => p_sqltype'' env t
|
adamc@467
|
2172 | _ => p_sqltype'' env t ^ " NOT NULL"
|
adamc@467
|
2173
|
adamc@275
|
2174 fun p_sqltype env t = string (p_sqltype' env t)
|
adamc@101
|
2175
|
adamc@467
|
2176 fun p_sqltype_base' env t =
|
adamc@467
|
2177 case t of
|
adamc@467
|
2178 (TOption t, _) => p_sqltype'' env t
|
adamc@467
|
2179 | _ => p_sqltype'' env t
|
adamc@467
|
2180
|
adamc@467
|
2181 fun p_sqltype_base env t = string (p_sqltype_base' env t)
|
adamc@467
|
2182
|
adamc@467
|
2183 fun is_not_null t =
|
adamc@467
|
2184 case t of
|
adamc@467
|
2185 (TOption _, _) => false
|
adamc@467
|
2186 | _ => true
|
adamc@467
|
2187
|
adamc@734
|
2188 fun sigName fields =
|
adamc@734
|
2189 let
|
adamc@734
|
2190 fun inFields s = List.exists (fn (s', _) => s' = s) fields
|
adamc@734
|
2191
|
adamc@734
|
2192 fun getSigName n =
|
adamc@734
|
2193 let
|
adamc@734
|
2194 val s = "Sig" ^ Int.toString n
|
adamc@734
|
2195 in
|
adamc@734
|
2196 if inFields s then
|
adamc@734
|
2197 getSigName (n + 1)
|
adamc@734
|
2198 else
|
adamc@734
|
2199 s
|
adamc@734
|
2200 end
|
adamc@734
|
2201 in
|
adamc@734
|
2202 if inFields "Sig" then
|
adamc@734
|
2203 getSigName 0
|
adamc@734
|
2204 else
|
adamc@734
|
2205 "Sig"
|
adamc@734
|
2206 end
|
adamc@734
|
2207
|
adamc@101
|
2208 fun p_file env (ds, ps) =
|
adamc@29
|
2209 let
|
adamc@101
|
2210 val (pds, env) = ListUtil.foldlMap (fn (d, env) =>
|
adamc@638
|
2211 (p_decl env d,
|
adamc@638
|
2212 E.declBinds env d))
|
adamc@101
|
2213 env ds
|
adamc@144
|
2214
|
adamc@779
|
2215 fun flatFields always (t : typ) =
|
adamc@756
|
2216 case #1 t of
|
adamc@756
|
2217 TRecord i =>
|
adamc@756
|
2218 let
|
adamc@756
|
2219 val xts = E.lookupStruct env i
|
adamc@756
|
2220 in
|
adamc@779
|
2221 SOME ((always @ map #1 xts) :: List.concat (List.mapPartial (flatFields [] o #2) xts))
|
adamc@756
|
2222 end
|
adamc@759
|
2223 | TList (_, i) =>
|
adamc@759
|
2224 let
|
adamc@759
|
2225 val ts = E.lookupStruct env i
|
adamc@759
|
2226 in
|
adamc@759
|
2227 case ts of
|
adamc@779
|
2228 [("1", t'), ("2", _)] => flatFields [] t'
|
adamc@759
|
2229 | _ => raise Fail "CjrPrint: Bad struct for TList"
|
adamc@759
|
2230 end
|
adamc@756
|
2231 | _ => NONE
|
adamc@756
|
2232
|
adamc@1104
|
2233 val fields = foldl (fn ((ek, _, _, ts, _, _, _), fields) =>
|
adamc@144
|
2234 case ek of
|
adamc@735
|
2235 Link => fields
|
adamc@735
|
2236 | Rpc _ => fields
|
adamc@735
|
2237 | Action eff =>
|
adamc@280
|
2238 case List.nth (ts, length ts - 2) of
|
adamc@756
|
2239 (TRecord i, loc) =>
|
adamc@144
|
2240 let
|
adamc@144
|
2241 val xts = E.lookupStruct env i
|
adamc@779
|
2242 val extra = case eff of
|
adamc@779
|
2243 ReadCookieWrite => [sigName xts]
|
adamc@779
|
2244 | _ => []
|
adamc@144
|
2245 in
|
adamc@779
|
2246 case flatFields extra (TRecord i, loc) of
|
adamc@756
|
2247 NONE => raise Fail "CjrPrint: flatFields impossible"
|
adamc@756
|
2248 | SOME fields' => List.revAppend (fields', fields)
|
adamc@144
|
2249 end
|
adamc@144
|
2250 | _ => raise Fail "CjrPrint: Last argument of action isn't record")
|
adamc@756
|
2251 [] ps
|
adamc@756
|
2252
|
adamc@756
|
2253 val fields = foldl (fn (xts, fields) =>
|
adamc@756
|
2254 let
|
adamc@756
|
2255 val xtsSet = SS.addList (SS.empty, xts)
|
adamc@756
|
2256 in
|
adamc@756
|
2257 foldl (fn (x, fields) =>
|
adamc@756
|
2258 let
|
adamc@756
|
2259 val xtsSet' = Option.getOpt (SM.find (fields, x), SS.empty)
|
adamc@756
|
2260 in
|
adamc@756
|
2261 SM.insert (fields, x, SS.union (SS.delete (xtsSet, x),
|
adamc@756
|
2262 xtsSet'))
|
adamc@756
|
2263 end) fields xts
|
adamc@756
|
2264 end)
|
adamc@756
|
2265 SM.empty fields
|
adamc@144
|
2266
|
adamc@144
|
2267 val fnums = SM.foldli (fn (x, xs, fnums) =>
|
adamc@144
|
2268 let
|
adamc@144
|
2269 val unusable = SS.foldl (fn (x', unusable) =>
|
adamc@144
|
2270 case SM.find (fnums, x') of
|
adamc@144
|
2271 NONE => unusable
|
adamc@144
|
2272 | SOME n => IS.add (unusable, n))
|
adamc@144
|
2273 IS.empty xs
|
adamc@144
|
2274
|
adamc@144
|
2275 fun findAvailable n =
|
adamc@144
|
2276 if IS.member (unusable, n) then
|
adamc@144
|
2277 findAvailable (n + 1)
|
adamc@144
|
2278 else
|
adamc@144
|
2279 n
|
adamc@144
|
2280 in
|
adamc@144
|
2281 SM.insert (fnums, x, findAvailable 0)
|
adamc@144
|
2282 end)
|
adamc@144
|
2283 SM.empty fields
|
adamc@144
|
2284
|
adamc@734
|
2285 val cookies = List.mapPartial (fn (DCookie s, _) => SOME s | _ => NONE) ds
|
adamc@734
|
2286
|
adamc@144
|
2287 fun makeSwitch (fnums, i) =
|
adamc@144
|
2288 case SM.foldl (fn (n, NotFound) => Found n
|
adamc@144
|
2289 | (n, Error) => Error
|
adamc@144
|
2290 | (n, Found n') => if n = n' then
|
adamc@144
|
2291 Found n'
|
adamc@144
|
2292 else
|
adamc@144
|
2293 Error) NotFound fnums of
|
adamc@144
|
2294 NotFound => box [string "return",
|
adamc@144
|
2295 space,
|
adamc@144
|
2296 string "-1;"]
|
adamc@144
|
2297 | Found n => box [string "return",
|
adamc@144
|
2298 space,
|
adamc@144
|
2299 string (Int.toString n),
|
adamc@144
|
2300 string ";"]
|
adamc@144
|
2301 | Error =>
|
adamc@144
|
2302 let
|
adamc@144
|
2303 val cmap = SM.foldli (fn (x, n, cmap) =>
|
adamc@144
|
2304 let
|
adamc@144
|
2305 val ch = if i < size x then
|
adamc@144
|
2306 String.sub (x, i)
|
adamc@144
|
2307 else
|
adamc@144
|
2308 chr 0
|
adamc@144
|
2309
|
adamc@144
|
2310 val fnums = case CM.find (cmap, ch) of
|
adamc@144
|
2311 NONE => SM.empty
|
adamc@144
|
2312 | SOME fnums => fnums
|
adamc@144
|
2313 val fnums = SM.insert (fnums, x, n)
|
adamc@144
|
2314 in
|
adamc@144
|
2315 CM.insert (cmap, ch, fnums)
|
adamc@144
|
2316 end)
|
adamc@144
|
2317 CM.empty fnums
|
adamc@144
|
2318
|
adamc@144
|
2319 val cmap = CM.listItemsi cmap
|
adamc@144
|
2320 in
|
adamc@144
|
2321 case cmap of
|
adamc@144
|
2322 [(_, fnums)] =>
|
adamc@144
|
2323 box [string "if",
|
adamc@144
|
2324 space,
|
adamc@144
|
2325 string "(name[",
|
adamc@144
|
2326 string (Int.toString i),
|
adamc@144
|
2327 string "]",
|
adamc@144
|
2328 space,
|
adamc@144
|
2329 string "==",
|
adamc@144
|
2330 space,
|
adamc@144
|
2331 string "0)",
|
adamc@144
|
2332 space,
|
adamc@144
|
2333 string "return",
|
adamc@144
|
2334 space,
|
adamc@144
|
2335 string "-1;",
|
adamc@144
|
2336 newline,
|
adamc@144
|
2337 makeSwitch (fnums, i+1)]
|
adamc@144
|
2338 | _ =>
|
adamc@144
|
2339 box [string "switch",
|
adamc@144
|
2340 space,
|
adamc@144
|
2341 string "(name[",
|
adamc@144
|
2342 string (Int.toString i),
|
adamc@144
|
2343 string "])",
|
adamc@144
|
2344 space,
|
adamc@144
|
2345 string "{",
|
adamc@144
|
2346 newline,
|
adamc@144
|
2347 box (map (fn (ch, fnums) =>
|
adamc@144
|
2348 box [string "case",
|
adamc@144
|
2349 space,
|
adamc@144
|
2350 if ch = chr 0 then
|
adamc@144
|
2351 string "0:"
|
adamc@144
|
2352 else
|
adamc@144
|
2353 box [string "'",
|
adamc@144
|
2354 string (Char.toString ch),
|
adamc@144
|
2355 string "':"],
|
adamc@144
|
2356 newline,
|
adamc@144
|
2357 makeSwitch (fnums, i+1),
|
adamc@144
|
2358 newline]) cmap),
|
adamc@144
|
2359 string "default:",
|
adamc@144
|
2360 newline,
|
adamc@144
|
2361 string "return",
|
adamc@144
|
2362 space,
|
adamc@144
|
2363 string "-1;",
|
adamc@144
|
2364 newline,
|
adamc@144
|
2365 string "}"]
|
adamc@144
|
2366 end
|
adamc@144
|
2367
|
adamc@756
|
2368 fun getInput (x, t) =
|
adamc@756
|
2369 let
|
adamc@756
|
2370 val n = case SM.find (fnums, x) of
|
adamc@759
|
2371 NONE => raise Fail ("CjrPrint: Can't find " ^ x ^ " in fnums")
|
adamc@756
|
2372 | SOME n => n
|
adamc@756
|
2373
|
adamc@756
|
2374 val f = case t of
|
adamc@756
|
2375 (TFfi ("Basis", "bool"), _) => "optional_"
|
adamc@756
|
2376 | _ => ""
|
adamc@756
|
2377 in
|
adamc@756
|
2378 if isFile t then
|
adamc@756
|
2379 box [string "uw_input_",
|
adamc@756
|
2380 p_ident x,
|
adamc@756
|
2381 space,
|
adamc@756
|
2382 string "=",
|
adamc@756
|
2383 space,
|
adamc@756
|
2384 string "uw_get_file_input(ctx, ",
|
adamc@756
|
2385 string (Int.toString n),
|
adamc@756
|
2386 string ");",
|
adamc@756
|
2387 newline]
|
adamc@756
|
2388 else case #1 t of
|
adamc@756
|
2389 TRecord i =>
|
adamc@756
|
2390 let
|
adamc@756
|
2391 val xts = E.lookupStruct env i
|
adamc@756
|
2392 in
|
adamc@756
|
2393 box [string "uw_enter_subform(ctx, ",
|
adamc@756
|
2394 string (Int.toString n),
|
adamc@756
|
2395 string ");",
|
adamc@756
|
2396 newline,
|
adamc@756
|
2397 string "uw_input_",
|
adamc@756
|
2398 p_ident x,
|
adamc@756
|
2399 space,
|
adamc@756
|
2400 string "=",
|
adamc@756
|
2401 space,
|
adamc@756
|
2402 string "({",
|
adamc@756
|
2403 box [p_typ env t,
|
adamc@756
|
2404 space,
|
adamc@756
|
2405 string "result;",
|
adamc@756
|
2406 newline,
|
adamc@756
|
2407 p_list_sep (box [])
|
adamc@756
|
2408 (fn (x, t) =>
|
adamc@756
|
2409 box [p_typ env t,
|
adamc@756
|
2410 space,
|
adamc@756
|
2411 string "uw_input_",
|
adamc@756
|
2412 string x,
|
adamc@756
|
2413 string ";",
|
adamc@756
|
2414 newline])
|
adamc@756
|
2415 xts,
|
adamc@756
|
2416 newline,
|
adamc@756
|
2417 p_list_sep (box []) (fn (x, t) =>
|
adamc@756
|
2418 box [getInput (x, t),
|
adamc@756
|
2419 string "result.__uwf_",
|
adamc@756
|
2420 string x,
|
adamc@756
|
2421 space,
|
adamc@756
|
2422 string "=",
|
adamc@756
|
2423 space,
|
adamc@756
|
2424 string "uw_input_",
|
adamc@756
|
2425 string x,
|
adamc@756
|
2426 string ";",
|
adamc@756
|
2427 newline])
|
adamc@756
|
2428 xts,
|
adamc@756
|
2429 newline,
|
adamc@756
|
2430 string "result;",
|
adamc@756
|
2431 newline],
|
adamc@756
|
2432 string "});",
|
adamc@756
|
2433 newline,
|
adamc@756
|
2434 string "uw_leave_subform(ctx);"]
|
adamc@756
|
2435 end
|
adamc@759
|
2436 | TList (t', i) =>
|
adamc@759
|
2437 let
|
adamc@759
|
2438 val xts = E.lookupStruct env i
|
adamc@759
|
2439 val i' = case xts of
|
adamc@759
|
2440 [("1", (TRecord i', loc)), ("2", _)] => i'
|
adamc@759
|
2441 | _ => raise Fail "CjrPrint: Bad TList record [2]"
|
adamc@759
|
2442 val xts = E.lookupStruct env i'
|
adamc@759
|
2443 in
|
adamc@759
|
2444 box [string "{",
|
adamc@759
|
2445 newline,
|
adamc@759
|
2446 string "int status;",
|
adamc@759
|
2447 newline,
|
adamc@759
|
2448 string "uw_input_",
|
adamc@759
|
2449 p_ident x,
|
adamc@759
|
2450 space,
|
adamc@759
|
2451 string "=",
|
adamc@759
|
2452 space,
|
adamc@759
|
2453 string "NULL;",
|
adamc@759
|
2454 newline,
|
adamc@759
|
2455 string "for (status = uw_enter_subforms(ctx, ",
|
adamc@759
|
2456 string (Int.toString n),
|
adamc@759
|
2457 string "); status; status = uw_next_entry(ctx)) {",
|
adamc@759
|
2458 newline,
|
adamc@759
|
2459 box [p_typ env t,
|
adamc@759
|
2460 space,
|
adamc@759
|
2461 string "result",
|
adamc@759
|
2462 space,
|
adamc@759
|
2463 string "=",
|
adamc@759
|
2464 space,
|
adamc@759
|
2465 string "uw_malloc(ctx, sizeof(struct __uws_",
|
adamc@759
|
2466 string (Int.toString i),
|
adamc@759
|
2467 string "));",
|
adamc@759
|
2468 newline,
|
adamc@759
|
2469 box [string "{",
|
adamc@759
|
2470 p_list_sep (box [])
|
adamc@759
|
2471 (fn (x, t) =>
|
adamc@759
|
2472 box [p_typ env t,
|
adamc@759
|
2473 space,
|
adamc@759
|
2474 string "uw_input_",
|
adamc@759
|
2475 string x,
|
adamc@759
|
2476 string ";",
|
adamc@759
|
2477 newline])
|
adamc@759
|
2478 xts,
|
adamc@759
|
2479 newline,
|
adamc@759
|
2480 p_list_sep (box []) (fn (x, t) =>
|
adamc@759
|
2481 box [getInput (x, t),
|
adamc@759
|
2482 string "result->__uwf_1.__uwf_",
|
adamc@759
|
2483 string x,
|
adamc@759
|
2484 space,
|
adamc@759
|
2485 string "=",
|
adamc@759
|
2486 space,
|
adamc@759
|
2487 string "uw_input_",
|
adamc@759
|
2488 string x,
|
adamc@759
|
2489 string ";",
|
adamc@759
|
2490 newline])
|
adamc@759
|
2491 xts,
|
adamc@759
|
2492 string "}",
|
adamc@759
|
2493 newline],
|
adamc@759
|
2494 newline,
|
adamc@759
|
2495 string "result->__uwf_2 = uw_input_",
|
adamc@759
|
2496 p_ident x,
|
adamc@759
|
2497 string ";",
|
adamc@759
|
2498 newline,
|
adamc@759
|
2499 string "uw_input_",
|
adamc@759
|
2500 p_ident x,
|
adamc@759
|
2501 string " = result;",
|
adamc@759
|
2502 newline],
|
adamc@759
|
2503 string "}}",
|
adamc@759
|
2504 newline]
|
adamc@759
|
2505 end
|
adamc@756
|
2506 | _ =>
|
adamc@756
|
2507 box [string "request = uw_get_",
|
adamc@756
|
2508 string f,
|
adamc@756
|
2509 string "input(ctx, ",
|
adamc@756
|
2510 string (Int.toString n),
|
adamc@756
|
2511 string ");",
|
adamc@756
|
2512 newline,
|
adamc@756
|
2513 string "if (request == NULL)",
|
adamc@756
|
2514 newline,
|
adamc@756
|
2515 box [string "uw_error(ctx, FATAL, \"Missing input ",
|
adamc@756
|
2516 string x,
|
adamc@756
|
2517 string "\");"],
|
adamc@756
|
2518 newline,
|
adamc@756
|
2519 string "uw_input_",
|
adamc@756
|
2520 p_ident x,
|
adamc@756
|
2521 space,
|
adamc@756
|
2522 string "=",
|
adamc@756
|
2523 space,
|
adamc@1023
|
2524 unurlify true env t,
|
adamc@756
|
2525 string ";",
|
adamc@756
|
2526 newline]
|
adamc@756
|
2527 end
|
adamc@756
|
2528
|
adamc@1104
|
2529 fun p_page (ek, s, n, ts, ran, side, tellSig) =
|
adamc@144
|
2530 let
|
adamc@734
|
2531 val (ts, defInputs, inputsVar, fields) =
|
adamc@144
|
2532 case ek of
|
adamc@734
|
2533 Core.Link => (List.take (ts, length ts - 1), string "", string "", NONE)
|
adamc@734
|
2534 | Core.Rpc _ => (List.take (ts, length ts - 1), string "", string "", NONE)
|
adamc@731
|
2535 | Core.Action _ =>
|
adamc@280
|
2536 case List.nth (ts, length ts - 2) of
|
adamc@144
|
2537 (TRecord i, _) =>
|
adamc@144
|
2538 let
|
adamc@144
|
2539 val xts = E.lookupStruct env i
|
adamc@144
|
2540 in
|
adamc@280
|
2541 (List.take (ts, length ts - 2),
|
adamc@144
|
2542 box [box (map (fn (x, t) => box [p_typ env t,
|
adamc@144
|
2543 space,
|
adamc@311
|
2544 string "uw_input_",
|
adamc@316
|
2545 p_ident x,
|
adamc@144
|
2546 string ";",
|
adamc@144
|
2547 newline]) xts),
|
adamc@144
|
2548 newline,
|
adamc@756
|
2549 box (map getInput xts),
|
adamc@311
|
2550 string "struct __uws_",
|
adamc@144
|
2551 string (Int.toString i),
|
adamc@144
|
2552 space,
|
adamc@311
|
2553 string "uw_inputs",
|
adamc@144
|
2554 space,
|
adamc@144
|
2555 string "= {",
|
adamc@144
|
2556 newline,
|
adamc@311
|
2557 box (map (fn (x, _) => box [string "uw_input_",
|
adamc@316
|
2558 p_ident x,
|
adamc@144
|
2559 string ",",
|
adamc@144
|
2560 newline]) xts),
|
adamc@144
|
2561 string "};",
|
adamc@144
|
2562 newline],
|
adamc@144
|
2563 box [string ",",
|
adamc@144
|
2564 space,
|
adamc@734
|
2565 string "uw_inputs"],
|
adamc@734
|
2566 SOME xts)
|
adamc@144
|
2567 end
|
adamc@144
|
2568
|
adamc@144
|
2569 | _ => raise Fail "CjrPrint: Last argument to an action isn't a record"
|
adamc@734
|
2570
|
adamc@734
|
2571 fun couldWrite ek =
|
adamc@734
|
2572 case ek of
|
adamc@734
|
2573 Link => false
|
adamc@735
|
2574 | Action ef => ef = ReadCookieWrite
|
adamc@735
|
2575 | Rpc ef => ef = ReadCookieWrite
|
adamc@863
|
2576
|
adamc@863
|
2577 val s =
|
adamc@863
|
2578 case Settings.getUrlPrefix () of
|
adamc@863
|
2579 "" => s
|
adamc@863
|
2580 | "/" => s
|
adamc@863
|
2581 | prefix =>
|
adamc@863
|
2582 if size s > 0 andalso String.sub (s, 0) = #"/" then
|
adamc@863
|
2583 prefix ^ String.extract (s, 1, NONE)
|
adamc@863
|
2584 else
|
adamc@863
|
2585 prefix ^ s
|
adamc@144
|
2586 in
|
adamc@735
|
2587 box [string "if (!strncmp(request, \"",
|
adam@1285
|
2588 string (String.toCString s),
|
adamc@735
|
2589 string "\", ",
|
adamc@735
|
2590 string (Int.toString (size s)),
|
adamc@735
|
2591 string ") && (request[",
|
adamc@735
|
2592 string (Int.toString (size s)),
|
adamc@735
|
2593 string "] == 0 || request[",
|
adamc@735
|
2594 string (Int.toString (size s)),
|
adamc@735
|
2595 string "] == '/')) {",
|
adamc@735
|
2596 newline,
|
adamc@735
|
2597 string "request += ",
|
adamc@735
|
2598 string (Int.toString (size s)),
|
adamc@735
|
2599 string ";",
|
adamc@735
|
2600 newline,
|
adamc@735
|
2601 string "if (*request == '/') ++request;",
|
adamc@735
|
2602 newline,
|
adamc@735
|
2603 if couldWrite ek then
|
adamc@734
|
2604 box [string "{",
|
adamc@734
|
2605 newline,
|
adamc@734
|
2606 string "uw_Basis_string sig = ",
|
adamc@734
|
2607 case fields of
|
adamc@734
|
2608 NONE => string "uw_Basis_requestHeader(ctx, \"UrWeb-Sig\")"
|
adamc@734
|
2609 | SOME fields =>
|
adamc@734
|
2610 case SM.find (fnums, sigName fields) of
|
adamc@734
|
2611 NONE => raise Fail "CjrPrint: sig name wasn't assigned a number"
|
adamc@734
|
2612 | SOME inum =>
|
adamc@734
|
2613 string ("uw_get_input(ctx, " ^ Int.toString inum ^ ")"),
|
adamc@734
|
2614 string ";",
|
adamc@734
|
2615 newline,
|
adamc@734
|
2616 string "if (sig == NULL) uw_error(ctx, FATAL, \"Missing cookie signature\");",
|
adamc@734
|
2617 newline,
|
adamc@734
|
2618 string "if (strcmp(sig, uw_cookie_sig(ctx)))",
|
adamc@734
|
2619 newline,
|
adamc@734
|
2620 box [string "uw_error(ctx, FATAL, \"Wrong cookie signature\");",
|
adamc@734
|
2621 newline],
|
adamc@734
|
2622 string "}",
|
adamc@734
|
2623 newline]
|
adamc@734
|
2624 else
|
adamc@734
|
2625 box [],
|
adamc@609
|
2626 box (case ek of
|
adamc@731
|
2627 Core.Rpc _ => [string "uw_write_header(ctx, \"Content-type: text/plain\\r\\n\");",
|
adamc@731
|
2628 newline]
|
adamc@609
|
2629 | _ => [string "uw_write_header(ctx, \"Content-type: text/html\\r\\n\");",
|
adamc@609
|
2630 newline,
|
adamc@609
|
2631 string "uw_write_header(ctx, \"Content-script-type: text/javascript\\r\\n\");",
|
adamc@609
|
2632 newline,
|
adamc@804
|
2633 string "uw_write(ctx, begin_xhtml);",
|
adamc@643
|
2634 newline,
|
adamc@643
|
2635 string "uw_set_script_header(ctx, \"",
|
adamc@812
|
2636 let
|
adamc@812
|
2637 val scripts =
|
adamc@812
|
2638 case side of
|
adamc@693
|
2639 ServerOnly => ""
|
adamc@1111
|
2640 | _ =>
|
adamc@1111
|
2641 let
|
adamc@1111
|
2642 val scripts =
|
adamc@1111
|
2643 "<script src=\\\""
|
adamc@1111
|
2644 ^ OS.Path.joinDirFile {dir = Settings.getUrlPrefix (),
|
adamc@1111
|
2645 file = "app.js"}
|
adamc@1111
|
2646 ^ "\\\"></script>\\n"
|
adamc@1111
|
2647 in
|
adamc@1111
|
2648 foldl (fn (x, scripts) =>
|
adamc@1111
|
2649 scripts
|
adamc@1111
|
2650 ^ "<script src=\\\"" ^ x ^ "\\\"></script>\\n")
|
adamc@1111
|
2651 scripts (Settings.getScripts ())
|
adamc@1111
|
2652 end
|
adamc@812
|
2653 in
|
adamc@812
|
2654 string scripts
|
adamc@812
|
2655 end,
|
adamc@643
|
2656 string "\");",
|
adamc@609
|
2657 newline]),
|
adamc@1038
|
2658 string "uw_set_needs_push(ctx, ",
|
adamc@1038
|
2659 string (case side of
|
adamc@1038
|
2660 ServerAndPullAndPush => "1"
|
adamc@1038
|
2661 | _ => "0"),
|
adamc@1038
|
2662 string ");",
|
adamc@1038
|
2663 newline,
|
adamc@736
|
2664 string "uw_set_needs_sig(ctx, ",
|
adamc@1104
|
2665 string (if tellSig then
|
adamc@736
|
2666 "1"
|
adamc@736
|
2667 else
|
adamc@736
|
2668 "0"),
|
adamc@736
|
2669 string ");",
|
adamc@736
|
2670 newline,
|
adamc@682
|
2671 string "uw_login(ctx);",
|
adamc@682
|
2672 newline,
|
adamc@144
|
2673 box [string "{",
|
adamc@144
|
2674 newline,
|
adamc@144
|
2675 box (ListUtil.mapi (fn (i, t) => box [p_typ env t,
|
adamc@144
|
2676 space,
|
adamc@144
|
2677 string "arg",
|
adamc@144
|
2678 string (Int.toString i),
|
adamc@144
|
2679 space,
|
adamc@144
|
2680 string "=",
|
adamc@144
|
2681 space,
|
adamc@1023
|
2682 unurlify false env t,
|
adamc@144
|
2683 string ";",
|
adamc@144
|
2684 newline]) ts),
|
adamc@144
|
2685 defInputs,
|
adamc@609
|
2686 box (case ek of
|
adamc@731
|
2687 Core.Rpc _ => [p_typ env ran,
|
adamc@731
|
2688 space,
|
adamc@731
|
2689 string "it0",
|
adamc@731
|
2690 space,
|
adamc@731
|
2691 string "=",
|
adamc@731
|
2692 space]
|
adamc@609
|
2693 | _ => []),
|
adamc@144
|
2694 p_enamed env n,
|
adamc@144
|
2695 string "(",
|
adamc@144
|
2696 p_list_sep (box [string ",", space])
|
adamc@144
|
2697 (fn x => x)
|
adamc@272
|
2698 (string "ctx"
|
adamc@280
|
2699 :: ListUtil.mapi (fn (i, _) => string ("arg" ^ Int.toString i)) ts),
|
adamc@144
|
2700 inputsVar,
|
adamc@311
|
2701 string ", uw_unit_v);",
|
adamc@144
|
2702 newline,
|
adamc@609
|
2703 box (case ek of
|
adamc@731
|
2704 Core.Rpc _ => [urlify env ran]
|
adamc@609
|
2705 | _ => [string "uw_write(ctx, \"</html>\");",
|
adamc@609
|
2706 newline]),
|
adamc@144
|
2707 string "return;",
|
adamc@144
|
2708 newline,
|
adamc@144
|
2709 string "}",
|
adamc@144
|
2710 newline,
|
adamc@144
|
2711 string "}"]
|
adamc@144
|
2712 ]
|
adamc@144
|
2713 end
|
adamc@144
|
2714
|
adamc@144
|
2715 val pds' = map p_page ps
|
adamc@275
|
2716
|
adamc@870
|
2717 val hasDb = ref false
|
adamc@870
|
2718 val tables = ref []
|
adamc@872
|
2719 val views = ref []
|
adamc@870
|
2720 val sequences = ref []
|
adamc@870
|
2721 val dbstring = ref ""
|
adamc@870
|
2722 val expunge = ref 0
|
adamc@870
|
2723 val initialize = ref 0
|
adamc@870
|
2724 val prepped = ref []
|
adamc@275
|
2725
|
adamc@870
|
2726 val () = app (fn d =>
|
adamc@870
|
2727 case #1 d of
|
adamc@870
|
2728 DDatabase {name = x, expunge = y, initialize = z} => (hasDb := true;
|
adamc@870
|
2729 dbstring := x;
|
adamc@870
|
2730 expunge := y;
|
adamc@870
|
2731 initialize := z)
|
adamc@870
|
2732 | DTable (s, xts, _, _) => tables := (s, map (fn (x, t) =>
|
adamc@870
|
2733 (x, sql_type_in env t)) xts) :: !tables
|
adamc@872
|
2734 | DView (s, xts, _) => views := (s, map (fn (x, t) =>
|
adamc@872
|
2735 (x, sql_type_in env t)) xts) :: !views
|
adamc@870
|
2736 | DSequence s => sequences := s :: !sequences
|
adamc@870
|
2737 | DPreparedStatements ss => prepped := ss
|
adamc@870
|
2738 | _ => ()) ds
|
adamc@377
|
2739
|
adamc@870
|
2740 val hasDb = !hasDb
|
adamc@734
|
2741
|
adamc@734
|
2742 val cookies = List.mapPartial (fn (DCookie s, _) => SOME s | _ => NONE) ds
|
adamc@734
|
2743
|
adamc@734
|
2744 val cookieCode = foldl (fn (cookie, acc) =>
|
adamc@734
|
2745 SOME (case acc of
|
adamc@734
|
2746 NONE => string ("uw_unnull(uw_Basis_get_cookie(ctx, \""
|
adamc@734
|
2747 ^ cookie ^ "\"))")
|
adamc@734
|
2748 | SOME acc => box [string ("uw_Basis_strcat(ctx, uw_unnull(uw_Basis_get_cookie(ctx, \""
|
adamc@734
|
2749 ^ cookie ^ "\")), uw_Basis_strcat(ctx, \"/\", "),
|
adamc@734
|
2750 acc,
|
adamc@734
|
2751 string "))"]))
|
adamc@734
|
2752 NONE cookies
|
adamc@770
|
2753
|
adamc@770
|
2754 fun makeChecker (name, rules : Settings.rule list) =
|
adamc@1094
|
2755 box [string "static int ",
|
adamc@770
|
2756 string name,
|
adamc@770
|
2757 string "(const char *s) {",
|
adamc@770
|
2758 newline,
|
adamc@770
|
2759 box [p_list_sep (box [])
|
adamc@770
|
2760 (fn rule =>
|
adamc@770
|
2761 box [string "if (!str",
|
adamc@770
|
2762 case #kind rule of
|
adamc@770
|
2763 Settings.Exact => box [string "cmp(s, \"",
|
adam@1285
|
2764 string (String.toCString (#pattern rule)),
|
adamc@770
|
2765 string "\"))"]
|
adamc@770
|
2766 | Settings.Prefix => box [string "ncmp(s, \"",
|
adam@1285
|
2767 string (String.toCString (#pattern rule)),
|
adamc@770
|
2768 string "\", ",
|
adamc@770
|
2769 string (Int.toString (size (#pattern rule))),
|
adamc@770
|
2770 string "))"],
|
adamc@770
|
2771 string " return ",
|
adamc@770
|
2772 string (case #action rule of
|
adamc@770
|
2773 Settings.Allow => "1"
|
adamc@770
|
2774 | Settings.Deny => "0"),
|
adamc@770
|
2775 string ";",
|
adamc@770
|
2776 newline]) rules,
|
adamc@770
|
2777 string "return 0;",
|
adamc@770
|
2778 newline],
|
adamc@770
|
2779 string "}",
|
adamc@770
|
2780 newline]
|
adamc@1073
|
2781
|
adamc@1075
|
2782 val initializers = List.mapPartial (fn (DTask (Initialize, e), _) => SOME e | _ => NONE) ds
|
adamc@1263
|
2783
|
adamc@1263
|
2784 val now = Time.now ()
|
adamc@1263
|
2785 val nowD = Date.fromTimeUniv now
|
adamc@1263
|
2786 val rfcFmt = "%a, %d %b %Y %H:%M:%S"
|
adamc@29
|
2787 in
|
adamc@1263
|
2788 box [string "#include \"",
|
adamc@1263
|
2789 string (OS.Path.joinDirFile {dir = Config.includ,
|
adamc@1263
|
2790 file = "config.h"}),
|
adamc@1263
|
2791 string "\"",
|
adamc@1263
|
2792 newline,
|
adamc@1263
|
2793 string "#include <stdio.h>",
|
adamc@144
|
2794 newline,
|
adamc@144
|
2795 string "#include <stdlib.h>",
|
adamc@144
|
2796 newline,
|
adamc@272
|
2797 string "#include <string.h>",
|
adamc@272
|
2798 newline,
|
adamc@390
|
2799 string "#include <math.h>",
|
adamc@390
|
2800 newline,
|
adamc@1263
|
2801 string "#include <time.h>",
|
adamc@1263
|
2802 newline,
|
adamc@432
|
2803 if hasDb then
|
adamc@866
|
2804 box [string ("#include <" ^ #header (Settings.currentDbms ()) ^ ">"),
|
adamc@432
|
2805 newline]
|
adamc@432
|
2806 else
|
adamc@432
|
2807 box [],
|
adamc@764
|
2808 p_list_sep (box []) (fn s => box [string "#include \"",
|
adamc@764
|
2809 string s,
|
adamc@764
|
2810 string "\"",
|
adamc@764
|
2811 newline]) (Settings.getHeaders ()),
|
adamc@378
|
2812 string "#include \"",
|
adamc@378
|
2813 string (OS.Path.joinDirFile {dir = Config.includ,
|
adamc@378
|
2814 file = "urweb.h"}),
|
adamc@378
|
2815 string "\"",
|
adamc@101
|
2816 newline,
|
adamc@101
|
2817 newline,
|
adamc@804
|
2818
|
adamc@1164
|
2819 #code (Settings.currentProtocol ()) (),
|
adamc@1164
|
2820
|
adamc@870
|
2821 if hasDb then
|
adamc@870
|
2822 #init (Settings.currentDbms ()) {dbstring = !dbstring,
|
adamc@870
|
2823 prepared = !prepped,
|
adamc@870
|
2824 tables = !tables,
|
adamc@872
|
2825 views = !views,
|
adamc@870
|
2826 sequences = !sequences}
|
adamc@870
|
2827 else
|
adamc@891
|
2828 box [string "void uw_client_init(void) { };",
|
adamc@891
|
2829 newline,
|
adamc@891
|
2830 string "void uw_db_init(uw_context ctx) { };",
|
adamc@870
|
2831 newline,
|
adamc@870
|
2832 string "int uw_db_begin(uw_context ctx) { return 0; };",
|
adamc@870
|
2833 newline,
|
adamc@1094
|
2834 string "void uw_db_close(uw_context ctx) { };",
|
adamc@1094
|
2835 newline,
|
adamc@870
|
2836 string "int uw_db_commit(uw_context ctx) { return 0; };",
|
adamc@870
|
2837 newline,
|
adamc@870
|
2838 string "int uw_db_rollback(uw_context ctx) { return 0; };"],
|
adamc@870
|
2839 newline,
|
adamc@870
|
2840 newline,
|
adamc@870
|
2841
|
adamc@804
|
2842 string "static const char begin_xhtml[] = \"<?xml version=\\\"1.0\\\" encoding=\\\"utf-8\\\" ?>\\n<!DOCTYPE html PUBLIC \\\"-//W3C//DTD XHTML 1.0 Transitional//EN\\\" \\\"http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd\\\">\\n<html xmlns=\\\"http://www.w3.org/1999/xhtml\\\" xml:lang=\\\"en\\\" lang=\\\"en\\\">\";",
|
adamc@804
|
2843 newline,
|
adamc@804
|
2844 newline,
|
adamc@804
|
2845
|
adamc@101
|
2846 p_list_sep newline (fn x => x) pds,
|
adamc@101
|
2847 newline,
|
adamc@144
|
2848 newline,
|
adamc@1094
|
2849 string "static int uw_input_num(const char *name) {",
|
adamc@144
|
2850 newline,
|
adamc@144
|
2851 makeSwitch (fnums, 0),
|
adamc@144
|
2852 string "}",
|
adamc@144
|
2853 newline,
|
adamc@144
|
2854 newline,
|
adamc@770
|
2855
|
adamc@770
|
2856 makeChecker ("uw_check_url", Settings.getUrlRules ()),
|
adamc@770
|
2857 newline,
|
adamc@770
|
2858
|
adamc@770
|
2859 makeChecker ("uw_check_mime", Settings.getMimeRules ()),
|
adamc@770
|
2860 newline,
|
adamc@734
|
2861
|
adamc@734
|
2862 string "extern void uw_sign(const char *in, char *out);",
|
adamc@734
|
2863 newline,
|
adamc@734
|
2864 string "extern int uw_hash_blocksize;",
|
adamc@734
|
2865 newline,
|
adamc@1094
|
2866 string "static uw_Basis_string uw_cookie_sig(uw_context ctx) {",
|
adamc@734
|
2867 newline,
|
adamc@734
|
2868 box [string "uw_Basis_string r = uw_malloc(ctx, uw_hash_blocksize);",
|
adamc@734
|
2869 newline,
|
adamc@734
|
2870 string "uw_sign(",
|
adamc@734
|
2871 case cookieCode of
|
adamc@734
|
2872 NONE => string "\"\""
|
adamc@734
|
2873 | SOME code => code,
|
adamc@734
|
2874 string ", r);",
|
adamc@734
|
2875 newline,
|
adamc@734
|
2876 string "return uw_Basis_makeSigString(ctx, r);",
|
adamc@734
|
2877 newline],
|
adamc@734
|
2878 string "}",
|
adamc@734
|
2879 newline,
|
adamc@734
|
2880 newline,
|
adamc@734
|
2881
|
adamc@1094
|
2882 string "static void uw_handle(uw_context ctx, char *request) {",
|
adamc@101
|
2883 newline,
|
adamc@863
|
2884 string "if (!strcmp(request, \"",
|
adamc@863
|
2885 string (OS.Path.joinDirFile {dir = Settings.getUrlPrefix (),
|
adamc@863
|
2886 file = "app.js"}),
|
adamc@863
|
2887 string "\")) {",
|
adamc@569
|
2888 newline,
|
adamc@1263
|
2889 box [string "uw_Basis_string ims = uw_Basis_requestHeader(ctx, \"If-modified-since\");",
|
adamc@1263
|
2890 newline,
|
adamc@1263
|
2891 string ("if (ims && !strcmp(ims, \"" ^ Date.fmt rfcFmt nowD ^ "\")) {"),
|
adamc@1263
|
2892 newline,
|
adamc@1263
|
2893 box [string "uw_clear_headers(ctx);",
|
adamc@1263
|
2894 newline,
|
adamc@1263
|
2895 string "uw_write_header(ctx, \"HTTP/1.1 304 Not Modified\\r\\n\");",
|
adamc@1263
|
2896 newline,
|
adamc@1263
|
2897 string "return;",
|
adamc@1263
|
2898 newline],
|
adamc@1263
|
2899 string "}",
|
adamc@1263
|
2900 newline,
|
adamc@1263
|
2901 newline,
|
adamc@1263
|
2902 string "uw_write_header(ctx, \"Content-type: text/javascript\\r\\n\");",
|
adamc@1263
|
2903 newline,
|
adamc@1263
|
2904 string ("uw_write_header(ctx, \"Last-modified: " ^ Date.fmt rfcFmt nowD ^ "\\r\\n\");"),
|
adamc@569
|
2905 newline,
|
adamc@569
|
2906 string "uw_write(ctx, jslib);",
|
adamc@569
|
2907 newline,
|
adamc@569
|
2908 string "return;",
|
adamc@569
|
2909 newline],
|
adamc@569
|
2910 string "}",
|
adamc@569
|
2911 newline,
|
adamc@101
|
2912 p_list_sep newline (fn x => x) pds',
|
adamc@101
|
2913 newline,
|
adamc@1110
|
2914 string "uw_clear_headers(ctx);",
|
adamc@1110
|
2915 newline,
|
adamc@1110
|
2916 string "uw_write_header(ctx, \"HTTP/1.1 404 Not Found\\r\\nContent-type: text/plain\\r\\n\");",
|
adamc@1110
|
2917 newline,
|
adamc@1110
|
2918 string "uw_write(ctx, \"Not Found\");",
|
adamc@387
|
2919 newline,
|
adamc@101
|
2920 string "}",
|
adamc@275
|
2921 newline,
|
adamc@275
|
2922 newline,
|
adamc@870
|
2923
|
adamc@432
|
2924 if hasDb then
|
adamc@1094
|
2925 box [string "static void uw_expunger(uw_context ctx, uw_Basis_client cli) {",
|
adamc@870
|
2926 newline,
|
adamc@870
|
2927 box [p_enamed env (!expunge),
|
adamc@870
|
2928 string "(ctx, cli);",
|
adamc@870
|
2929 newline],
|
adamc@870
|
2930 string "}",
|
adamc@870
|
2931 newline,
|
adamc@870
|
2932 newline,
|
adamc@870
|
2933
|
adamc@1094
|
2934 string "static void uw_initializer(uw_context ctx) {",
|
adamc@870
|
2935 newline,
|
adamc@1073
|
2936 box [p_list_sep (box []) (fn e => box [p_exp env e,
|
adamc@1073
|
2937 string ";",
|
adamc@1073
|
2938 newline]) initializers,
|
adamc@1073
|
2939 p_enamed env (!initialize),
|
adamc@870
|
2940 string "(ctx, uw_unit_v);",
|
adamc@870
|
2941 newline],
|
adamc@870
|
2942 string "}",
|
adamc@870
|
2943 newline]
|
adamc@432
|
2944 else
|
adamc@1094
|
2945 box [string "static void uw_expunger(uw_context ctx, uw_Basis_client cli) { };",
|
adamc@687
|
2946 newline,
|
adamc@1094
|
2947 string "static void uw_initializer(uw_context ctx) { };",
|
adamc@1094
|
2948 newline],
|
adamc@1094
|
2949
|
adamc@1094
|
2950 string "uw_app uw_application = {",
|
adamc@1094
|
2951 p_list_sep (box [string ",", newline]) string
|
adamc@1094
|
2952 [Int.toString (SM.foldl Int.max 0 fnums + 1),
|
adamc@1094
|
2953 Int.toString (Settings.getTimeout ()),
|
adamc@1094
|
2954 "\"" ^ Settings.getUrlPrefix () ^ "\"",
|
adamc@1094
|
2955 "uw_client_init", "uw_initializer", "uw_expunger",
|
adamc@1094
|
2956 "uw_db_init", "uw_db_begin", "uw_db_commit", "uw_db_rollback", "uw_db_close",
|
adamc@1094
|
2957 "uw_handle",
|
adamc@1094
|
2958 "uw_input_num", "uw_cookie_sig", "uw_check_url", "uw_check_mime"],
|
adamc@1094
|
2959 string "};",
|
adamc@1094
|
2960 newline]
|
adamc@29
|
2961 end
|
adamc@29
|
2962
|
adamc@274
|
2963 fun p_sql env (ds, _) =
|
adamc@274
|
2964 let
|
adamc@274
|
2965 val (pps, _) = ListUtil.foldlMap
|
adamc@274
|
2966 (fn (dAll as (d, _), env) =>
|
adamc@274
|
2967 let
|
adamc@274
|
2968 val pp = case d of
|
adamc@707
|
2969 DTable (s, xts, pk, csts) =>
|
adamc@274
|
2970 box [string "CREATE TABLE ",
|
adamc@274
|
2971 string s,
|
adamc@274
|
2972 string "(",
|
adamc@274
|
2973 p_list (fn (x, t) =>
|
adamc@874
|
2974 let
|
adamc@874
|
2975 val t = sql_type_in env t
|
adamc@874
|
2976 in
|
adamc@874
|
2977 box [string "uw_",
|
adamc@874
|
2978 string (CharVector.map Char.toLower x),
|
adamc@874
|
2979 space,
|
adamc@874
|
2980 string (#p_sql_type (Settings.currentDbms ()) t),
|
adamc@874
|
2981 case t of
|
adamc@874
|
2982 Nullable _ => box []
|
adamc@874
|
2983 | _ => string " NOT NULL"]
|
adamc@874
|
2984 end) xts,
|
adamc@707
|
2985 case (pk, csts) of
|
adamc@707
|
2986 ("", []) => box []
|
adamc@707
|
2987 | _ => string ",",
|
adamc@704
|
2988 cut,
|
adamc@707
|
2989 case pk of
|
adamc@707
|
2990 "" => box []
|
adamc@707
|
2991 | _ => box [string "PRIMARY",
|
adamc@707
|
2992 space,
|
adamc@707
|
2993 string "KEY",
|
adamc@707
|
2994 space,
|
adamc@707
|
2995 string "(",
|
adamc@707
|
2996 string pk,
|
adamc@707
|
2997 string ")",
|
adamc@707
|
2998 case csts of
|
adamc@707
|
2999 [] => box []
|
adamc@707
|
3000 | _ => string ",",
|
adamc@707
|
3001 newline],
|
adamc@704
|
3002 p_list_sep (box [string ",", newline])
|
adamc@704
|
3003 (fn (x, c) =>
|
adamc@704
|
3004 box [string "CONSTRAINT",
|
adamc@704
|
3005 space,
|
adamc@704
|
3006 string s,
|
adamc@704
|
3007 string "_",
|
adamc@704
|
3008 string x,
|
adamc@704
|
3009 space,
|
adamc@704
|
3010 string c]) csts,
|
adamc@704
|
3011 newline,
|
adamc@274
|
3012 string ");",
|
adamc@274
|
3013 newline,
|
adamc@274
|
3014 newline]
|
adamc@338
|
3015 | DSequence s =>
|
adamc@877
|
3016 box [string (#createSequence (Settings.currentDbms ()) s),
|
adamc@338
|
3017 string ";",
|
adamc@338
|
3018 newline,
|
adamc@338
|
3019 newline]
|
adamc@754
|
3020 | DView (s, xts, q) =>
|
adamc@754
|
3021 box [string "CREATE VIEW",
|
adamc@754
|
3022 space,
|
adamc@754
|
3023 string s,
|
adamc@754
|
3024 space,
|
adamc@754
|
3025 string "AS",
|
adamc@754
|
3026 space,
|
adamc@754
|
3027 string q,
|
adamc@754
|
3028 string ";",
|
adamc@754
|
3029 newline,
|
adamc@754
|
3030 newline]
|
adamc@274
|
3031 | _ => box []
|
adamc@274
|
3032 in
|
adamc@274
|
3033 (pp, E.declBinds env dAll)
|
adamc@274
|
3034 end)
|
adamc@274
|
3035 env ds
|
adamc@274
|
3036 in
|
adamc@882
|
3037 box (string (#sqlPrefix (Settings.currentDbms ())) :: pps)
|
adamc@274
|
3038 end
|
adamc@274
|
3039
|
adamc@29
|
3040 end
|