Mercurial > urweb

annotate src/cjr_print.sml @ 1622:a20daedfd1d0

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