Mercurial > urweb

annotate src/cjr_print.sml @ 1451:b6ce8ef0ea88

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