Mercurial > urweb

annotate src/cjr_print.sml @ 1739:c414850f206f

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Add support for -boot flag, which allows in-tree execution of Ur/Web The boot flag rewrites most hardcoded paths to point to the build directory, and also forces static compilation. This is convenient for developing Ur/Web, or if you cannot 'sudo make install' Ur/Web. The following changes were made: * Header files were moved to include/urweb instead of include; this lets FFI users point their C_INCLUDE_PATH at this directory at write <urweb/urweb.h>. For internal Ur/Web executables, we simply pass -I$PATH/include/urweb as normal. * Differentiate between LIB and SRCLIB; SRCLIB is Ur and JavaScript source files, while LIB is compiled products from libtool. For in-tree compilation these live in different places. * No longer reference Config for paths; instead use Settings; these settings can be changed dynamically by Compiler.enableBoot () (TODO: add a disableBoot function.) * config.h is now generated directly in include/urweb/config.h, for consistency's sake (especially since it gets installed along with the rest of the headers!) * All of the autotools build products got updated. * The linkStatic field in protocols now only contains the name of the build product, and not the absolute path. Future users have to be careful not to reference the Settings files to early, lest they get an old version (this was the source of two bugs during development of this patch.)
author Edward Z. Yang <ezyang@mit.edu>
date Wed, 02 May 2012 17:17:57 -0400
parents 27e731a65934
children 95dd9f427bb2
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, \"",
adamc@292 1620 string (ErrorMsg.spanToString loc),
adamc@292 1621 string ": %s\", ",
adam@1524 1622 p_exp' false false env e,
adamc@283 1623 string ");",
adamc@283 1624 newline,
adamc@283 1625 string "tmp;",
adamc@283 1626 newline,
adamc@283 1627 string "})"]
adamc@741 1628 | EReturnBlob {blob, mimeType, t} =>
adamc@741 1629 box [string "({",
adamc@741 1630 newline,
adam@1663 1631 string "uw_Basis_blob",
adam@1663 1632 space,
adam@1663 1633 string "blob",
adam@1663 1634 space,
adam@1663 1635 string "=",
adam@1663 1636 space,
adam@1663 1637 p_exp' false false env blob,
adam@1663 1638 string ";",
adam@1663 1639 newline,
adam@1663 1640 string "uw_Basis_string",
adam@1663 1641 space,
adam@1663 1642 string "mimeType",
adam@1663 1643 space,
adam@1663 1644 string "=",
adam@1663 1645 space,
adam@1663 1646 p_exp' false false env mimeType,
adam@1663 1647 string ";",
adam@1663 1648 newline,
adamc@741 1649 p_typ env t,
adamc@741 1650 space,
adamc@741 1651 string "tmp;",
adamc@741 1652 newline,
adam@1663 1653 string "uw_return_blob(ctx, blob, mimeType);",
adamc@741 1654 newline,
adamc@741 1655 string "tmp;",
adamc@741 1656 newline,
adamc@741 1657 string "})"]
adamc@1065 1658 | ERedirect (e, t) =>
adamc@1065 1659 box [string "({",
adamc@1065 1660 newline,
adamc@1065 1661 p_typ env t,
adamc@1065 1662 space,
adamc@1065 1663 string "tmp;",
adamc@1065 1664 newline,
adamc@1065 1665 string "uw_redirect(ctx, ",
adam@1524 1666 p_exp' false false env e,
adamc@1065 1667 string ");",
adamc@1065 1668 newline,
adamc@1065 1669 string "tmp;",
adamc@1065 1670 newline,
adamc@1065 1671 string "})"]
adamc@476 1672 | EApp ((EError (e, (TFun (_, ran), _)), loc), _) =>
adam@1524 1673 p_exp' false false env (EError (e, ran), loc)
adamc@741 1674 | EApp ((EReturnBlob {blob, mimeType, t = (TFun (_, ran), _)}, loc), _) =>
adam@1524 1675 p_exp' false false env (EReturnBlob {blob = blob, mimeType = mimeType, t = ran}, loc)
adamc@476 1676
adam@1663 1677 | EFfiApp ("Basis", "strcat", [(e1, _), (e2, _)]) =>
adamc@922 1678 let
adamc@922 1679 fun flatten e =
adamc@922 1680 case #1 e of
adam@1663 1681 EFfiApp ("Basis", "strcat", [(e1, _), (e2, _)]) => flatten e1 @ flatten e2
adamc@922 1682 | _ => [e]
adam@1663 1683
adam@1663 1684 val es = flatten e1 @ flatten e2
adam@1663 1685 val t = (TFfi ("Basis", "string"), loc)
adam@1663 1686 val es = map (fn e => (e, t)) es
adamc@922 1687 in
adam@1663 1688 case es of
adam@1663 1689 [_, _] => pFuncall env ("Basis", "strcat", es, NONE)
adam@1663 1690 | _ => pFuncall env ("Basis", "mstrcat", es, SOME "NULL")
adamc@922 1691 end
adamc@922 1692
adam@1663 1693 | EFfiApp (m, x, es) => pFuncall env (m, x, es, NONE)
adamc@316 1694 | EApp (f, args) =>
adam@1524 1695 let
adam@1664 1696 fun getSig n =
adam@1524 1697 let
adam@1524 1698 val (_, t) = E.lookupENamed env n
adam@1524 1699
adam@1524 1700 fun getSig (t, args) =
adam@1524 1701 case #1 t of
adam@1524 1702 TFun (dom, t) => getSig (t, dom :: args)
adam@1524 1703 | _ => (args, t)
adam@1664 1704 in
adam@1664 1705 getSig (t, [])
adam@1664 1706 end
adam@1524 1707
adam@1664 1708 fun default () =
adam@1664 1709 case (#1 f, args) of
adam@1664 1710 (ENamed n, _ :: _ :: _) =>
adam@1664 1711 let
adam@1664 1712 val (args', ret) = getSig n
adam@1664 1713 val args = ListPair.zip (args, args')
adam@1664 1714 in
adam@1664 1715 parenIf par (box [string "({",
adam@1664 1716 newline,
adam@1664 1717 p_list_sepi newline
adam@1664 1718 (fn i => fn (e, t) =>
adam@1664 1719 box [p_typ env t,
adam@1664 1720 space,
adam@1664 1721 string ("arg" ^ Int.toString i),
adam@1664 1722 space,
adam@1664 1723 string "=",
adam@1664 1724 space,
adam@1664 1725 p_exp' false false env e,
adam@1664 1726 string ";"])
adam@1664 1727 args,
adam@1664 1728 newline,
adam@1664 1729 p_exp' false false env f,
adam@1664 1730 string "(ctx,",
adam@1664 1731 space,
adam@1664 1732 p_list_sepi (box [string ",", space])
adam@1664 1733 (fn i => fn _ =>
adam@1664 1734 string ("arg" ^ Int.toString i)) args,
adam@1664 1735 string ");",
adam@1664 1736 newline,
adam@1664 1737 string "})"])
adam@1664 1738 end
adam@1664 1739 | _ =>
adam@1664 1740 parenIf par (box [p_exp' true false env f,
adam@1664 1741 string "(ctx,",
adam@1664 1742 space,
adam@1664 1743 p_list_sep (box [string ",", space]) (p_exp' false false env) args,
adam@1664 1744 string ")"])
adam@1664 1745
adam@1664 1746 fun isSelf n =
adam@1664 1747 let
adam@1664 1748 val (argts, ret) = getSig n
adam@1524 1749 in
adam@1524 1750 parenIf par (box [string "({",
adam@1524 1751 newline,
adam@1524 1752 p_list_sepi newline
adam@1524 1753 (fn i => fn (e, t) =>
adam@1524 1754 box [p_typ env t,
adam@1524 1755 space,
adam@1524 1756 string ("rearg" ^ Int.toString i),
adam@1524 1757 space,
adam@1524 1758 string "=",
adam@1524 1759 space,
adam@1524 1760 p_exp' false false env e,
adam@1524 1761 string ";"])
adam@1524 1762 (ListPair.zip (args, argts)),
adam@1524 1763 newline,
adam@1524 1764 p_typ env ret,
adam@1524 1765 space,
adam@1524 1766 string "tmp;",
adam@1524 1767 newline,
adam@1524 1768 p_list_sepi newline
adam@1524 1769 (fn i => fn _ =>
adam@1524 1770 box [p_rel env (E.countERels env - 1 - i),
adam@1524 1771 space,
adam@1524 1772 string "=",
adam@1524 1773 space,
adam@1524 1774 string ("rearg" ^ Int.toString i ^ ";")]) args,
adam@1524 1775 newline,
adam@1524 1776 string "goto restart;",
adam@1524 1777 newline,
adam@1524 1778 string "tmp;",
adam@1524 1779 newline,
adam@1524 1780 string "})"])
adam@1524 1781 end
adam@1524 1782 in
adam@1524 1783 case #1 f of
adam@1524 1784 ENamed n => if SOME n = !self andalso tail then
adam@1524 1785 isSelf n
adam@1524 1786 else
adam@1524 1787 default ()
adam@1524 1788 | _ => default ()
adam@1524 1789 end
adamc@29 1790
adamc@387 1791 | EUnop (s, e1) =>
adamc@387 1792 parenIf par (box [string s,
adamc@387 1793 space,
adam@1524 1794 p_exp' true false env e1])
adamc@387 1795
adamc@387 1796 | EBinop (s, e1, e2) =>
adam@1619 1797 if s <> "fdiv" andalso Char.isAlpha (String.sub (s, size s - 1)) then
adamc@389 1798 box [string s,
adamc@390 1799 string "(",
adam@1524 1800 p_exp' false false env e1,
adamc@389 1801 string ",",
adamc@389 1802 space,
adam@1524 1803 p_exp' false false env e2,
adamc@389 1804 string ")"]
adam@1619 1805 else if s = "/" orelse s = "%" then
adam@1619 1806 box [string "({",
adam@1619 1807 newline,
adam@1619 1808 string "uw_Basis_int",
adam@1619 1809 space,
adam@1619 1810 string "dividend",
adam@1619 1811 space,
adam@1619 1812 string "=",
adam@1619 1813 space,
adam@1619 1814 p_exp env e1,
adam@1619 1815 string ",",
adam@1619 1816 space,
adam@1619 1817 string "divisor",
adam@1619 1818 space,
adam@1619 1819 string "=",
adam@1619 1820 space,
adam@1619 1821 p_exp env e2,
adam@1619 1822 string ";",
adam@1619 1823 newline,
adam@1619 1824 string "if",
adam@1619 1825 space,
adam@1619 1826 string "(divisor",
adam@1619 1827 space,
adam@1619 1828 string "==",
adam@1619 1829 space,
adam@1619 1830 string "0)",
adam@1619 1831 newline,
adam@1619 1832 box [string "uw_error(ctx, FATAL, \"",
adam@1619 1833 string (ErrorMsg.spanToString loc),
adam@1619 1834 string ": division by zero\");",
adam@1619 1835 newline],
adam@1619 1836 string "dividend",
adam@1619 1837 space,
adam@1619 1838 string s,
adam@1619 1839 space,
adam@1619 1840 string "divisor;",
adam@1619 1841 newline,
adam@1619 1842 string "})"]
adamc@389 1843 else
adam@1524 1844 parenIf par (box [p_exp' true false env e1,
adamc@389 1845 space,
adam@1619 1846 string (if s = "fdiv" then "/" else s),
adamc@389 1847 space,
adam@1524 1848 p_exp' true false env e2])
adamc@387 1849
adam@1431 1850 | ERecord (0, _) => string "0"
adam@1431 1851
adamc@29 1852 | ERecord (i, xes) => box [string "({",
adamc@29 1853 space,
adamc@29 1854 string "struct",
adamc@29 1855 space,
adamc@311 1856 string ("__uws_" ^ Int.toString i),
adamc@29 1857 space,
adamc@181 1858 string "tmp",
adamc@29 1859 space,
adamc@29 1860 string "=",
adamc@29 1861 space,
adamc@29 1862 string "{",
adamc@29 1863 p_list (fn (_, e) =>
adam@1524 1864 p_exp' false false env e) xes,
adamc@29 1865 string "};",
adamc@29 1866 space,
adamc@181 1867 string "tmp;",
adamc@29 1868 space,
adamc@29 1869 string "})" ]
adamc@29 1870 | EField (e, x) =>
adam@1524 1871 box [p_exp' true false env e,
adamc@311 1872 string ".__uwf_",
adamc@316 1873 p_ident x]
adamc@29 1874
adamc@182 1875 | ECase (e, pes, {disc, result}) =>
adam@1431 1876 box [string "({",
adam@1431 1877 newline,
adam@1431 1878 p_typ env disc,
adam@1431 1879 space,
adam@1431 1880 string "disc",
adam@1431 1881 space,
adam@1431 1882 string "=",
adam@1431 1883 space,
adam@1524 1884 p_exp' false false env e,
adam@1431 1885 string ";",
adam@1431 1886 newline,
adam@1431 1887 newline,
adam@1431 1888 foldr (fn ((p, e), body) =>
adam@1431 1889 let
adam@1431 1890 val pm = p_patMatch (env, "disc") p
adam@1516 1891 val (pb, env') = p_patBind (env, "disc") p
adam@1431 1892 in
adam@1431 1893 box [pm,
adam@1431 1894 space,
adam@1431 1895 string "?",
adam@1431 1896 space,
adam@1516 1897 if E.countERels env' = E.countERels env then
adam@1524 1898 p_exp' false tail env e
adam@1516 1899 else
adam@1516 1900 box [string "({",
adam@1516 1901 pb,
adam@1524 1902 p_exp' false tail env' e,
adam@1516 1903 string ";",
adam@1516 1904 newline,
adam@1516 1905 string "})"],
adam@1431 1906 newline,
adam@1431 1907 space,
adam@1431 1908 string ":",
adam@1431 1909 space,
adam@1431 1910 body]
adam@1431 1911 end) (box [string "({",
adam@1431 1912 newline,
adam@1431 1913 p_typ env result,
adam@1431 1914 space,
adam@1431 1915 string "tmp;",
adam@1431 1916 newline,
adam@1431 1917 string "uw_error(ctx, FATAL, \"",
adam@1431 1918 string (ErrorMsg.spanToString loc),
adam@1431 1919 string ": pattern match failure\");",
adam@1431 1920 newline,
adam@1431 1921 string "tmp;",
adam@1431 1922 newline,
adam@1431 1923 string "})"]) pes,
adam@1431 1924 string ";",
adam@1431 1925 newline,
adam@1431 1926 string "})"]
adamc@181 1927
adamc@311 1928 | EWrite e => box [string "(uw_write(ctx, ",
adam@1524 1929 p_exp' false false env e,
adam@1431 1930 string "), 0)"]
adamc@102 1931
adam@1391 1932 | ESeq (e1, e2) =>
adam@1391 1933 let
adam@1391 1934 val useRegion = potentiallyFancy e1
adam@1391 1935 in
adam@1391 1936 box [string "(",
adam@1391 1937 if useRegion then
adam@1391 1938 box [string "uw_begin_region(ctx),",
adam@1391 1939 space]
adam@1391 1940 else
adam@1391 1941 box [],
adam@1524 1942 p_exp' false false env e1,
adam@1391 1943 string ",",
adam@1391 1944 space,
adam@1391 1945 if useRegion then
adam@1391 1946 box [string "uw_end_region(ctx),",
adam@1391 1947 space]
adam@1391 1948 else
adam@1391 1949 box [],
adam@1524 1950 p_exp' false tail env e2,
adam@1391 1951 string ")"]
adam@1391 1952 end
adam@1391 1953 | ELet (x, t, e1, e2) =>
adam@1391 1954 let
adam@1391 1955 val useRegion = notLeaky env false t andalso potentiallyFancy e1
adam@1391 1956 in
adam@1391 1957 box [string "({",
adam@1391 1958 newline,
adam@1391 1959 p_typ env t,
adam@1391 1960 space,
adam@1391 1961 string "__uwr_",
adam@1391 1962 p_ident x,
adam@1391 1963 string "_",
adam@1391 1964 string (Int.toString (E.countERels env)),
adam@1391 1965 space,
adam@1391 1966 string "=",
adam@1391 1967 space,
adam@1391 1968 if useRegion then
adam@1391 1969 box [string "(uw_begin_region(ctx),",
adam@1391 1970 space]
adam@1391 1971 else
adam@1391 1972 box [],
adam@1524 1973 p_exp' false false env e1,
adam@1391 1974 if useRegion then
adam@1391 1975 string ")"
adam@1391 1976 else
adam@1391 1977 box [],
adam@1391 1978 string ";",
adam@1391 1979 newline,
adam@1391 1980 if useRegion then
adam@1391 1981 box [string "uw_end_region(ctx);",
adam@1391 1982 newline]
adam@1391 1983 else
adam@1391 1984 box [],
adam@1524 1985 p_exp' false tail (E.pushERel env x t) e2,
adam@1391 1986 string ";",
adam@1391 1987 newline,
adam@1391 1988 string "})"]
adam@1391 1989 end
adamc@269 1990
adamc@282 1991 | EQuery {exps, tables, rnum, state, query, body, initial, prepared} =>
adamc@278 1992 let
adamc@316 1993 val exps = map (fn (x, t) => ("__uwf_" ^ ident x, t)) exps
adamc@278 1994 val tables = ListUtil.mapConcat (fn (x, xts) =>
adamc@316 1995 map (fn (x', t) => ("__uwf_" ^ ident x ^ ".__uwf_" ^ ident x', t)) xts)
adamc@278 1996 tables
adamc@638 1997
adamc@1168 1998 val sort = ListMergeSort.sort (fn ((s1, _), (s2, _)) => String.compare (s1, s2) = GREATER)
adamc@1168 1999 val outputs = sort exps @ sort tables
adamc@324 2000
adamc@324 2001 val wontLeakStrings = notLeaky env true state
adamc@324 2002 val wontLeakAnything = notLeaky env false state
adamc@867 2003
adamc@867 2004 val inputs =
adamc@867 2005 case prepared of
adamc@867 2006 NONE => []
adamc@867 2007 | SOME _ => getPargs query
adamc@867 2008
adamc@867 2009 fun doCols p_getcol =
adamc@867 2010 box [string "struct __uws_",
adamc@867 2011 string (Int.toString rnum),
adamc@867 2012 string " __uwr_r_",
adamc@867 2013 string (Int.toString (E.countERels env)),
adamc@867 2014 string ";",
adamc@867 2015 newline,
adamc@867 2016 p_typ env state,
adamc@867 2017 space,
adamc@867 2018 string "__uwr_acc_",
adamc@867 2019 string (Int.toString (E.countERels env + 1)),
adamc@867 2020 space,
adamc@867 2021 string "=",
adamc@867 2022 space,
adamc@867 2023 string "acc;",
adamc@867 2024 newline,
adamc@867 2025 newline,
adamc@1114 2026
adamc@1114 2027 if Settings.getDeadlines () then
adamc@1114 2028 box [string "uw_check_deadline(ctx);",
adamc@1114 2029 newline]
adamc@1114 2030 else
adamc@1114 2031 box [],
adamc@1114 2032
adamc@867 2033 p_list_sepi (box []) (fn i =>
adamc@867 2034 fn (proj, t) =>
adamc@867 2035 box [string "__uwr_r_",
adamc@867 2036 string (Int.toString (E.countERels env)),
adamc@867 2037 string ".",
adamc@867 2038 string proj,
adamc@867 2039 space,
adamc@867 2040 string "=",
adamc@867 2041 space,
adamc@880 2042 p_getcol {loc = loc,
adamc@880 2043 wontLeakStrings = wontLeakStrings,
adamc@867 2044 col = i,
adamc@867 2045 typ = sql_type_in env t},
adamc@867 2046 string ";",
adamc@867 2047 newline]) outputs,
adamc@867 2048 newline,
adamc@867 2049 newline,
adamc@867 2050
adamc@867 2051 string "acc",
adamc@867 2052 space,
adamc@867 2053 string "=",
adamc@867 2054 space,
adam@1524 2055 p_exp' false false (E.pushERel
adam@1524 2056 (E.pushERel env "r" (TRecord rnum, loc))
adam@1524 2057 "acc" state)
adam@1524 2058 body,
adamc@867 2059 string ";",
adamc@867 2060 newline]
adamc@278 2061 in
adamc@640 2062 box [if wontLeakAnything then
adamc@704 2063 string "(uw_begin_region(ctx), "
adamc@324 2064 else
adamc@324 2065 box [],
adamc@324 2066 string "({",
adamc@278 2067 newline,
adamc@640 2068 p_typ env state,
adamc@640 2069 space,
adamc@640 2070 string "acc",
adamc@640 2071 space,
adamc@640 2072 string "=",
adamc@640 2073 space,
adam@1524 2074 p_exp' false false env initial,
adamc@640 2075 string ";",
adamc@640 2076 newline,
adamc@867 2077 string "int dummy = (uw_begin_region(ctx), 0);",
adamc@640 2078 newline,
adamc@640 2079
adamc@282 2080 case prepared of
adamc@867 2081 NONE =>
adamc@867 2082 box [string "char *query = ",
adam@1524 2083 p_exp' false false env query,
adamc@867 2084 string ";",
adamc@867 2085 newline,
adamc@867 2086 newline,
adamc@282 2087
adamc@867 2088 #query (Settings.currentDbms ())
adamc@867 2089 {loc = loc,
adamc@873 2090 cols = map (fn (_, t) => sql_type_in env t) outputs,
adamc@867 2091 doCols = doCols}]
adamc@879 2092 | SOME {id, query, nested} =>
adamc@867 2093 box [p_list_sepi newline
adamc@867 2094 (fn i => fn (e, t) =>
adamc@867 2095 box [p_sql_type t,
adamc@867 2096 space,
adamc@867 2097 string "arg",
adamc@867 2098 string (Int.toString (i + 1)),
adamc@867 2099 space,
adamc@867 2100 string "=",
adamc@867 2101 space,
adam@1524 2102 p_exp' false false env e,
adamc@867 2103 string ";"])
adamc@867 2104 inputs,
adamc@867 2105 newline,
adamc@867 2106 newline,
adamc@640 2107
adamc@867 2108 #queryPrepared (Settings.currentDbms ())
adamc@867 2109 {loc = loc,
adamc@867 2110 id = id,
adamc@867 2111 query = query,
adamc@867 2112 inputs = map #2 inputs,
adamc@873 2113 cols = map (fn (_, t) => sql_type_in env t) outputs,
adamc@879 2114 doCols = doCols,
adamc@879 2115 nested = nested}],
adamc@278 2116 newline,
adamc@277 2117
adamc@324 2118 if wontLeakAnything then
adamc@324 2119 box [string "uw_end_region(ctx);",
adamc@324 2120 newline]
adamc@324 2121 else
adamc@324 2122 box [],
adamc@278 2123 string "acc;",
adamc@278 2124 newline,
adamc@704 2125 string "})",
adamc@704 2126 if wontLeakAnything then
adamc@704 2127 string ")"
adamc@704 2128 else
adamc@704 2129 box []]
adamc@278 2130 end
adamc@106 2131
adam@1293 2132 | EDml {dml, prepared, mode} =>
adam@1295 2133 box [string "(uw_begin_region(ctx), ({",
adamc@307 2134 newline,
adamc@307 2135 case prepared of
adamc@307 2136 NONE => box [string "char *dml = ",
adam@1524 2137 p_exp' false false env dml,
adamc@307 2138 string ";",
adamc@868 2139 newline,
adamc@868 2140 newline,
adam@1293 2141 #dml (Settings.currentDbms ()) (loc, mode)]
adamc@879 2142 | SOME {id, dml = dml'} =>
adamc@307 2143 let
adamc@868 2144 val inputs = getPargs dml
adamc@307 2145 in
adamc@307 2146 box [p_list_sepi newline
adamc@307 2147 (fn i => fn (e, t) =>
adamc@307 2148 box [p_sql_type t,
adamc@307 2149 space,
adamc@307 2150 string "arg",
adamc@307 2151 string (Int.toString (i + 1)),
adamc@307 2152 space,
adamc@307 2153 string "=",
adamc@307 2154 space,
adam@1524 2155 p_exp' false false env e,
adamc@307 2156 string ";"])
adamc@868 2157 inputs,
adamc@307 2158 newline,
adamc@307 2159 newline,
adamc@307 2160
adamc@868 2161 #dmlPrepared (Settings.currentDbms ()) {loc = loc,
adamc@868 2162 id = id,
adamc@868 2163 dml = dml',
adam@1293 2164 inputs = map #2 inputs,
adam@1293 2165 mode = mode}]
adamc@307 2166 end,
adamc@307 2167 newline,
adamc@307 2168 newline,
adamc@337 2169 string "uw_end_region(ctx);",
adamc@337 2170 newline,
adam@1293 2171
adam@1293 2172 case mode of
adam@1431 2173 Settings.Error => string "0;"
adam@1295 2174 | Settings.None => string "uw_dup_and_clear_error_message(ctx);",
adam@1293 2175
adamc@307 2176 newline,
adam@1295 2177 string "}))"]
adamc@307 2178
adamc@338 2179 | ENextval {seq, prepared} =>
adamc@878 2180 box [string "({",
adamc@878 2181 newline,
adamc@878 2182 string "uw_Basis_int n;",
adamc@878 2183 newline,
adamc@869 2184
adamc@878 2185 case prepared of
adamc@878 2186 NONE => #nextval (Settings.currentDbms ()) {loc = loc,
adam@1524 2187 seqE = p_exp' false false env seq,
adamc@878 2188 seqName = case #1 seq of
adamc@878 2189 EPrim (Prim.String s) => SOME s
adamc@878 2190 | _ => NONE}
adamc@879 2191 | SOME {id, query} => #nextvalPrepared (Settings.currentDbms ()) {loc = loc,
adamc@878 2192 id = id,
adamc@878 2193 query = query},
adamc@878 2194 newline,
adamc@878 2195 newline,
adamc@869 2196
adamc@878 2197 string "n;",
adamc@878 2198 newline,
adamc@878 2199 string "})"]
adamc@338 2200
adamc@1073 2201 | ESetval {seq, count} =>
adamc@1073 2202 box [string "({",
adamc@1073 2203 newline,
adamc@1073 2204
adamc@1073 2205 #setval (Settings.currentDbms ()) {loc = loc,
adam@1524 2206 seqE = p_exp' false false env seq,
adam@1524 2207 count = p_exp' false false env count},
adamc@1073 2208 newline,
adamc@1073 2209 newline,
adamc@1073 2210
adam@1431 2211 string "0;",
adamc@1073 2212 newline,
adamc@1073 2213 string "})"]
adamc@1073 2214
adamc@1112 2215 | EUnurlify (e, t, true) =>
adamc@463 2216 let
adamc@463 2217 fun getIt () =
adamc@463 2218 if isUnboxable t then
adamc@1023 2219 unurlify false env t
adamc@463 2220 else
adamc@463 2221 box [string "({",
adamc@463 2222 newline,
adamc@463 2223 p_typ env t,
adamc@463 2224 string " *tmp = uw_malloc(ctx, sizeof(",
adamc@463 2225 p_typ env t,
adamc@463 2226 string "));",
adamc@463 2227 newline,
adamc@463 2228 string "*tmp = ",
adamc@1023 2229 unurlify false env t,
adamc@463 2230 string ";",
adamc@463 2231 newline,
adamc@463 2232 string "tmp;",
adamc@463 2233 newline,
adamc@463 2234 string "})"]
adamc@463 2235 in
adamc@463 2236 box [string "({",
adamc@463 2237 newline,
adamc@737 2238 string "uw_Basis_string request = uw_maybe_strdup(ctx, ",
adam@1524 2239 p_exp' false false env e,
adamc@492 2240 string ");",
adamc@463 2241 newline,
adamc@463 2242 newline,
adamc@463 2243 string "(request ? ",
adamc@463 2244 getIt (),
adamc@463 2245 string " : NULL);",
adamc@463 2246 newline,
adamc@463 2247 string "})"]
adamc@463 2248 end
adamc@463 2249
adamc@1112 2250 | EUnurlify (e, t, false) =>
adamc@1112 2251 let
adamc@1112 2252 fun getIt () =
adamc@1112 2253 if isUnboxable t then
adamc@1112 2254 unurlify false env t
adamc@1112 2255 else
adamc@1112 2256 box [string "({",
adamc@1112 2257 newline,
adamc@1112 2258 p_typ env t,
adamc@1112 2259 string " *tmp = uw_malloc(ctx, sizeof(",
adamc@1112 2260 p_typ env t,
adamc@1112 2261 string "));",
adamc@1112 2262 newline,
adamc@1112 2263 string "*tmp = ",
adamc@1112 2264 unurlify false env t,
adamc@1112 2265 string ";",
adamc@1112 2266 newline,
adamc@1112 2267 string "tmp;",
adamc@1112 2268 newline,
adamc@1112 2269 string "})"]
adamc@1112 2270 in
adamc@1112 2271 box [string "({",
adamc@1112 2272 newline,
adamc@1112 2273 string "uw_Basis_string request = uw_maybe_strdup(ctx, ",
adam@1524 2274 p_exp' false false env e,
adamc@1112 2275 string ");",
adamc@1112 2276 newline,
adamc@1112 2277 newline,
adamc@1112 2278 unurlify false env t,
adamc@1112 2279 string ";",
adamc@1112 2280 newline,
adamc@1112 2281 string "})"]
adamc@1112 2282 end
adamc@1112 2283
adam@1524 2284 and p_exp env = p_exp' false true env
adamc@29 2285
adamc@1114 2286 fun p_fun isRec env (fx, n, args, ran, e) =
adamc@129 2287 let
adamc@129 2288 val nargs = length args
adamc@129 2289 val env' = foldl (fn ((x, dom), env) => E.pushERel env x dom) env args
adamc@129 2290 in
adamc@129 2291 box [string "static",
adamc@129 2292 space,
adamc@129 2293 p_typ env ran,
adamc@129 2294 space,
adamc@316 2295 string ("__uwn_" ^ ident fx ^ "_" ^ Int.toString n),
adamc@129 2296 string "(",
adamc@129 2297 p_list_sep (box [string ",", space]) (fn x => x)
adamc@311 2298 (string "uw_context ctx" :: ListUtil.mapi (fn (i, (_, dom)) =>
adamc@129 2299 box [p_typ env dom,
adamc@129 2300 space,
adamc@129 2301 p_rel env' (nargs - i - 1)]) args),
adamc@129 2302 string ")",
adamc@129 2303 space,
adamc@129 2304 string "{",
adam@1524 2305 if isRec then
adam@1524 2306 box [string "restart:",
adam@1524 2307 newline]
adam@1524 2308 else
adam@1524 2309 box [],
adamc@129 2310 newline,
adamc@1114 2311 if isRec andalso Settings.getDeadlines () then
adamc@1114 2312 box [string "uw_check_deadline(ctx);",
adamc@1114 2313 newline]
adamc@1114 2314 else
adamc@1114 2315 box [],
adamc@638 2316 box [string "return(",
adamc@638 2317 p_exp env' e,
adamc@638 2318 string ");"],
adamc@129 2319 newline,
adamc@129 2320 string "}"]
adamc@129 2321 end
adamc@129 2322
adamc@129 2323 fun p_decl env (dAll as (d, _) : decl) =
adamc@29 2324 case d of
adamc@29 2325 DStruct (n, xts) =>
adamc@196 2326 let
adamc@196 2327 val env = E.declBinds env dAll
adamc@196 2328 in
adamc@196 2329 box [string "struct",
adamc@196 2330 space,
adamc@311 2331 string ("__uws_" ^ Int.toString n),
adamc@196 2332 space,
adamc@196 2333 string "{",
adamc@196 2334 newline,
adamc@196 2335 p_list_sep (box []) (fn (x, t) => box [p_typ env t,
adamc@196 2336 space,
adamc@311 2337 string "__uwf_",
adamc@316 2338 p_ident x,
adamc@196 2339 string ";",
adamc@196 2340 newline]) xts,
adamc@196 2341 string "};"]
adamc@196 2342 end
adamc@809 2343 | DDatatype dts =>
adamc@165 2344 let
adamc@809 2345 val dts = ListMergeSort.sort (fn ((dk1, _, _, _), (dk2, _, _, _)) =>
adamc@809 2346 dk1 = Enum andalso dk2 <> Enum) dts
adamc@809 2347
adamc@809 2348 fun p_one (Enum, x, n, xncs) =
adamc@809 2349 box [string "enum",
adamc@809 2350 space,
adamc@809 2351 string ("__uwe_" ^ ident x ^ "_" ^ Int.toString n),
adamc@809 2352 space,
adamc@809 2353 string "{",
adamc@809 2354 space,
adam@1298 2355 case xncs of
adam@1298 2356 [] => string ("__uwec_" ^ ident x ^ "_" ^ Int.toString n)
adam@1298 2357 | _ =>
adam@1298 2358 p_list_sep (box [string ",", space]) (fn (x, n, _) =>
adam@1298 2359 string ("__uwc_" ^ ident x ^ "_" ^ Int.toString n)) xncs,
adamc@809 2360 space,
adamc@809 2361 string "};"]
adamc@809 2362 | p_one (Option, _, _, _) = box []
adamc@809 2363 | p_one (Default, x, n, xncs) =
adamc@809 2364 let
adamc@809 2365 val xncsArgs = List.mapPartial (fn (x, n, NONE) => NONE
adamc@809 2366 | (x, n, SOME t) => SOME (x, n, t)) xncs
adamc@809 2367 in
adamc@809 2368 box [string "enum",
adamc@809 2369 space,
adamc@809 2370 string ("__uwe_" ^ ident x ^ "_" ^ Int.toString n),
adamc@809 2371 space,
adamc@809 2372 string "{",
adamc@809 2373 space,
adamc@809 2374 p_list_sep (box [string ",", space]) (fn (x, n, _) =>
adamc@809 2375 string ("__uwc_" ^ ident x ^ "_" ^ Int.toString n))
adamc@809 2376 xncs,
adamc@809 2377 space,
adamc@809 2378 string "};",
adamc@809 2379 newline,
adamc@809 2380 newline,
adamc@809 2381 string "struct",
adamc@809 2382 space,
adamc@809 2383 string ("__uwd_" ^ ident x ^ "_" ^ Int.toString n),
adamc@809 2384 space,
adamc@809 2385 string "{",
adamc@809 2386 newline,
adamc@809 2387 string "enum",
adamc@809 2388 space,
adamc@809 2389 string ("__uwe_" ^ ident x ^ "_" ^ Int.toString n),
adamc@809 2390 space,
adamc@809 2391 string "tag;",
adamc@809 2392 newline,
adamc@809 2393 box (case xncsArgs of
adamc@809 2394 [] => []
adamc@809 2395 | _ => [string "union",
adamc@809 2396 space,
adamc@809 2397 string "{",
adamc@809 2398 newline,
adamc@809 2399 p_list_sep newline (fn (x, n, t) => box [p_typ env t,
adamc@809 2400 space,
adamc@809 2401 string ("uw_" ^ ident x),
adamc@809 2402 string ";"]) xncsArgs,
adamc@809 2403 newline,
adamc@809 2404 string "}",
adamc@809 2405 space,
adamc@809 2406 string "data;",
adamc@809 2407 newline]),
adamc@809 2408 string "};"]
adamc@809 2409 end
adamc@165 2410 in
adamc@809 2411 p_list_sep (box []) p_one dts
adamc@188 2412 end
adamc@29 2413
adamc@196 2414 | DDatatypeForward _ => box []
adamc@196 2415
adamc@29 2416 | DVal (x, n, t, e) =>
adamc@29 2417 box [p_typ env t,
adamc@29 2418 space,
adamc@316 2419 string ("__uwn_" ^ ident x ^ "_" ^ Int.toString n),
adamc@29 2420 space,
adamc@29 2421 string "=",
adamc@29 2422 space,
adamc@29 2423 p_exp env e,
adamc@29 2424 string ";"]
adamc@1114 2425 | DFun vi => p_fun false env vi
adamc@129 2426 | DFunRec vis =>
adamc@29 2427 let
adamc@129 2428 val env = E.declBinds env dAll
adamc@29 2429 in
adamc@129 2430 box [p_list_sep newline (fn (fx, n, args, ran, _) =>
adamc@129 2431 box [string "static",
adamc@129 2432 space,
adamc@129 2433 p_typ env ran,
adamc@129 2434 space,
adamc@316 2435 string ("__uwn_" ^ ident fx ^ "_" ^ Int.toString n),
adamc@311 2436 string "(uw_context,",
adamc@129 2437 space,
adamc@129 2438 p_list_sep (box [string ",", space])
adamc@129 2439 (fn (_, dom) => p_typ env dom) args,
adamc@129 2440 string ");"]) vis,
adamc@29 2441 newline,
adam@1524 2442 p_list_sep newline (fn vi as (_, n, _, _, _) =>
adam@1524 2443 (self := SOME n;
adam@1524 2444 p_fun true env vi
adam@1524 2445 before self := NONE)) vis,
adamc@129 2446 newline]
adamc@29 2447 end
adamc@707 2448 | DTable (x, _, pk, csts) => box [string "/* SQL table ",
adamc@707 2449 string x,
adamc@707 2450 space,
adamc@707 2451 case pk of
adamc@707 2452 "" => box []
adamc@707 2453 | _ => box [string "keys",
adamc@707 2454 space,
adamc@707 2455 string pk,
adamc@707 2456 space],
adamc@707 2457 string "constraints",
adamc@707 2458 space,
adamc@707 2459 p_list (fn (x, v) => box [string x,
adamc@707 2460 space,
adamc@707 2461 string ":",
adamc@707 2462 space,
adamc@707 2463 string v]) csts,
adamc@707 2464 space,
adamc@707 2465 string " */",
adamc@707 2466 newline]
adamc@338 2467 | DSequence x => box [string "/* SQL sequence ",
adamc@338 2468 string x,
adamc@338 2469 string " */",
adamc@338 2470 newline]
adamc@754 2471 | DView (x, _, s) => box [string "/* SQL view ",
adamc@754 2472 string x,
adamc@754 2473 space,
adamc@754 2474 string "AS",
adamc@754 2475 space,
adamc@754 2476 string s,
adamc@754 2477 space,
adamc@754 2478 string " */",
adamc@754 2479 newline]
adamc@870 2480 | DDatabase _ => box []
adamc@870 2481 | DPreparedStatements _ => box []
adamc@282 2482
adamc@569 2483 | DJavaScript s => box [string "static char jslib[] = \"",
adam@1656 2484 string (Prim.toCString s),
adamc@569 2485 string "\";"]
adamc@725 2486 | DCookie s => box [string "/*",
adamc@725 2487 space,
adamc@725 2488 string "cookie",
adamc@725 2489 space,
adamc@725 2490 string s,
adamc@725 2491 space,
adamc@725 2492 string "*/"]
adamc@720 2493 | DStyle s => box [string "/*",
adamc@720 2494 space,
adamc@720 2495 string "style",
adamc@720 2496 space,
adamc@720 2497 string s,
adamc@720 2498 space,
adamc@720 2499 string "*/"]
adamc@569 2500
adamc@1075 2501 | DTask _ => box []
adam@1294 2502 | DOnError _ => box []
adamc@1073 2503
adamc@144 2504 datatype 'a search =
adamc@144 2505 Found of 'a
adamc@144 2506 | NotFound
adamc@144 2507 | Error
adamc@120 2508
adamc@467 2509 fun p_sqltype'' env (tAll as (t, loc)) =
adamc@275 2510 case t of
adamc@275 2511 TFfi ("Basis", "int") => "int8"
adamc@275 2512 | TFfi ("Basis", "float") => "float8"
adamc@275 2513 | TFfi ("Basis", "string") => "text"
adamc@275 2514 | TFfi ("Basis", "bool") => "bool"
adamc@438 2515 | TFfi ("Basis", "time") => "timestamp"
adamc@737 2516 | TFfi ("Basis", "blob") => "bytea"
adamc@682 2517 | TFfi ("Basis", "channel") => "int8"
adamc@682 2518 | TFfi ("Basis", "client") => "int4"
adamc@275 2519 | _ => (ErrorMsg.errorAt loc "Don't know SQL equivalent of type";
adam@1623 2520 Print.eprefaces' [("Type", p_htyp env tAll)];
adamc@275 2521 "ERROR")
adamc@275 2522
adamc@467 2523 fun p_sqltype' env (tAll as (t, loc)) =
adamc@467 2524 case t of
adamc@467 2525 (TOption t, _) => p_sqltype'' env t
adamc@467 2526 | _ => p_sqltype'' env t ^ " NOT NULL"
adamc@467 2527
adamc@275 2528 fun p_sqltype env t = string (p_sqltype' env t)
adamc@101 2529
adamc@467 2530 fun p_sqltype_base' env t =
adamc@467 2531 case t of
adamc@467 2532 (TOption t, _) => p_sqltype'' env t
adamc@467 2533 | _ => p_sqltype'' env t
adamc@467 2534
adamc@467 2535 fun p_sqltype_base env t = string (p_sqltype_base' env t)
adamc@467 2536
adamc@467 2537 fun is_not_null t =
adamc@467 2538 case t of
adamc@467 2539 (TOption _, _) => false
adamc@467 2540 | _ => true
adamc@467 2541
adamc@734 2542 fun sigName fields =
adamc@734 2543 let
adamc@734 2544 fun inFields s = List.exists (fn (s', _) => s' = s) fields
adamc@734 2545
adamc@734 2546 fun getSigName n =
adamc@734 2547 let
adamc@734 2548 val s = "Sig" ^ Int.toString n
adamc@734 2549 in
adamc@734 2550 if inFields s then
adamc@734 2551 getSigName (n + 1)
adamc@734 2552 else
adamc@734 2553 s
adamc@734 2554 end
adamc@734 2555 in
adamc@734 2556 if inFields "Sig" then
adamc@734 2557 getSigName 0
adamc@734 2558 else
adamc@734 2559 "Sig"
adamc@734 2560 end
adamc@734 2561
adamc@101 2562 fun p_file env (ds, ps) =
adamc@29 2563 let
adam@1516 2564 val () = (clearUrlHandlers ();
adam@1516 2565 unurlifies := IS.empty;
adam@1516 2566 urlifies := IS.empty;
adam@1524 2567 urlifiesL := IS.empty;
adam@1524 2568 self := NONE)
adam@1516 2569
adamc@101 2570 val (pds, env) = ListUtil.foldlMap (fn (d, env) =>
adam@1516 2571 let
adam@1516 2572 val d' = p_decl env d
adam@1546 2573 val hs = latestUrlHandlers ()
adam@1546 2574 val (protos, defs) = ListPair.unzip hs
adam@1516 2575 in
adam@1546 2576 (box (List.revAppend (protos, (List.revAppend (defs, [d'])))),
adam@1516 2577 E.declBinds env d)
adam@1516 2578 end)
adamc@101 2579 env ds
adamc@144 2580
adamc@779 2581 fun flatFields always (t : typ) =
adamc@756 2582 case #1 t of
adamc@756 2583 TRecord i =>
adamc@756 2584 let
adamc@756 2585 val xts = E.lookupStruct env i
adamc@756 2586 in
adamc@779 2587 SOME ((always @ map #1 xts) :: List.concat (List.mapPartial (flatFields [] o #2) xts))
adamc@756 2588 end
adamc@759 2589 | TList (_, i) =>
adamc@759 2590 let
adamc@759 2591 val ts = E.lookupStruct env i
adamc@759 2592 in
adamc@759 2593 case ts of
adamc@779 2594 [("1", t'), ("2", _)] => flatFields [] t'
adamc@759 2595 | _ => raise Fail "CjrPrint: Bad struct for TList"
adamc@759 2596 end
adamc@756 2597 | _ => NONE
adamc@756 2598
adamc@1104 2599 val fields = foldl (fn ((ek, _, _, ts, _, _, _), fields) =>
adamc@144 2600 case ek of
adam@1347 2601 Action eff =>
adam@1347 2602 (case List.nth (ts, length ts - 2) of
adam@1347 2603 (TRecord i, loc) =>
adam@1347 2604 let
adam@1347 2605 val xts = E.lookupStruct env i
adam@1347 2606 val extra = case eff of
adam@1347 2607 ReadCookieWrite => [sigName xts]
adam@1347 2608 | _ => []
adam@1347 2609 in
adam@1347 2610 case flatFields extra (TRecord i, loc) of
adam@1347 2611 NONE => raise Fail "CjrPrint: flatFields impossible"
adam@1347 2612 | SOME fields' => List.revAppend (fields', fields)
adam@1347 2613 end
adam@1347 2614 | _ => raise Fail "CjrPrint: Last argument of action isn't record")
adam@1347 2615 | _ => fields)
adamc@756 2616 [] ps
adamc@756 2617
adamc@756 2618 val fields = foldl (fn (xts, fields) =>
adamc@756 2619 let
adamc@756 2620 val xtsSet = SS.addList (SS.empty, xts)
adamc@756 2621 in
adamc@756 2622 foldl (fn (x, fields) =>
adamc@756 2623 let
adamc@756 2624 val xtsSet' = Option.getOpt (SM.find (fields, x), SS.empty)
adamc@756 2625 in
adamc@756 2626 SM.insert (fields, x, SS.union (SS.delete (xtsSet, x),
adamc@756 2627 xtsSet'))
adamc@756 2628 end) fields xts
adamc@756 2629 end)
adamc@756 2630 SM.empty fields
adamc@144 2631
adamc@144 2632 val fnums = SM.foldli (fn (x, xs, fnums) =>
adamc@144 2633 let
adamc@144 2634 val unusable = SS.foldl (fn (x', unusable) =>
adamc@144 2635 case SM.find (fnums, x') of
adamc@144 2636 NONE => unusable
adamc@144 2637 | SOME n => IS.add (unusable, n))
adamc@144 2638 IS.empty xs
adamc@144 2639
adamc@144 2640 fun findAvailable n =
adamc@144 2641 if IS.member (unusable, n) then
adamc@144 2642 findAvailable (n + 1)
adamc@144 2643 else
adamc@144 2644 n
adamc@144 2645 in
adamc@144 2646 SM.insert (fnums, x, findAvailable 0)
adamc@144 2647 end)
adamc@144 2648 SM.empty fields
adamc@144 2649
adamc@734 2650 val cookies = List.mapPartial (fn (DCookie s, _) => SOME s | _ => NONE) ds
adamc@734 2651
adamc@144 2652 fun makeSwitch (fnums, i) =
adamc@144 2653 case SM.foldl (fn (n, NotFound) => Found n
adamc@144 2654 | (n, Error) => Error
adamc@144 2655 | (n, Found n') => if n = n' then
adamc@144 2656 Found n'
adamc@144 2657 else
adamc@144 2658 Error) NotFound fnums of
adamc@144 2659 NotFound => box [string "return",
adamc@144 2660 space,
adamc@144 2661 string "-1;"]
adamc@144 2662 | Found n => box [string "return",
adamc@144 2663 space,
adamc@144 2664 string (Int.toString n),
adamc@144 2665 string ";"]
adamc@144 2666 | Error =>
adamc@144 2667 let
adamc@144 2668 val cmap = SM.foldli (fn (x, n, cmap) =>
adamc@144 2669 let
adamc@144 2670 val ch = if i < size x then
adamc@144 2671 String.sub (x, i)
adamc@144 2672 else
adamc@144 2673 chr 0
adamc@144 2674
adamc@144 2675 val fnums = case CM.find (cmap, ch) of
adamc@144 2676 NONE => SM.empty
adamc@144 2677 | SOME fnums => fnums
adamc@144 2678 val fnums = SM.insert (fnums, x, n)
adamc@144 2679 in
adamc@144 2680 CM.insert (cmap, ch, fnums)
adamc@144 2681 end)
adamc@144 2682 CM.empty fnums
adamc@144 2683
adamc@144 2684 val cmap = CM.listItemsi cmap
adamc@144 2685 in
adamc@144 2686 case cmap of
adamc@144 2687 [(_, fnums)] =>
adamc@144 2688 box [string "if",
adamc@144 2689 space,
adamc@144 2690 string "(name[",
adamc@144 2691 string (Int.toString i),
adamc@144 2692 string "]",
adamc@144 2693 space,
adamc@144 2694 string "==",
adamc@144 2695 space,
adamc@144 2696 string "0)",
adamc@144 2697 space,
adamc@144 2698 string "return",
adamc@144 2699 space,
adamc@144 2700 string "-1;",
adamc@144 2701 newline,
adamc@144 2702 makeSwitch (fnums, i+1)]
adamc@144 2703 | _ =>
adamc@144 2704 box [string "switch",
adamc@144 2705 space,
adamc@144 2706 string "(name[",
adamc@144 2707 string (Int.toString i),
adamc@144 2708 string "])",
adamc@144 2709 space,
adamc@144 2710 string "{",
adamc@144 2711 newline,
adamc@144 2712 box (map (fn (ch, fnums) =>
adamc@144 2713 box [string "case",
adamc@144 2714 space,
adamc@144 2715 if ch = chr 0 then
adamc@144 2716 string "0:"
adamc@144 2717 else
adamc@144 2718 box [string "'",
adamc@144 2719 string (Char.toString ch),
adamc@144 2720 string "':"],
adamc@144 2721 newline,
adamc@144 2722 makeSwitch (fnums, i+1),
adamc@144 2723 newline]) cmap),
adamc@144 2724 string "default:",
adamc@144 2725 newline,
adamc@144 2726 string "return",
adamc@144 2727 space,
adamc@144 2728 string "-1;",
adamc@144 2729 newline,
adamc@144 2730 string "}"]
adamc@144 2731 end
adamc@144 2732
adamc@756 2733 fun getInput (x, t) =
adamc@756 2734 let
adamc@756 2735 val n = case SM.find (fnums, x) of
adamc@759 2736 NONE => raise Fail ("CjrPrint: Can't find " ^ x ^ " in fnums")
adamc@756 2737 | SOME n => n
adamc@756 2738
adamc@756 2739 val f = case t of
adamc@756 2740 (TFfi ("Basis", "bool"), _) => "optional_"
adamc@756 2741 | _ => ""
adamc@756 2742 in
adamc@756 2743 if isFile t then
adamc@756 2744 box [string "uw_input_",
adamc@756 2745 p_ident x,
adamc@756 2746 space,
adamc@756 2747 string "=",
adamc@756 2748 space,
adamc@756 2749 string "uw_get_file_input(ctx, ",
adamc@756 2750 string (Int.toString n),
adamc@756 2751 string ");",
adamc@756 2752 newline]
adamc@756 2753 else case #1 t of
adamc@756 2754 TRecord i =>
adamc@756 2755 let
adamc@756 2756 val xts = E.lookupStruct env i
adamc@756 2757 in
adamc@756 2758 box [string "uw_enter_subform(ctx, ",
adamc@756 2759 string (Int.toString n),
adamc@756 2760 string ");",
adamc@756 2761 newline,
adamc@756 2762 string "uw_input_",
adamc@756 2763 p_ident x,
adamc@756 2764 space,
adamc@756 2765 string "=",
adamc@756 2766 space,
adamc@756 2767 string "({",
adamc@756 2768 box [p_typ env t,
adamc@756 2769 space,
adamc@756 2770 string "result;",
adamc@756 2771 newline,
adamc@756 2772 p_list_sep (box [])
adamc@756 2773 (fn (x, t) =>
adamc@756 2774 box [p_typ env t,
adamc@756 2775 space,
adamc@756 2776 string "uw_input_",
adamc@756 2777 string x,
adamc@756 2778 string ";",
adamc@756 2779 newline])
adamc@756 2780 xts,
adamc@756 2781 newline,
adamc@756 2782 p_list_sep (box []) (fn (x, t) =>
adamc@756 2783 box [getInput (x, t),
adamc@756 2784 string "result.__uwf_",
adamc@756 2785 string x,
adamc@756 2786 space,
adamc@756 2787 string "=",
adamc@756 2788 space,
adamc@756 2789 string "uw_input_",
adamc@756 2790 string x,
adamc@756 2791 string ";",
adamc@756 2792 newline])
adamc@756 2793 xts,
adamc@756 2794 newline,
adamc@756 2795 string "result;",
adamc@756 2796 newline],
adamc@756 2797 string "});",
adamc@756 2798 newline,
adamc@756 2799 string "uw_leave_subform(ctx);"]
adamc@756 2800 end
adamc@759 2801 | TList (t', i) =>
adamc@759 2802 let
adamc@759 2803 val xts = E.lookupStruct env i
adamc@759 2804 val i' = case xts of
adamc@759 2805 [("1", (TRecord i', loc)), ("2", _)] => i'
adamc@759 2806 | _ => raise Fail "CjrPrint: Bad TList record [2]"
adamc@759 2807 val xts = E.lookupStruct env i'
adamc@759 2808 in
adamc@759 2809 box [string "{",
adamc@759 2810 newline,
adamc@759 2811 string "int status;",
adamc@759 2812 newline,
adamc@759 2813 string "uw_input_",
adamc@759 2814 p_ident x,
adamc@759 2815 space,
adamc@759 2816 string "=",
adamc@759 2817 space,
adamc@759 2818 string "NULL;",
adamc@759 2819 newline,
adamc@759 2820 string "for (status = uw_enter_subforms(ctx, ",
adamc@759 2821 string (Int.toString n),
adamc@759 2822 string "); status; status = uw_next_entry(ctx)) {",
adamc@759 2823 newline,
adamc@759 2824 box [p_typ env t,
adamc@759 2825 space,
adamc@759 2826 string "result",
adamc@759 2827 space,
adamc@759 2828 string "=",
adamc@759 2829 space,
adamc@759 2830 string "uw_malloc(ctx, sizeof(struct __uws_",
adamc@759 2831 string (Int.toString i),
adamc@759 2832 string "));",
adamc@759 2833 newline,
adamc@759 2834 box [string "{",
adamc@759 2835 p_list_sep (box [])
adamc@759 2836 (fn (x, t) =>
adamc@759 2837 box [p_typ env t,
adamc@759 2838 space,
adamc@759 2839 string "uw_input_",
adamc@759 2840 string x,
adamc@759 2841 string ";",
adamc@759 2842 newline])
adamc@759 2843 xts,
adamc@759 2844 newline,
adamc@759 2845 p_list_sep (box []) (fn (x, t) =>
adamc@759 2846 box [getInput (x, t),
adamc@759 2847 string "result->__uwf_1.__uwf_",
adamc@759 2848 string x,
adamc@759 2849 space,
adamc@759 2850 string "=",
adamc@759 2851 space,
adamc@759 2852 string "uw_input_",
adamc@759 2853 string x,
adamc@759 2854 string ";",
adamc@759 2855 newline])
adamc@759 2856 xts,
adamc@759 2857 string "}",
adamc@759 2858 newline],
adamc@759 2859 newline,
adamc@759 2860 string "result->__uwf_2 = uw_input_",
adamc@759 2861 p_ident x,
adamc@759 2862 string ";",
adamc@759 2863 newline,
adamc@759 2864 string "uw_input_",
adamc@759 2865 p_ident x,
adamc@759 2866 string " = result;",
adamc@759 2867 newline],
adamc@759 2868 string "}}",
adamc@759 2869 newline]
adamc@759 2870 end
adam@1692 2871 | TOption _ =>
adam@1692 2872 box [string "uw_input_",
adam@1692 2873 p_ident x,
adam@1692 2874 space,
adam@1692 2875 string "=",
adam@1692 2876 space,
adam@1692 2877 string "uw_get_input(ctx, ",
adam@1692 2878 string (Int.toString n),
adam@1692 2879 string ");",
adam@1692 2880 newline]
adamc@756 2881 | _ =>
adamc@756 2882 box [string "request = uw_get_",
adamc@756 2883 string f,
adamc@756 2884 string "input(ctx, ",
adamc@756 2885 string (Int.toString n),
adamc@756 2886 string ");",
adamc@756 2887 newline,
adamc@756 2888 string "if (request == NULL)",
adamc@756 2889 newline,
adamc@756 2890 box [string "uw_error(ctx, FATAL, \"Missing input ",
adamc@756 2891 string x,
adamc@756 2892 string "\");"],
adamc@756 2893 newline,
adamc@756 2894 string "uw_input_",
adamc@756 2895 p_ident x,
adamc@756 2896 space,
adamc@756 2897 string "=",
adamc@756 2898 space,
adamc@1023 2899 unurlify true env t,
adamc@756 2900 string ";",
adamc@756 2901 newline]
adamc@756 2902 end
adamc@756 2903
adam@1542 2904 val timestamp = LargeInt.toString (Time.toMilliseconds (Time.now ()))
adam@1542 2905 val app_js = OS.Path.joinDirFile {dir = Settings.getUrlPrefix (),
adam@1542 2906 file = "app." ^ timestamp ^ ".js"}
adam@1542 2907
adam@1731 2908 val allScripts =
adam@1731 2909 let
adam@1731 2910 val scripts =
adam@1731 2911 "<script type=\\\"text/javascript\\\" src=\\\""
adam@1731 2912 ^ app_js
adam@1731 2913 ^ "\\\"></script>\\n"
adam@1731 2914 in
adam@1731 2915 foldl (fn (x, scripts) =>
adam@1731 2916 scripts
adam@1731 2917 ^ "<script type=\\\"text/javascript\\\" src=\\\"" ^ x ^ "\\\"></script>\\n")
adam@1731 2918 scripts (Settings.getScripts ())
adam@1731 2919 end
adam@1731 2920
adamc@1104 2921 fun p_page (ek, s, n, ts, ran, side, tellSig) =
adamc@144 2922 let
adamc@734 2923 val (ts, defInputs, inputsVar, fields) =
adamc@144 2924 case ek of
adam@1347 2925 Core.Action _ =>
adam@1347 2926 (case List.nth (ts, length ts - 2) of
adam@1347 2927 (TRecord i, _) =>
adam@1347 2928 let
adam@1347 2929 val xts = E.lookupStruct env i
adam@1347 2930 in
adam@1347 2931 (List.take (ts, length ts - 2),
adam@1347 2932 box [box (map (fn (x, t) => box [p_typ env t,
adam@1347 2933 space,
adam@1347 2934 string "uw_input_",
adam@1347 2935 p_ident x,
adam@1347 2936 string ";",
adam@1347 2937 newline]) xts),
adam@1347 2938 newline,
adam@1347 2939 box (map getInput xts),
adam@1431 2940 case i of
adam@1431 2941 0 => string "uw_unit uw_inputs;"
adam@1431 2942 | _ => box [string "struct __uws_",
adam@1431 2943 string (Int.toString i),
adam@1431 2944 space,
adam@1431 2945 string "uw_inputs",
adam@1431 2946 space,
adam@1431 2947 string "= {",
adam@1431 2948 newline,
adam@1431 2949 box (map (fn (x, _) => box [string "uw_input_",
adam@1431 2950 p_ident x,
adam@1431 2951 string ",",
adam@1431 2952 newline]) xts),
adam@1431 2953 string "};"],
adam@1347 2954 newline],
adam@1347 2955 box [string ",",
adam@1347 2956 space,
adam@1347 2957 string "uw_inputs"],
adam@1347 2958 SOME xts)
adam@1347 2959 end
adamc@144 2960
adam@1347 2961 | _ => raise Fail "CjrPrint: Last argument to an action isn't a record")
adam@1347 2962 | _ => (List.take (ts, length ts - 1), string "", string "", NONE)
adamc@734 2963
adamc@734 2964 fun couldWrite ek =
adamc@734 2965 case ek of
adamc@734 2966 Link => false
adamc@735 2967 | Action ef => ef = ReadCookieWrite
adamc@735 2968 | Rpc ef => ef = ReadCookieWrite
adam@1384 2969 | Extern _ => false
adamc@863 2970
adamc@863 2971 val s =
adamc@863 2972 case Settings.getUrlPrefix () of
adamc@863 2973 "" => s
adamc@863 2974 | "/" => s
adamc@863 2975 | prefix =>
adamc@863 2976 if size s > 0 andalso String.sub (s, 0) = #"/" then
adamc@863 2977 prefix ^ String.extract (s, 1, NONE)
adamc@863 2978 else
adamc@863 2979 prefix ^ s
adamc@144 2980 in
adamc@735 2981 box [string "if (!strncmp(request, \"",
adam@1656 2982 string (Prim.toCString s),
adamc@735 2983 string "\", ",
adamc@735 2984 string (Int.toString (size s)),
adamc@735 2985 string ") && (request[",
adamc@735 2986 string (Int.toString (size s)),
adamc@735 2987 string "] == 0 || request[",
adamc@735 2988 string (Int.toString (size s)),
adamc@735 2989 string "] == '/')) {",
adamc@735 2990 newline,
adamc@735 2991 string "request += ",
adamc@735 2992 string (Int.toString (size s)),
adamc@735 2993 string ";",
adamc@735 2994 newline,
adamc@735 2995 string "if (*request == '/') ++request;",
adamc@735 2996 newline,
adam@1691 2997 case ek of
adam@1691 2998 Rpc _ => box [string "if (uw_hasPostBody(ctx)) {",
adam@1691 2999 newline,
adam@1691 3000 box [string "uw_Basis_postBody pb = uw_getPostBody(ctx);",
adam@1691 3001 newline,
adam@1691 3002 string "if (pb.data[0])",
adam@1691 3003 newline,
adam@1691 3004 box [string "request = uw_Basis_strcat(ctx, request, pb.data);"],
adam@1691 3005 newline],
adam@1691 3006 string "}",
adam@1691 3007 newline]
adam@1691 3008 | _ => box [],
adam@1478 3009 if couldWrite ek andalso not (Settings.checkNoXsrfProtection s) then
adamc@734 3010 box [string "{",
adamc@734 3011 newline,
adamc@734 3012 string "uw_Basis_string sig = ",
adamc@734 3013 case fields of
adamc@734 3014 NONE => string "uw_Basis_requestHeader(ctx, \"UrWeb-Sig\")"
adamc@734 3015 | SOME fields =>
adamc@734 3016 case SM.find (fnums, sigName fields) of
adamc@734 3017 NONE => raise Fail "CjrPrint: sig name wasn't assigned a number"
adamc@734 3018 | SOME inum =>
adamc@734 3019 string ("uw_get_input(ctx, " ^ Int.toString inum ^ ")"),
adamc@734 3020 string ";",
adamc@734 3021 newline,
adamc@734 3022 string "if (sig == NULL) uw_error(ctx, FATAL, \"Missing cookie signature\");",
adamc@734 3023 newline,
adam@1512 3024 string "if (!uw_streq(sig, uw_cookie_sig(ctx)))",
adamc@734 3025 newline,
adamc@734 3026 box [string "uw_error(ctx, FATAL, \"Wrong cookie signature\");",
adamc@734 3027 newline],
adamc@734 3028 string "}",
adamc@734 3029 newline]
adamc@734 3030 else
adamc@734 3031 box [],
adamc@609 3032 box (case ek of
adamc@731 3033 Core.Rpc _ => [string "uw_write_header(ctx, \"Content-type: text/plain\\r\\n\");",
adamc@731 3034 newline]
kkallio@1596 3035 | _ => [string "uw_write_header(ctx, \"Content-type: text/html; charset=utf-8\\r\\n\");",
adamc@609 3036 newline,
adamc@609 3037 string "uw_write_header(ctx, \"Content-script-type: text/javascript\\r\\n\");",
adamc@609 3038 newline,
adamc@804 3039 string "uw_write(ctx, begin_xhtml);",
adamc@643 3040 newline,
adam@1451 3041 string "uw_mayReturnIndirectly(ctx);",
adam@1451 3042 newline,
adamc@643 3043 string "uw_set_script_header(ctx, \"",
adamc@812 3044 let
adamc@812 3045 val scripts =
adamc@812 3046 case side of
adamc@693 3047 ServerOnly => ""
adam@1731 3048 | _ => allScripts
adamc@812 3049 in
adamc@812 3050 string scripts
adamc@812 3051 end,
adamc@643 3052 string "\");",
adamc@609 3053 newline]),
adamc@1038 3054 string "uw_set_needs_push(ctx, ",
adamc@1038 3055 string (case side of
adamc@1038 3056 ServerAndPullAndPush => "1"
adamc@1038 3057 | _ => "0"),
adamc@1038 3058 string ");",
adamc@1038 3059 newline,
adamc@736 3060 string "uw_set_needs_sig(ctx, ",
adamc@1104 3061 string (if tellSig then
adamc@736 3062 "1"
adamc@736 3063 else
adamc@736 3064 "0"),
adamc@736 3065 string ");",
adamc@736 3066 newline,
adamc@682 3067 string "uw_login(ctx);",
adamc@682 3068 newline,
adamc@144 3069 box [string "{",
adamc@144 3070 newline,
adamc@144 3071 box (ListUtil.mapi (fn (i, t) => box [p_typ env t,
adamc@144 3072 space,
adamc@144 3073 string "arg",
adamc@144 3074 string (Int.toString i),
adamc@144 3075 space,
adamc@144 3076 string "=",
adamc@144 3077 space,
adam@1347 3078 case #1 t of
adam@1347 3079 TFfi ("Basis", "postBody") => string "uw_getPostBody(ctx)"
adam@1370 3080 | TOption (TFfi ("Basis", "queryString"), _) => string "uw_queryString(ctx)"
adam@1347 3081 | _ => unurlify false env t,
adamc@144 3082 string ";",
adamc@144 3083 newline]) ts),
adamc@144 3084 defInputs,
adamc@609 3085 box (case ek of
adamc@731 3086 Core.Rpc _ => [p_typ env ran,
adamc@731 3087 space,
adamc@731 3088 string "it0",
adamc@731 3089 space,
adamc@731 3090 string "=",
adamc@731 3091 space]
adamc@609 3092 | _ => []),
adamc@144 3093 p_enamed env n,
adamc@144 3094 string "(",
adamc@144 3095 p_list_sep (box [string ",", space])
adamc@144 3096 (fn x => x)
adamc@272 3097 (string "ctx"
adamc@280 3098 :: ListUtil.mapi (fn (i, _) => string ("arg" ^ Int.toString i)) ts),
adamc@144 3099 inputsVar,
adam@1431 3100 string ", 0);",
adamc@144 3101 newline,
adamc@609 3102 box (case ek of
adam@1446 3103 Core.Rpc _ => [string "uw_write(ctx, uw_get_real_script(ctx));",
adam@1446 3104 newline,
adam@1446 3105 string "uw_write(ctx, \"\\n\");",
adam@1446 3106 newline,
adam@1446 3107 urlify env ran]
adamc@609 3108 | _ => [string "uw_write(ctx, \"</html>\");",
adamc@609 3109 newline]),
adamc@144 3110 string "return;",
adamc@144 3111 newline,
adamc@144 3112 string "}",
adamc@144 3113 newline,
adamc@144 3114 string "}"]
adamc@144 3115 ]
adamc@144 3116 end
adamc@144 3117
adam@1516 3118 val (pds', handlers) = ListUtil.foldlMap (fn (p, handlers) =>
adam@1516 3119 let
adam@1516 3120 val p' = p_page p
adam@1516 3121 in
adam@1516 3122 (p', latestUrlHandlers () @ handlers)
adam@1516 3123 end) [] ps
adam@1546 3124 val (protos, defs) = ListPair.unzip handlers
adam@1546 3125
adamc@870 3126 val hasDb = ref false
adamc@870 3127 val tables = ref []
adamc@872 3128 val views = ref []
adamc@870 3129 val sequences = ref []
adamc@870 3130 val dbstring = ref ""
adamc@870 3131 val expunge = ref 0
adamc@870 3132 val initialize = ref 0
adamc@870 3133 val prepped = ref []
adam@1731 3134 val hasJs = ref false
adamc@275 3135
adam@1623 3136 val _ = foldl (fn (d, env) =>
adam@1623 3137 ((case #1 d of
adam@1623 3138 DDatabase {name = x, expunge = y, initialize = z} => (hasDb := true;
adam@1623 3139 dbstring := x;
adam@1623 3140 expunge := y;
adam@1623 3141 initialize := z)
adam@1731 3142 | DJavaScript _ => hasJs := true
adam@1623 3143 | DTable (s, xts, _, _) => tables := (s, map (fn (x, t) =>
adam@1623 3144 (x, sql_type_in env t)) xts) :: !tables
adam@1623 3145 | DView (s, xts, _) => views := (s, map (fn (x, t) =>
adam@1623 3146 (x, sql_type_in env t)) xts) :: !views
adam@1623 3147 | DSequence s => sequences := s :: !sequences
adam@1623 3148 | DPreparedStatements ss => prepped := ss
adam@1623 3149 | _ => ());
adam@1623 3150 E.declBinds env d)) E.empty ds
adamc@377 3151
adam@1381 3152 val hasDb = !hasDb
adam@1381 3153
adam@1381 3154 fun expDb (e, _) =
adam@1381 3155 case e of
adam@1381 3156 ECon (_, _, SOME e) => expDb e
adam@1381 3157 | ESome (_, e) => expDb e
adam@1663 3158 | EFfiApp (_, _, es) => List.exists (expDb o #1) es
adam@1381 3159 | EApp (e, es) => expDb e orelse List.exists expDb es
adam@1381 3160 | EUnop (_, e) => expDb e
adam@1381 3161 | EBinop (_, e1, e2) => expDb e1 orelse expDb e2
adam@1381 3162 | ERecord (_, xes) => List.exists (expDb o #2) xes
adam@1381 3163 | EField (e, _) => expDb e
adam@1381 3164 | ECase (e, pes, _) => expDb e orelse List.exists (expDb o #2) pes
adam@1381 3165 | EError (e, _) => expDb e
adam@1381 3166 | EReturnBlob {blob = e1, mimeType = e2, ...} => expDb e1 orelse expDb e2
adam@1381 3167 | ERedirect (e, _) => expDb e
adam@1381 3168 | EWrite e => expDb e
adam@1381 3169 | ESeq (e1, e2) => expDb e1 orelse expDb e2
adam@1381 3170 | ELet (_, _, e1, e2) => expDb e1 orelse expDb e2
adam@1381 3171 | EQuery _ => true
adam@1381 3172 | EDml _ => true
adam@1381 3173 | ENextval _ => true
adam@1381 3174 | ESetval _ => true
adam@1381 3175 | EUnurlify (e, _, _) => expDb e
adam@1381 3176 | _ => false
adam@1381 3177
adam@1381 3178 fun declDb (d, _) =
adam@1381 3179 case d of
adam@1381 3180 DVal (_, _, _, e) => expDb e
adam@1381 3181 | DFun (_, _, _, _, e) => expDb e
adam@1381 3182 | DFunRec vis => List.exists (expDb o #5) vis
adam@1381 3183 | _ => false
adam@1381 3184
adam@1381 3185 val () = if not hasDb andalso List.exists declDb ds then
adam@1381 3186 ErrorMsg.error "Application uses a database but has none configured with 'database' in .urp file."
adam@1381 3187 else
adam@1381 3188 ()
adamc@734 3189
adamc@734 3190 val cookies = List.mapPartial (fn (DCookie s, _) => SOME s | _ => NONE) ds
adamc@734 3191
adamc@734 3192 val cookieCode = foldl (fn (cookie, acc) =>
adamc@734 3193 SOME (case acc of
adamc@734 3194 NONE => string ("uw_unnull(uw_Basis_get_cookie(ctx, \""
adamc@734 3195 ^ cookie ^ "\"))")
adamc@734 3196 | SOME acc => box [string ("uw_Basis_strcat(ctx, uw_unnull(uw_Basis_get_cookie(ctx, \""
adamc@734 3197 ^ cookie ^ "\")), uw_Basis_strcat(ctx, \"/\", "),
adamc@734 3198 acc,
adamc@734 3199 string "))"]))
adamc@734 3200 NONE cookies
adamc@770 3201
adamc@770 3202 fun makeChecker (name, rules : Settings.rule list) =
adamc@1094 3203 box [string "static int ",
adamc@770 3204 string name,
adamc@770 3205 string "(const char *s) {",
adamc@770 3206 newline,
adamc@770 3207 box [p_list_sep (box [])
adamc@770 3208 (fn rule =>
adamc@770 3209 box [string "if (!str",
adamc@770 3210 case #kind rule of
adamc@770 3211 Settings.Exact => box [string "cmp(s, \"",
adam@1656 3212 string (Prim.toCString (#pattern rule)),
adamc@770 3213 string "\"))"]
adamc@770 3214 | Settings.Prefix => box [string "ncmp(s, \"",
adam@1656 3215 string (Prim.toCString (#pattern rule)),
adamc@770 3216 string "\", ",
adamc@770 3217 string (Int.toString (size (#pattern rule))),
adamc@770 3218 string "))"],
adamc@770 3219 string " return ",
adamc@770 3220 string (case #action rule of
adamc@770 3221 Settings.Allow => "1"
adamc@770 3222 | Settings.Deny => "0"),
adamc@770 3223 string ";",
adamc@770 3224 newline]) rules,
adamc@770 3225 string "return 0;",
adamc@770 3226 newline],
adamc@770 3227 string "}",
adamc@770 3228 newline]
adamc@1073 3229
adam@1348 3230 val initializers = List.mapPartial (fn (DTask (Initialize, x1, x2, e), _) => SOME (x1, x2, e) | _ => NONE) ds
adam@1348 3231 val expungers = List.mapPartial (fn (DTask (ClientLeaves, x1, x2, e), _) => SOME (x1, x2, e) | _ => NONE) ds
adam@1349 3232 val periodics = List.mapPartial (fn (DTask (Periodic n, x1, x2, e), _) => SOME (n, x1, x2, e) | _ => NONE) ds
adamc@1263 3233
adam@1294 3234 val onError = ListUtil.search (fn (DOnError n, _) => SOME n | _ => NONE) ds
adam@1294 3235
adamc@1263 3236 val now = Time.now ()
adamc@1263 3237 val nowD = Date.fromTimeUniv now
adamc@1263 3238 val rfcFmt = "%a, %d %b %Y %H:%M:%S"
adamc@29 3239 in
adamc@1263 3240 box [string "#include \"",
ezyang@1739 3241 string (OS.Path.joinDirFile {dir = !Settings.configInclude,
adamc@1263 3242 file = "config.h"}),
adamc@1263 3243 string "\"",
adamc@1263 3244 newline,
adamc@1263 3245 string "#include <stdio.h>",
adamc@144 3246 newline,
adamc@144 3247 string "#include <stdlib.h>",
adamc@144 3248 newline,
adamc@272 3249 string "#include <string.h>",
adamc@272 3250 newline,
adamc@390 3251 string "#include <math.h>",
adamc@390 3252 newline,
adamc@1263 3253 string "#include <time.h>",
adamc@1263 3254 newline,
adamc@432 3255 if hasDb then
adamc@866 3256 box [string ("#include <" ^ #header (Settings.currentDbms ()) ^ ">"),
adamc@432 3257 newline]
adamc@432 3258 else
adamc@432 3259 box [],
adamc@764 3260 p_list_sep (box []) (fn s => box [string "#include \"",
adamc@764 3261 string s,
adamc@764 3262 string "\"",
adamc@764 3263 newline]) (Settings.getHeaders ()),
adamc@378 3264 string "#include \"",
ezyang@1739 3265 string (OS.Path.joinDirFile {dir = !Settings.configInclude,
adamc@378 3266 file = "urweb.h"}),
adamc@378 3267 string "\"",
adamc@101 3268 newline,
adamc@101 3269 newline,
adamc@804 3270
adam@1307 3271 box [string "static void uw_setup_limits() {",
adam@1307 3272 newline,
adam@1332 3273 case Settings.getMinHeap () of
adam@1332 3274 0 => box []
adam@1332 3275 | n => box [string "uw_min_heap",
adam@1332 3276 space,
adam@1332 3277 string "=",
adam@1332 3278 space,
adam@1332 3279 string (Int.toString n),
adam@1332 3280 string ";",
adam@1332 3281 newline,
adam@1332 3282 newline],
adam@1307 3283 box [p_list_sep (box []) (fn (class, num) =>
adam@1307 3284 let
adam@1307 3285 val num = case class of
adam@1307 3286 "page" => Int.max (2048, num)
adam@1307 3287 | _ => num
adam@1307 3288 in
adam@1307 3289 box [string ("uw_" ^ class ^ "_max"),
adam@1307 3290 space,
adam@1307 3291 string "=",
adam@1307 3292 space,
adam@1307 3293 string (Int.toString num),
adam@1307 3294 string ";",
adam@1307 3295 newline]
adam@1307 3296 end) (Settings.limits ())],
adam@1307 3297 string "}",
adam@1307 3298 newline,
adam@1307 3299 newline],
adam@1307 3300
adamc@1164 3301 #code (Settings.currentProtocol ()) (),
adamc@1164 3302
adamc@870 3303 if hasDb then
adamc@870 3304 #init (Settings.currentDbms ()) {dbstring = !dbstring,
adamc@870 3305 prepared = !prepped,
adamc@870 3306 tables = !tables,
adamc@872 3307 views = !views,
adamc@870 3308 sequences = !sequences}
adamc@870 3309 else
adam@1307 3310 box [string "static void uw_client_init(void) { };",
adamc@891 3311 newline,
adam@1307 3312 string "static void uw_db_init(uw_context ctx) { };",
adamc@870 3313 newline,
adam@1307 3314 string "static int uw_db_begin(uw_context ctx) { return 0; };",
adamc@870 3315 newline,
adam@1307 3316 string "static void uw_db_close(uw_context ctx) { };",
adamc@1094 3317 newline,
adam@1307 3318 string "static int uw_db_commit(uw_context ctx) { return 0; };",
adamc@870 3319 newline,
adam@1307 3320 string "static int uw_db_rollback(uw_context ctx) { return 0; };"],
adamc@870 3321 newline,
adamc@870 3322 newline,
adamc@870 3323
adam@1407 3324 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 3325 newline,
adam@1407 3326 newline,
adam@1407 3327
adam@1407 3328 p_list_sep newline (fn x => x) pds,
adam@1407 3329 newline,
adam@1407 3330 newline,
adam@1407 3331 string "static int uw_input_num(const char *name) {",
adam@1407 3332 newline,
adam@1407 3333 makeSwitch (fnums, 0),
adam@1407 3334 string "}",
adam@1407 3335 newline,
adam@1407 3336 newline,
adam@1407 3337
adam@1349 3338 box (ListUtil.mapi (fn (i, (_, x1, x2, e)) =>
adam@1349 3339 box [string "static void uw_periodic",
adam@1349 3340 string (Int.toString i),
adam@1349 3341 string "(uw_context ctx) {",
adam@1349 3342 newline,
adam@1349 3343 box [string "uw_unit __uwr_",
adam@1349 3344 string x1,
adam@1431 3345 string "_0 = 0, __uwr_",
adam@1349 3346 string x2,
adam@1431 3347 string "_1 = 0;",
adam@1349 3348 newline,
adam@1349 3349 p_exp (E.pushERel (E.pushERel env x1 dummyt) x2 dummyt) e,
adam@1349 3350 string ";",
adam@1349 3351 newline],
adam@1349 3352 string "}",
adam@1349 3353 newline,
adam@1349 3354 newline]) periodics),
adam@1349 3355
adam@1349 3356 string "static uw_periodic my_periodics[] = {",
adam@1349 3357 box (ListUtil.mapi (fn (i, (n, _, _, _)) =>
adam@1349 3358 box [string "{uw_periodic",
adam@1349 3359 string (Int.toString i),
adam@1349 3360 string ",",
adam@1349 3361 space,
adam@1349 3362 string (Int64.toString n),
adam@1349 3363 string "},"]) periodics),
adam@1349 3364 string "{NULL}};",
adam@1349 3365 newline,
adam@1349 3366 newline,
adam@1349 3367
adamc@770 3368 makeChecker ("uw_check_url", Settings.getUrlRules ()),
adamc@770 3369 newline,
adamc@770 3370
adamc@770 3371 makeChecker ("uw_check_mime", Settings.getMimeRules ()),
adamc@770 3372 newline,
adam@1465 3373
adam@1465 3374 makeChecker ("uw_check_requestHeader", Settings.getRequestHeaderRules ()),
adam@1465 3375 newline,
adam@1465 3376
adam@1465 3377 makeChecker ("uw_check_responseHeader", Settings.getResponseHeaderRules ()),
adam@1465 3378 newline,
adamc@734 3379
adamc@734 3380 string "extern void uw_sign(const char *in, char *out);",
adamc@734 3381 newline,
adamc@734 3382 string "extern int uw_hash_blocksize;",
adamc@734 3383 newline,
adamc@1094 3384 string "static uw_Basis_string uw_cookie_sig(uw_context ctx) {",
adamc@734 3385 newline,
adamc@734 3386 box [string "uw_Basis_string r = uw_malloc(ctx, uw_hash_blocksize);",
adamc@734 3387 newline,
adamc@734 3388 string "uw_sign(",
adamc@734 3389 case cookieCode of
adamc@734 3390 NONE => string "\"\""
adamc@734 3391 | SOME code => code,
adamc@734 3392 string ", r);",
adamc@734 3393 newline,
adamc@734 3394 string "return uw_Basis_makeSigString(ctx, r);",
adamc@734 3395 newline],
adamc@734 3396 string "}",
adamc@734 3397 newline,
adamc@734 3398 newline,
adamc@734 3399
adam@1546 3400 box (rev protos),
adam@1546 3401 box (rev defs),
adam@1516 3402
adamc@1094 3403 string "static void uw_handle(uw_context ctx, char *request) {",
adamc@101 3404 newline,
adamc@863 3405 string "if (!strcmp(request, \"",
adam@1542 3406 string app_js,
adamc@863 3407 string "\")) {",
adamc@569 3408 newline,
adamc@1263 3409 box [string "uw_Basis_string ims = uw_Basis_requestHeader(ctx, \"If-modified-since\");",
adamc@1263 3410 newline,
adamc@1263 3411 string ("if (ims && !strcmp(ims, \"" ^ Date.fmt rfcFmt nowD ^ "\")) {"),
adamc@1263 3412 newline,
adamc@1263 3413 box [string "uw_clear_headers(ctx);",
adamc@1263 3414 newline,
adam@1320 3415 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 3416 newline,
adamc@1263 3417 string "return;",
adamc@1263 3418 newline],
adamc@1263 3419 string "}",
adamc@1263 3420 newline,
adamc@1263 3421 newline,
adamc@1263 3422 string "uw_write_header(ctx, \"Content-type: text/javascript\\r\\n\");",
adamc@1263 3423 newline,
adamc@1263 3424 string ("uw_write_header(ctx, \"Last-modified: " ^ Date.fmt rfcFmt nowD ^ "\\r\\n\");"),
adamc@569 3425 newline,
adamc@569 3426 string "uw_write(ctx, jslib);",
adamc@569 3427 newline,
adamc@569 3428 string "return;",
adamc@569 3429 newline],
adamc@569 3430 string "}",
adamc@569 3431 newline,
adamc@101 3432 p_list_sep newline (fn x => x) pds',
adamc@101 3433 newline,
adamc@1110 3434 string "uw_clear_headers(ctx);",
adamc@1110 3435 newline,
adamc@1110 3436 string "uw_write_header(ctx, \"HTTP/1.1 404 Not Found\\r\\nContent-type: text/plain\\r\\n\");",
adamc@1110 3437 newline,
adamc@1110 3438 string "uw_write(ctx, \"Not Found\");",
adamc@387 3439 newline,
adamc@101 3440 string "}",
adamc@275 3441 newline,
adamc@275 3442 newline,
adamc@870 3443
adam@1348 3444 box [string "static void uw_expunger(uw_context ctx, uw_Basis_client cli) {",
adam@1348 3445 newline,
adam@1348 3446
adam@1348 3447 p_list_sep (box []) (fn (x1, x2, e) => box [string "({",
adam@1348 3448 newline,
adam@1348 3449 string "uw_Basis_client __uwr_",
adam@1348 3450 string x1,
adam@1348 3451 string "_0 = cli;",
adam@1348 3452 newline,
adam@1348 3453 string "uw_unit __uwr_",
adam@1348 3454 string x2,
adam@1431 3455 string "_1 = 0;",
adam@1348 3456 newline,
adam@1348 3457 p_exp (E.pushERel (E.pushERel env x1 (TFfi ("Basis", "client"), ErrorMsg.dummySpan))
adam@1348 3458 x2 dummyt) e,
adam@1348 3459 string ";",
adam@1348 3460 newline,
adam@1348 3461 string "});",
adam@1348 3462 newline]) expungers,
adam@1348 3463
adam@1348 3464 if hasDb then
adamc@870 3465 box [p_enamed env (!expunge),
adamc@870 3466 string "(ctx, cli);",
adam@1348 3467 newline]
adam@1348 3468 else
adam@1348 3469 box [],
adam@1348 3470 string "}"],
adamc@870 3471
adam@1348 3472 newline,
adam@1348 3473 string "static void uw_initializer(uw_context ctx) {",
adam@1348 3474 newline,
adam@1348 3475 box [p_list_sep (box []) (fn (x1, x2, e) => box [string "({",
adam@1348 3476 newline,
adam@1348 3477 string "uw_unit __uwr_",
adam@1348 3478 string x1,
adam@1431 3479 string "_0 = 0, __uwr_",
adam@1348 3480 string x2,
adam@1431 3481 string "_1 = 0;",
adam@1348 3482 newline,
adam@1348 3483 p_exp (E.pushERel (E.pushERel env x1 dummyt) x2 dummyt) e,
adam@1348 3484 string ";",
adam@1348 3485 newline,
adam@1348 3486 string "});",
adam@1348 3487 newline]) initializers,
adam@1348 3488 if hasDb then
adam@1348 3489 box [p_enamed env (!initialize),
adam@1431 3490 string "(ctx, 0);",
adam@1348 3491 newline]
adam@1348 3492 else
adam@1348 3493 box []],
adam@1348 3494 string "}",
adam@1348 3495 newline,
adamc@1094 3496
adam@1294 3497 case onError of
adam@1294 3498 NONE => box []
adam@1294 3499 | SOME n => box [string "static void uw_onError(uw_context ctx, char *msg) {",
adam@1294 3500 newline,
adam@1483 3501 if Settings.getDebug () then
adam@1483 3502 box []
adam@1483 3503 else
adam@1483 3504 box [string "uw_cutErrorLocation(msg);",
adam@1483 3505 newline],
adam@1731 3506 if !hasJs then
adam@1731 3507 box [string "uw_set_script_header(ctx, \"",
adam@1731 3508 string allScripts,
adam@1731 3509 string "\");",
adam@1731 3510 newline]
adam@1731 3511 else
adam@1731 3512 box [],
adam@1294 3513 box [string "uw_write(ctx, ",
adam@1294 3514 p_enamed env n,
adam@1431 3515 string "(ctx, msg, 0));",
adam@1294 3516 newline],
adam@1294 3517 string "}",
adam@1294 3518 newline,
adam@1294 3519 newline],
adam@1294 3520
adamc@1094 3521 string "uw_app uw_application = {",
adamc@1094 3522 p_list_sep (box [string ",", newline]) string
adamc@1094 3523 [Int.toString (SM.foldl Int.max 0 fnums + 1),
adamc@1094 3524 Int.toString (Settings.getTimeout ()),
adamc@1094 3525 "\"" ^ Settings.getUrlPrefix () ^ "\"",
adamc@1094 3526 "uw_client_init", "uw_initializer", "uw_expunger",
adamc@1094 3527 "uw_db_init", "uw_db_begin", "uw_db_commit", "uw_db_rollback", "uw_db_close",
adamc@1094 3528 "uw_handle",
adam@1465 3529 "uw_input_num", "uw_cookie_sig", "uw_check_url", "uw_check_mime", "uw_check_requestHeader", "uw_check_responseHeader",
adam@1629 3530 case onError of NONE => "NULL" | SOME _ => "uw_onError", "my_periodics",
adam@1656 3531 "\"" ^ Prim.toCString (Settings.getTimeFormat ()) ^ "\""],
adamc@1094 3532 string "};",
adamc@1094 3533 newline]
adamc@29 3534 end
adamc@29 3535
adamc@274 3536 fun p_sql env (ds, _) =
adamc@274 3537 let
adamc@274 3538 val (pps, _) = ListUtil.foldlMap
adamc@274 3539 (fn (dAll as (d, _), env) =>
adamc@274 3540 let
adamc@274 3541 val pp = case d of
adamc@707 3542 DTable (s, xts, pk, csts) =>
adamc@274 3543 box [string "CREATE TABLE ",
adamc@274 3544 string s,
adamc@274 3545 string "(",
adamc@274 3546 p_list (fn (x, t) =>
adamc@874 3547 let
adamc@874 3548 val t = sql_type_in env t
adamc@874 3549 in
adamc@874 3550 box [string "uw_",
adamc@874 3551 string (CharVector.map Char.toLower x),
adamc@874 3552 space,
adamc@874 3553 string (#p_sql_type (Settings.currentDbms ()) t),
adamc@874 3554 case t of
adamc@874 3555 Nullable _ => box []
adamc@874 3556 | _ => string " NOT NULL"]
adamc@874 3557 end) xts,
adamc@707 3558 case (pk, csts) of
adamc@707 3559 ("", []) => box []
adamc@707 3560 | _ => string ",",
adamc@704 3561 cut,
adamc@707 3562 case pk of
adamc@707 3563 "" => box []
adamc@707 3564 | _ => box [string "PRIMARY",
adamc@707 3565 space,
adamc@707 3566 string "KEY",
adamc@707 3567 space,
adamc@707 3568 string "(",
adamc@707 3569 string pk,
adamc@707 3570 string ")",
adamc@707 3571 case csts of
adamc@707 3572 [] => box []
adamc@707 3573 | _ => string ",",
adamc@707 3574 newline],
adamc@704 3575 p_list_sep (box [string ",", newline])
adamc@704 3576 (fn (x, c) =>
adamc@704 3577 box [string "CONSTRAINT",
adamc@704 3578 space,
adamc@704 3579 string s,
adamc@704 3580 string "_",
adamc@704 3581 string x,
adamc@704 3582 space,
adamc@704 3583 string c]) csts,
adamc@704 3584 newline,
adamc@274 3585 string ");",
adamc@274 3586 newline,
adamc@274 3587 newline]
adamc@338 3588 | DSequence s =>
adamc@877 3589 box [string (#createSequence (Settings.currentDbms ()) s),
adamc@338 3590 string ";",
adamc@338 3591 newline,
adamc@338 3592 newline]
adamc@754 3593 | DView (s, xts, q) =>
adamc@754 3594 box [string "CREATE VIEW",
adamc@754 3595 space,
adamc@754 3596 string s,
adamc@754 3597 space,
adamc@754 3598 string "AS",
adamc@754 3599 space,
adamc@754 3600 string q,
adamc@754 3601 string ";",
adamc@754 3602 newline,
adamc@754 3603 newline]
adamc@274 3604 | _ => box []
adamc@274 3605 in
adamc@274 3606 (pp, E.declBinds env dAll)
adamc@274 3607 end)
adamc@274 3608 env ds
adamc@274 3609 in
adamc@882 3610 box (string (#sqlPrefix (Settings.currentDbms ())) :: pps)
adamc@274 3611 end
adamc@274 3612
adamc@29 3613 end