Mercurial > urweb

annotate src/cjr_print.sml @ 1659:8de2ea0a0701

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