Ur/Web: src/cjr_print.sml annotate

annotate src/cjr_print.sml @ 1905:cd1cfecc8c72

Remove autogenerated config.h.in from version control Signed-off-by: Anders Kaseorg <andersk@mit.edu> --- .hgignore | 1 + include/urweb/config.h.in | 104 ---------------------------------------------- 2 files changed, 1 insertion(+), 104 deletions(-) delete mode 100644 include/urweb/config.h.in

author	Anders Kaseorg <andersk@mit.edu>
date	Fri, 22 Nov 2013 09:36:14 -0500
parents	0354df1b6849
children	1a04b1edded2

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

Mercurial > urweb

annotate src/cjr_print.sml @ 1905:cd1cfecc8c72