Mercurial > urweb

annotate src/cjr_print.sml @ 2134:752e5efe9da9

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