Mercurial > urweb

annotate src/cjr_print.sml @ 2182:d25c42e5d8f4

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Return to working version mode
author Adam Chlipala <adam@chlipala.net>
date Sun, 18 Oct 2015 14:46:50 -0400
parents f55b0e45422f
children 6eae499c56cb 2b1af5dc6dee
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
adam@2144 3668 box [string (Settings.mangleSql (CharVector.map Char.toLower x)),
adamc@874 3669 space,
adamc@874 3670 string (#p_sql_type (Settings.currentDbms ()) t),
adamc@874 3671 case t of
adamc@874 3672 Nullable _ => box []
adamc@874 3673 | _ => string " NOT NULL"]
adamc@874 3674 end) xts,
adamc@707 3675 case (pk, csts) of
adamc@707 3676 ("", []) => box []
adamc@707 3677 | _ => string ",",
adamc@704 3678 cut,
adamc@707 3679 case pk of
adamc@707 3680 "" => box []
adamc@707 3681 | _ => box [string "PRIMARY",
adamc@707 3682 space,
adamc@707 3683 string "KEY",
adamc@707 3684 space,
adamc@707 3685 string "(",
adamc@707 3686 string pk,
adamc@707 3687 string ")",
adamc@707 3688 case csts of
adamc@707 3689 [] => box []
adamc@707 3690 | _ => string ",",
adamc@707 3691 newline],
adamc@704 3692 p_list_sep (box [string ",", newline])
adamc@704 3693 (fn (x, c) =>
adamc@704 3694 box [string "CONSTRAINT",
adamc@704 3695 space,
adamc@704 3696 string s,
adamc@704 3697 string "_",
adamc@704 3698 string x,
adamc@704 3699 space,
adamc@704 3700 string c]) csts,
adamc@704 3701 newline,
adamc@274 3702 string ");",
adamc@274 3703 newline,
adamc@274 3704 newline]
adamc@338 3705 | DSequence s =>
adamc@877 3706 box [string (#createSequence (Settings.currentDbms ()) s),
adamc@338 3707 string ";",
adamc@338 3708 newline,
adamc@338 3709 newline]
adamc@754 3710 | DView (s, xts, q) =>
adamc@754 3711 box [string "CREATE VIEW",
adamc@754 3712 space,
adamc@754 3713 string s,
adamc@754 3714 space,
adamc@754 3715 string "AS",
adamc@754 3716 space,
adamc@754 3717 string q,
adamc@754 3718 string ";",
adamc@754 3719 newline,
adamc@754 3720 newline]
adamc@274 3721 | _ => box []
adamc@274 3722 in
adamc@274 3723 (pp, E.declBinds env dAll)
adamc@274 3724 end)
adamc@274 3725 env ds
adamc@274 3726 in
adamc@882 3727 box (string (#sqlPrefix (Settings.currentDbms ())) :: pps)
adamc@274 3728 end
adamc@274 3729
adamc@29 3730 end