Mercurial > urweb

annotate src/cjr_print.sml @ 1431:4a6f84092399

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