Mercurial > urweb

annotate src/cjr_print.sml @ 1633:deeeb036c8ed

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