Mercurial > urweb

annotate src/cjr_print.sml @ 287:3ed7a7c7b060

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Ask GCC to strip executables
author Adam Chlipala <adamc@hcoop.net>
date Sun, 07 Sep 2008 10:52:51 -0400
parents c0e4ac23522d
children 4260ad920c36
rev   line source
adamc@29 1 (* Copyright (c) 2008, 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@29 60 fun p_typ' par env (t, loc) =
adamc@29 61 case t of
adamc@269 62 TFun (t1, t2) => parenIf par (box [p_typ' true env t2,
adamc@109 63 space,
adamc@109 64 string "(*)",
adamc@109 65 space,
adamc@109 66 string "(",
adamc@109 67 p_typ env t1,
adamc@109 68 string ")"])
adamc@29 69 | TRecord i => box [string "struct",
adamc@29 70 space,
adamc@29 71 string "__lws_",
adamc@29 72 string (Int.toString i)]
adamc@188 73 | TDatatype (Enum, n, _) =>
adamc@188 74 (box [string "enum",
adamc@188 75 space,
adamc@188 76 string ("__lwe_" ^ #1 (E.lookupDatatype env n) ^ "_" ^ Int.toString n)]
adamc@188 77 handle CjrEnv.UnboundNamed _ => string ("__lwd_UNBOUND__" ^ Int.toString n))
adamc@198 78 | TDatatype (Option, n, xncs) =>
adamc@198 79 (case ListUtil.search #3 (!xncs) of
adamc@198 80 NONE => raise Fail "CjrPrint: TDatatype marked Option has no constructor with an argument"
adamc@198 81 | SOME t =>
adamc@198 82 case #1 t of
adamc@198 83 TDatatype _ => p_typ' par env t
adamc@199 84 | TFfi ("Basis", "string") => p_typ' par env t
adamc@198 85 | _ => box [p_typ' par env t,
adamc@198 86 string "*"])
adamc@188 87 | TDatatype (Default, n, _) =>
adamc@165 88 (box [string "struct",
adamc@165 89 space,
adamc@166 90 string ("__lwd_" ^ #1 (E.lookupDatatype env n) ^ "_" ^ Int.toString n ^ "*")]
adamc@166 91 handle CjrEnv.UnboundNamed _ => string ("__lwd_UNBOUND__" ^ Int.toString n))
adamc@53 92 | TFfi (m, x) => box [string "lw_", string m, string "_", string x]
adamc@29 93
adamc@29 94 and p_typ env = p_typ' false env
adamc@29 95
adamc@29 96 fun p_rel env n = string ("__lwr_" ^ #1 (E.lookupERel env n) ^ "_" ^ Int.toString (E.countERels env - n - 1))
adamc@29 97 handle CjrEnv.UnboundRel _ => string ("__lwr_UNBOUND_" ^ Int.toString (E.countERels env - n - 1))
adamc@29 98
adamc@109 99 fun p_enamed env n =
adamc@109 100 string ("__lwn_" ^ #1 (E.lookupENamed env n) ^ "_" ^ Int.toString n)
adamc@109 101 handle CjrEnv.UnboundNamed _ => string ("__lwn_UNBOUND_" ^ Int.toString n)
adamc@109 102
adamc@182 103 fun p_con_named env n =
adamc@182 104 string ("__lwc_" ^ #1 (E.lookupConstructor env n) ^ "_" ^ Int.toString n)
adamc@182 105 handle CjrEnv.UnboundNamed _ => string ("__lwc_UNBOUND_" ^ Int.toString n)
adamc@182 106
adamc@182 107 fun p_pat_preamble env (p, _) =
adamc@182 108 case p of
adamc@182 109 PWild => (box [],
adamc@182 110 env)
adamc@182 111 | PVar (x, t) => (box [p_typ env t,
adamc@182 112 space,
adamc@182 113 string "__lwr_",
adamc@182 114 string x,
adamc@182 115 string "_",
adamc@182 116 string (Int.toString (E.countERels env)),
adamc@182 117 string ";",
adamc@182 118 newline],
adamc@196 119 E.pushERel env x t)
adamc@182 120 | PPrim _ => (box [], env)
adamc@188 121 | PCon (_, _, NONE) => (box [], env)
adamc@188 122 | PCon (_, _, SOME p) => p_pat_preamble env p
adamc@182 123 | PRecord xps =>
adamc@182 124 foldl (fn ((_, p, _), (pp, env)) =>
adamc@182 125 let
adamc@182 126 val (pp', env) = p_pat_preamble env p
adamc@182 127 in
adamc@182 128 (box [pp', pp], env)
adamc@182 129 end) (box [], env) xps
adamc@182 130
adamc@182 131 fun p_patCon env pc =
adamc@182 132 case pc of
adamc@182 133 PConVar n => p_con_named env n
adamc@186 134 | PConFfi {mod = m, con, ...} => string ("lw_" ^ m ^ "_" ^ con)
adamc@182 135
adamc@182 136 fun p_pat (env, exit, depth) (p, _) =
adamc@182 137 case p of
adamc@182 138 PWild =>
adamc@182 139 (box [], env)
adamc@182 140 | PVar (x, t) =>
adamc@182 141 (box [string "__lwr_",
adamc@182 142 string x,
adamc@182 143 string "_",
adamc@182 144 string (Int.toString (E.countERels env)),
adamc@182 145 space,
adamc@182 146 string "=",
adamc@182 147 space,
adamc@182 148 string "disc",
adamc@182 149 string (Int.toString depth),
adamc@182 150 string ";"],
adamc@182 151 E.pushERel env x t)
adamc@182 152 | PPrim (Prim.Int n) =>
adamc@182 153 (box [string "if",
adamc@182 154 space,
adamc@182 155 string "(disc",
adamc@182 156 string (Int.toString depth),
adamc@182 157 space,
adamc@182 158 string "!=",
adamc@182 159 space,
adamc@276 160 Prim.p_t_GCC (Prim.Int n),
adamc@182 161 string ")",
adamc@182 162 space,
adamc@182 163 exit],
adamc@182 164 env)
adamc@182 165 | PPrim (Prim.String s) =>
adamc@182 166 (box [string "if",
adamc@182 167 space,
adamc@182 168 string "(strcmp(disc",
adamc@182 169 string (Int.toString depth),
adamc@182 170 string ",",
adamc@182 171 space,
adamc@276 172 Prim.p_t_GCC (Prim.String s),
adamc@182 173 string "))",
adamc@182 174 space,
adamc@182 175 exit],
adamc@182 176 env)
adamc@182 177 | PPrim _ => raise Fail "CjrPrint: Disallowed PPrim primitive"
adamc@182 178
adamc@188 179 | PCon (dk, pc, po) =>
adamc@182 180 let
adamc@182 181 val (p, env) =
adamc@182 182 case po of
adamc@182 183 NONE => (box [], env)
adamc@182 184 | SOME p =>
adamc@182 185 let
adamc@182 186 val (p, env) = p_pat (env, exit, depth + 1) p
adamc@182 187
adamc@182 188 val (x, to) = case pc of
adamc@182 189 PConVar n =>
adamc@182 190 let
adamc@182 191 val (x, to, _) = E.lookupConstructor env n
adamc@182 192 in
adamc@196 193 ("lw_" ^ x, to)
adamc@182 194 end
adamc@188 195 | PConFfi {mod = m, con, arg, ...} =>
adamc@188 196 ("lw_" ^ m ^ "_" ^ con, arg)
adamc@182 197
adamc@182 198 val t = case to of
adamc@182 199 NONE => raise Fail "CjrPrint: Constructor mismatch"
adamc@182 200 | SOME t => t
adamc@182 201 in
adamc@182 202 (box [string "{",
adamc@182 203 newline,
adamc@182 204 p_typ env t,
adamc@182 205 space,
adamc@182 206 string "disc",
adamc@182 207 string (Int.toString (depth + 1)),
adamc@182 208 space,
adamc@182 209 string "=",
adamc@182 210 space,
adamc@198 211 case dk of
adamc@198 212 Enum => raise Fail "CjrPrint: Looking at argument of no-argument constructor"
adamc@198 213 | Default => box [string "disc",
adamc@198 214 string (Int.toString depth),
adamc@198 215 string "->data.",
adamc@198 216 string x]
adamc@198 217 | Option =>
adamc@198 218 case #1 t of
adamc@198 219 TDatatype _ => box [string "disc",
adamc@198 220 string (Int.toString depth)]
adamc@199 221 | TFfi ("Basis", "string") => box [string "disc",
adamc@199 222 string (Int.toString depth)]
adamc@198 223 | _ => box [string "*disc",
adamc@198 224 string (Int.toString depth)],
adamc@182 225 string ";",
adamc@182 226 newline,
adamc@182 227 p,
adamc@182 228 newline,
adamc@182 229 string "}"],
adamc@182 230 env)
adamc@182 231 end
adamc@182 232 in
adamc@182 233 (box [string "if",
adamc@182 234 space,
adamc@182 235 string "(disc",
adamc@182 236 string (Int.toString depth),
adamc@198 237 case (dk, po) of
adamc@198 238 (Enum, _) => box [space,
adamc@198 239 string "!=",
adamc@198 240 space,
adamc@198 241 p_patCon env pc]
adamc@198 242 | (Default, _) => box [string "->tag",
adamc@198 243 space,
adamc@198 244 string "!=",
adamc@198 245 space,
adamc@198 246 p_patCon env pc]
adamc@198 247 | (Option, NONE) => box [space,
adamc@198 248 string "!=",
adamc@198 249 space,
adamc@198 250 string "NULL"]
adamc@198 251 | (Option, SOME _) => box [space,
adamc@198 252 string "==",
adamc@198 253 space,
adamc@198 254 string "NULL"],
adamc@182 255 string ")",
adamc@182 256 space,
adamc@182 257 exit,
adamc@182 258 newline,
adamc@182 259 p],
adamc@182 260 env)
adamc@182 261 end
adamc@182 262
adamc@182 263 | PRecord xps =>
adamc@182 264 let
adamc@182 265 val (xps, env) =
adamc@182 266 ListUtil.foldlMap (fn ((x, p, t), env) =>
adamc@182 267 let
adamc@182 268 val (p, env) = p_pat (env, exit, depth + 1) p
adamc@182 269
adamc@182 270 val p = box [string "{",
adamc@182 271 newline,
adamc@182 272 p_typ env t,
adamc@182 273 space,
adamc@182 274 string "disc",
adamc@182 275 string (Int.toString (depth + 1)),
adamc@182 276 space,
adamc@182 277 string "=",
adamc@182 278 space,
adamc@182 279 string "disc",
adamc@182 280 string (Int.toString depth),
adamc@196 281 string ".__lwf_",
adamc@182 282 string x,
adamc@182 283 string ";",
adamc@182 284 newline,
adamc@182 285 p,
adamc@182 286 newline,
adamc@182 287 string "}"]
adamc@182 288 in
adamc@182 289 (p, env)
adamc@182 290 end) env xps
adamc@182 291 in
adamc@182 292 (p_list_sep newline (fn x => x) xps,
adamc@182 293 env)
adamc@182 294 end
adamc@182 295
adamc@182 296 local
adamc@182 297 val count = ref 0
adamc@182 298 in
adamc@182 299 fun newGoto () =
adamc@182 300 let
adamc@182 301 val r = !count
adamc@182 302 in
adamc@182 303 count := r + 1;
adamc@182 304 string ("L" ^ Int.toString r)
adamc@182 305 end
adamc@182 306 end
adamc@182 307
adamc@185 308 fun patConInfo env pc =
adamc@185 309 case pc of
adamc@185 310 PConVar n =>
adamc@185 311 let
adamc@185 312 val (x, _, dn) = E.lookupConstructor env n
adamc@185 313 val (dx, _) = E.lookupDatatype env dn
adamc@185 314 in
adamc@185 315 ("__lwd_" ^ dx ^ "_" ^ Int.toString dn,
adamc@196 316 "__lwc_" ^ x ^ "_" ^ Int.toString n,
adamc@196 317 "lw_" ^ x)
adamc@185 318 end
adamc@186 319 | PConFfi {mod = m, datatyp, con, ...} =>
adamc@185 320 ("lw_" ^ m ^ "_" ^ datatyp,
adamc@196 321 "lw_" ^ m ^ "_" ^ con,
adamc@196 322 "lw_" ^ con)
adamc@185 323
adamc@278 324 fun p_unsql env (tAll as (t, loc)) e =
adamc@278 325 case t of
adamc@278 326 TFfi ("Basis", "int") => box [string "*(lw_Basis_int *)", e]
adamc@278 327 | TFfi ("Basis", "float") => box [string "*(lw_Basis_float *)", e]
adamc@278 328 | TFfi ("Basis", "string") => box [string "lw_Basis_strdup(ctx, ", e, string ")"]
adamc@278 329 | TFfi ("Basis", "bool") => box [string "(*(int *)",
adamc@278 330 e,
adamc@278 331 string " ? lw_Basis_True : lw_Basis_False)"]
adamc@278 332 | _ => (ErrorMsg.errorAt loc "Don't know how to unmarshal type from SQL";
adamc@278 333 Print.eprefaces' [("Type", p_typ env tAll)];
adamc@278 334 string "ERROR")
adamc@278 335
adamc@282 336 datatype sql_type =
adamc@282 337 Int
adamc@282 338 | Float
adamc@282 339 | String
adamc@282 340 | Bool
adamc@282 341
adamc@282 342 fun p_sql_type t =
adamc@282 343 string (case t of
adamc@282 344 Int => "lw_Basis_int"
adamc@282 345 | Float => "lw_Basis_float"
adamc@282 346 | String => "lw_Basis_string"
adamc@282 347 | Bool => "lw_Basis_bool")
adamc@282 348
adamc@282 349 fun getPargs (e, _) =
adamc@282 350 case e of
adamc@282 351 EPrim (Prim.String _) => []
adamc@282 352 | EFfiApp ("Basis", "strcat", [e1, e2]) => getPargs e1 @ getPargs e2
adamc@282 353
adamc@282 354 | EFfiApp ("Basis", "sqlifyInt", [e]) => [(e, Int)]
adamc@282 355 | EFfiApp ("Basis", "sqlifyFloat", [e]) => [(e, Float)]
adamc@282 356 | EFfiApp ("Basis", "sqlifyString", [e]) => [(e, String)]
adamc@282 357 | EFfiApp ("Basis", "sqlifyBool", [e]) => [(e, Bool)]
adamc@282 358
adamc@282 359 | _ => raise Fail "CjrPrint: getPargs"
adamc@282 360
adamc@282 361 fun p_ensql t e =
adamc@282 362 case t of
adamc@282 363 Int => box [string "(char *)&", e]
adamc@282 364 | Float => box [string "(char *)&", e]
adamc@282 365 | String => e
adamc@282 366 | Bool => box [string "lw_Basis_ensqlBool(", e, string ")"]
adamc@282 367
adamc@282 368 fun p_ensql_len t e =
adamc@282 369 case t of
adamc@282 370 Int => string "sizeof(lw_Basis_int)"
adamc@282 371 | Float => string "sizeof(lw_Basis_float)"
adamc@282 372 | String => box [string "strlen(", e, string ")"]
adamc@282 373 | Bool => string "sizeof(lw_Basis_bool)"
adamc@282 374
adamc@182 375 fun p_exp' par env (e, loc) =
adamc@29 376 case e of
adamc@276 377 EPrim p => Prim.p_t_GCC p
adamc@29 378 | ERel n => p_rel env n
adamc@109 379 | ENamed n => p_enamed env n
adamc@188 380 | ECon (Enum, pc, _) => p_patCon env pc
adamc@198 381 | ECon (Option, pc, NONE) => string "NULL"
adamc@198 382 | ECon (Option, pc, SOME e) =>
adamc@198 383 let
adamc@198 384 val to = case pc of
adamc@198 385 PConVar n => #2 (E.lookupConstructor env n)
adamc@198 386 | PConFfi {arg, ...} => arg
adamc@198 387
adamc@198 388 val t = case to of
adamc@198 389 NONE => raise Fail "CjrPrint: ECon argument status mismatch"
adamc@198 390 | SOME t => t
adamc@198 391 in
adamc@198 392 case #1 t of
adamc@198 393 TDatatype _ => p_exp' par env e
adamc@199 394 | TFfi ("Basis", "string") => p_exp' par env e
adamc@198 395 | _ => box [string "({",
adamc@198 396 newline,
adamc@198 397 p_typ env t,
adamc@198 398 space,
adamc@198 399 string "*tmp",
adamc@198 400 space,
adamc@198 401 string "=",
adamc@198 402 space,
adamc@198 403 string "lw_malloc(ctx, sizeof(",
adamc@198 404 p_typ env t,
adamc@198 405 string "));",
adamc@198 406 newline,
adamc@198 407 string "*tmp",
adamc@198 408 space,
adamc@198 409 string "=",
adamc@198 410 p_exp' par env e,
adamc@198 411 string ";",
adamc@198 412 newline,
adamc@198 413 string "tmp;",
adamc@198 414 newline,
adamc@198 415 string "})"]
adamc@198 416 end
adamc@188 417 | ECon (Default, pc, eo) =>
adamc@181 418 let
adamc@196 419 val (xd, xc, xn) = patConInfo env pc
adamc@181 420 in
adamc@182 421 box [string "({",
adamc@181 422 newline,
adamc@181 423 string "struct",
adamc@181 424 space,
adamc@185 425 string xd,
adamc@181 426 space,
adamc@181 427 string "*tmp",
adamc@181 428 space,
adamc@181 429 string "=",
adamc@181 430 space,
adamc@185 431 string "lw_malloc(ctx, sizeof(struct ",
adamc@185 432 string xd,
adamc@181 433 string "));",
adamc@181 434 newline,
adamc@181 435 string "tmp->tag",
adamc@181 436 space,
adamc@181 437 string "=",
adamc@181 438 space,
adamc@185 439 string xc,
adamc@181 440 string ";",
adamc@181 441 newline,
adamc@181 442 case eo of
adamc@181 443 NONE => box []
adamc@185 444 | SOME e => box [string "tmp->data.",
adamc@196 445 string xn,
adamc@181 446 space,
adamc@181 447 string "=",
adamc@181 448 space,
adamc@181 449 p_exp env e,
adamc@181 450 string ";",
adamc@181 451 newline],
adamc@181 452 string "tmp;",
adamc@181 453 newline,
adamc@181 454 string "})"]
adamc@181 455 end
adamc@109 456
adamc@53 457 | EFfi (m, x) => box [string "lw_", string m, string "_", string x]
adamc@283 458 | EError (e, t) =>
adamc@283 459 box [string "({",
adamc@283 460 newline,
adamc@283 461 p_typ env t,
adamc@283 462 space,
adamc@283 463 string "tmp;",
adamc@283 464 newline,
adamc@283 465 string "lw_Basis_error(ctx, ",
adamc@283 466 p_exp env e,
adamc@283 467 string ");",
adamc@283 468 newline,
adamc@283 469 string "tmp;",
adamc@283 470 newline,
adamc@283 471 string "})"]
adamc@53 472 | EFfiApp (m, x, es) => box [string "lw_",
adamc@53 473 string m,
adamc@53 474 string "_",
adamc@53 475 string x,
adamc@117 476 string "(ctx, ",
adamc@53 477 p_list (p_exp env) es,
adamc@53 478 string ")"]
adamc@129 479 | EApp (e1, e2) =>
adamc@129 480 let
adamc@129 481 fun unravel (f, acc) =
adamc@129 482 case #1 f of
adamc@129 483 EApp (f', arg) => unravel (f', arg :: acc)
adamc@129 484 | _ => (f, acc)
adamc@129 485
adamc@129 486 val (f, args) = unravel (e1, [e2])
adamc@129 487 in
adamc@129 488 parenIf par (box [p_exp' true env e1,
adamc@129 489 string "(ctx,",
adamc@129 490 space,
adamc@129 491 p_list_sep (box [string ",", space]) (p_exp env) args,
adamc@129 492 string ")"])
adamc@129 493 end
adamc@29 494
adamc@29 495 | ERecord (i, xes) => box [string "({",
adamc@29 496 space,
adamc@29 497 string "struct",
adamc@29 498 space,
adamc@29 499 string ("__lws_" ^ Int.toString i),
adamc@29 500 space,
adamc@181 501 string "tmp",
adamc@29 502 space,
adamc@29 503 string "=",
adamc@29 504 space,
adamc@29 505 string "{",
adamc@29 506 p_list (fn (_, e) =>
adamc@29 507 p_exp env e) xes,
adamc@29 508 string "};",
adamc@29 509 space,
adamc@181 510 string "tmp;",
adamc@29 511 space,
adamc@29 512 string "})" ]
adamc@29 513 | EField (e, x) =>
adamc@29 514 box [p_exp' true env e,
adamc@182 515 string ".__lwf_",
adamc@29 516 string x]
adamc@29 517
adamc@182 518 | ECase (e, pes, {disc, result}) =>
adamc@182 519 let
adamc@182 520 val final = newGoto ()
adamc@182 521
adamc@182 522 val body = foldl (fn ((p, e), body) =>
adamc@182 523 let
adamc@182 524 val exit = newGoto ()
adamc@182 525 val (pr, _) = p_pat_preamble env p
adamc@182 526 val (p, env) = p_pat (env,
adamc@182 527 box [string "goto",
adamc@182 528 space,
adamc@182 529 exit,
adamc@182 530 string ";"],
adamc@182 531 0) p
adamc@182 532 in
adamc@182 533 box [body,
adamc@182 534 box [string "{",
adamc@182 535 newline,
adamc@182 536 pr,
adamc@182 537 newline,
adamc@182 538 p,
adamc@182 539 newline,
adamc@182 540 string "result",
adamc@182 541 space,
adamc@182 542 string "=",
adamc@182 543 space,
adamc@182 544 p_exp env e,
adamc@182 545 string ";",
adamc@182 546 newline,
adamc@182 547 string "goto",
adamc@182 548 space,
adamc@182 549 final,
adamc@182 550 string ";",
adamc@182 551 newline,
adamc@182 552 string "}"],
adamc@182 553 newline,
adamc@182 554 exit,
adamc@182 555 string ":",
adamc@182 556 newline]
adamc@182 557 end) (box []) pes
adamc@182 558 in
adamc@182 559 box [string "({",
adamc@182 560 newline,
adamc@182 561 p_typ env disc,
adamc@182 562 space,
adamc@182 563 string "disc0",
adamc@182 564 space,
adamc@182 565 string "=",
adamc@182 566 space,
adamc@182 567 p_exp env e,
adamc@182 568 string ";",
adamc@182 569 newline,
adamc@182 570 p_typ env result,
adamc@182 571 space,
adamc@182 572 string "result;",
adamc@182 573 newline,
adamc@182 574 body,
adamc@182 575 string "lw_error(ctx, FATAL, \"",
adamc@182 576 string (ErrorMsg.spanToString loc),
adamc@182 577 string ": pattern match failure\");",
adamc@182 578 newline,
adamc@182 579 final,
adamc@182 580 string ":",
adamc@182 581 space,
adamc@182 582 string "result;",
adamc@182 583 newline,
adamc@182 584 string "})"]
adamc@182 585 end
adamc@181 586
adamc@117 587 | EWrite e => box [string "(lw_write(ctx, ",
adamc@102 588 p_exp env e,
adamc@102 589 string "), lw_unit_v)"]
adamc@102 590
adamc@106 591 | ESeq (e1, e2) => box [string "(",
adamc@106 592 p_exp env e1,
adamc@106 593 string ",",
adamc@106 594 space,
adamc@106 595 p_exp env e2,
adamc@106 596 string ")"]
adamc@269 597 | ELet (x, t, e1, e2) => box [string "({",
adamc@269 598 newline,
adamc@269 599 p_typ env t,
adamc@269 600 space,
adamc@272 601 string "__lwr_",
adamc@272 602 string x,
adamc@272 603 string "_",
adamc@272 604 string (Int.toString (E.countERels env)),
adamc@269 605 space,
adamc@269 606 string "=",
adamc@269 607 space,
adamc@269 608 p_exp env e1,
adamc@269 609 string ";",
adamc@269 610 newline,
adamc@269 611 p_exp (E.pushERel env x t) e2,
adamc@269 612 string ";",
adamc@269 613 newline,
adamc@269 614 string "})"]
adamc@269 615
adamc@282 616 | EQuery {exps, tables, rnum, state, query, body, initial, prepared} =>
adamc@278 617 let
adamc@278 618 val exps = map (fn (x, t) => ("__lwf_" ^ x, t)) exps
adamc@278 619 val tables = ListUtil.mapConcat (fn (x, xts) =>
adamc@278 620 map (fn (x', t) => ("__lwf_" ^ x ^ ".__lwf_" ^ x', t)) xts)
adamc@278 621 tables
adamc@278 622
adamc@278 623 val outputs = exps @ tables
adamc@278 624 in
adamc@278 625 box [string "({",
adamc@278 626 newline,
adamc@278 627 string "PGconn *conn = lw_get_db(ctx);",
adamc@278 628 newline,
adamc@282 629 case prepared of
adamc@282 630 NONE => box [string "char *query = ",
adamc@282 631 p_exp env query,
adamc@282 632 string ";",
adamc@282 633 newline]
adamc@282 634 | SOME _ =>
adamc@282 635 let
adamc@282 636 val ets = getPargs query
adamc@282 637 in
adamc@282 638 box [p_list_sepi newline
adamc@282 639 (fn i => fn (e, t) =>
adamc@282 640 box [p_sql_type t,
adamc@282 641 space,
adamc@282 642 string "arg",
adamc@282 643 string (Int.toString (i + 1)),
adamc@282 644 space,
adamc@282 645 string "=",
adamc@282 646 space,
adamc@282 647 p_exp env e,
adamc@282 648 string ";"])
adamc@282 649 ets,
adamc@282 650 newline,
adamc@282 651 newline,
adamc@282 652
adamc@282 653 string "const char *paramValues[] = { ",
adamc@282 654 p_list_sepi (box [string ",", space])
adamc@282 655 (fn i => fn (_, t) => p_ensql t (box [string "arg",
adamc@282 656 string (Int.toString (i + 1))]))
adamc@282 657 ets,
adamc@282 658 string " };",
adamc@282 659 newline,
adamc@282 660 newline,
adamc@282 661
adamc@282 662 string "const int paramLengths[] = { ",
adamc@282 663 p_list_sepi (box [string ",", space])
adamc@282 664 (fn i => fn (_, t) => p_ensql_len t (box [string "arg",
adamc@282 665 string (Int.toString (i + 1))]))
adamc@282 666 ets,
adamc@282 667 string " };",
adamc@282 668 newline,
adamc@282 669 newline,
adamc@282 670
adamc@282 671 string "const static int paramFormats[] = { ",
adamc@282 672 p_list_sep (box [string ",", space]) (fn _ => string "1") ets,
adamc@282 673 string " };",
adamc@282 674 newline,
adamc@282 675 newline]
adamc@282 676 end,
adamc@278 677 string "int n, i;",
adamc@278 678 newline,
adamc@278 679 p_typ env state,
adamc@278 680 space,
adamc@278 681 string "acc",
adamc@278 682 space,
adamc@278 683 string "=",
adamc@278 684 space,
adamc@278 685 p_exp env initial,
adamc@278 686 string ";",
adamc@278 687 newline,
adamc@282 688 string "PGresult *res = ",
adamc@282 689 case prepared of
adamc@282 690 NONE => string "PQexecParams(conn, query, 0, NULL, NULL, NULL, NULL, 1);"
adamc@282 691 | SOME n => box [string "PQexecPrepared(conn, \"lw",
adamc@282 692 string (Int.toString n),
adamc@282 693 string "\", ",
adamc@282 694 string (Int.toString (length (getPargs query))),
adamc@282 695 string ", paramValues, paramLengths, paramFormats, 1);"],
adamc@278 696 newline,
adamc@278 697 newline,
adamc@277 698
adamc@278 699 string "if (res == NULL) lw_error(ctx, FATAL, \"Out of memory allocating query result.\");",
adamc@278 700 newline,
adamc@278 701 newline,
adamc@277 702
adamc@278 703 string "if (PQresultStatus(res) != PGRES_TUPLES_OK) {",
adamc@278 704 newline,
adamc@278 705 box [string "PQclear(res);",
adamc@278 706 newline,
adamc@278 707 string "lw_error(ctx, FATAL, \"",
adamc@278 708 string (ErrorMsg.spanToString loc),
adamc@282 709 string ": Query failed:\\n%s\\n%s\", ",
adamc@282 710 case prepared of
adamc@282 711 NONE => string "query"
adamc@282 712 | SOME _ => p_exp env query,
adamc@282 713 string ", PQerrorMessage(conn));",
adamc@278 714 newline],
adamc@278 715 string "}",
adamc@278 716 newline,
adamc@278 717 newline,
adamc@277 718
adamc@278 719 string "n = PQntuples(res);",
adamc@278 720 newline,
adamc@278 721 string "for (i = 0; i < n; ++i) {",
adamc@278 722 newline,
adamc@278 723 box [string "struct",
adamc@278 724 space,
adamc@278 725 string "__lws_",
adamc@278 726 string (Int.toString rnum),
adamc@278 727 space,
adamc@278 728 string "__lwr_r_",
adamc@278 729 string (Int.toString (E.countERels env)),
adamc@278 730 string ";",
adamc@278 731 newline,
adamc@278 732 p_typ env state,
adamc@278 733 space,
adamc@278 734 string "__lwr_acc_",
adamc@278 735 string (Int.toString (E.countERels env + 1)),
adamc@278 736 space,
adamc@278 737 string "=",
adamc@278 738 space,
adamc@278 739 string "acc;",
adamc@278 740 newline,
adamc@278 741 newline,
adamc@278 742
adamc@278 743 p_list_sepi (box []) (fn i =>
adamc@278 744 fn (proj, t) =>
adamc@278 745 box [string "__lwr_r_",
adamc@278 746 string (Int.toString (E.countERels env)),
adamc@278 747 string ".",
adamc@278 748 string proj,
adamc@278 749 space,
adamc@278 750 string "=",
adamc@278 751 space,
adamc@278 752 p_unsql env t
adamc@278 753 (box [string "PQgetvalue(res, i, ",
adamc@278 754 string (Int.toString i),
adamc@278 755 string ")"]),
adamc@278 756 string ";",
adamc@278 757 newline]) outputs,
adamc@278 758
adamc@278 759 newline,
adamc@278 760 newline,
adamc@278 761
adamc@278 762 string "acc",
adamc@278 763 space,
adamc@278 764 string "=",
adamc@278 765 space,
adamc@278 766 p_exp (E.pushERel
adamc@278 767 (E.pushERel env "r" (TRecord rnum, loc))
adamc@278 768 "acc" state)
adamc@278 769 body,
adamc@278 770 string ";",
adamc@278 771 newline],
adamc@278 772 string "}",
adamc@278 773 newline,
adamc@278 774 newline,
adamc@278 775 string "PQclear(res);",
adamc@278 776 newline,
adamc@278 777 string "acc;",
adamc@278 778 newline,
adamc@278 779 string "})"]
adamc@278 780 end
adamc@106 781
adamc@29 782 and p_exp env = p_exp' false env
adamc@29 783
adamc@129 784 fun p_fun env (fx, n, args, ran, e) =
adamc@129 785 let
adamc@129 786 val nargs = length args
adamc@129 787 val env' = foldl (fn ((x, dom), env) => E.pushERel env x dom) env args
adamc@129 788 in
adamc@129 789 box [string "static",
adamc@129 790 space,
adamc@129 791 p_typ env ran,
adamc@129 792 space,
adamc@129 793 string ("__lwn_" ^ fx ^ "_" ^ Int.toString n),
adamc@129 794 string "(",
adamc@129 795 p_list_sep (box [string ",", space]) (fn x => x)
adamc@129 796 (string "lw_context ctx" :: ListUtil.mapi (fn (i, (_, dom)) =>
adamc@129 797 box [p_typ env dom,
adamc@129 798 space,
adamc@129 799 p_rel env' (nargs - i - 1)]) args),
adamc@129 800 string ")",
adamc@129 801 space,
adamc@129 802 string "{",
adamc@129 803 newline,
adamc@129 804 box[string "return(",
adamc@129 805 p_exp env' e,
adamc@129 806 string ");"],
adamc@129 807 newline,
adamc@129 808 string "}"]
adamc@129 809 end
adamc@129 810
adamc@129 811 fun p_decl env (dAll as (d, _) : decl) =
adamc@29 812 case d of
adamc@29 813 DStruct (n, xts) =>
adamc@196 814 let
adamc@196 815 val env = E.declBinds env dAll
adamc@196 816 in
adamc@196 817 box [string "struct",
adamc@196 818 space,
adamc@196 819 string ("__lws_" ^ Int.toString n),
adamc@196 820 space,
adamc@196 821 string "{",
adamc@196 822 newline,
adamc@196 823 p_list_sep (box []) (fn (x, t) => box [p_typ env t,
adamc@196 824 space,
adamc@196 825 string "__lwf_",
adamc@196 826 string x,
adamc@196 827 string ";",
adamc@196 828 newline]) xts,
adamc@196 829 string "};"]
adamc@196 830 end
adamc@188 831 | DDatatype (Enum, x, n, xncs) =>
adamc@188 832 box [string "enum",
adamc@188 833 space,
adamc@188 834 string ("__lwe_" ^ x ^ "_" ^ Int.toString n),
adamc@188 835 space,
adamc@188 836 string "{",
adamc@188 837 space,
adamc@188 838 p_list_sep (box [string ",", space]) (fn (x, n, _) => string ("__lwc_" ^ x ^ "_" ^ Int.toString n)) xncs,
adamc@188 839 space,
adamc@188 840 string "};"]
adamc@198 841 | DDatatype (Option, _, _, _) => box []
adamc@188 842 | DDatatype (Default, x, n, xncs) =>
adamc@165 843 let
adamc@165 844 val xncsArgs = List.mapPartial (fn (x, n, NONE) => NONE
adamc@165 845 | (x, n, SOME t) => SOME (x, n, t)) xncs
adamc@165 846 in
adamc@165 847 box [string "enum",
adamc@165 848 space,
adamc@165 849 string ("__lwe_" ^ x ^ "_" ^ Int.toString n),
adamc@165 850 space,
adamc@165 851 string "{",
adamc@165 852 space,
adamc@165 853 p_list_sep (box [string ",", space]) (fn (x, n, _) => string ("__lwc_" ^ x ^ "_" ^ Int.toString n)) xncs,
adamc@165 854 space,
adamc@165 855 string "};",
adamc@165 856 newline,
adamc@165 857 newline,
adamc@165 858 string "struct",
adamc@165 859 space,
adamc@167 860 string ("__lwd_" ^ x ^ "_" ^ Int.toString n),
adamc@165 861 space,
adamc@165 862 string "{",
adamc@165 863 newline,
adamc@165 864 string "enum",
adamc@165 865 space,
adamc@165 866 string ("__lwe_" ^ x ^ "_" ^ Int.toString n),
adamc@165 867 space,
adamc@165 868 string "tag;",
adamc@165 869 newline,
adamc@165 870 box (case xncsArgs of
adamc@165 871 [] => []
adamc@165 872 | _ => [string "union",
adamc@165 873 space,
adamc@165 874 string "{",
adamc@165 875 newline,
adamc@165 876 p_list_sep newline (fn (x, n, t) => box [p_typ env t,
adamc@165 877 space,
adamc@196 878 string ("lw_" ^ x),
adamc@165 879 string ";"]) xncsArgs,
adamc@165 880 newline,
adamc@165 881 string "}",
adamc@165 882 space,
adamc@165 883 string "data;",
adamc@165 884 newline]),
adamc@165 885 string "};"]
adamc@188 886 end
adamc@29 887
adamc@196 888 | DDatatypeForward _ => box []
adamc@196 889
adamc@29 890 | DVal (x, n, t, e) =>
adamc@29 891 box [p_typ env t,
adamc@29 892 space,
adamc@29 893 string ("__lwn_" ^ x ^ "_" ^ Int.toString n),
adamc@29 894 space,
adamc@29 895 string "=",
adamc@29 896 space,
adamc@29 897 p_exp env e,
adamc@29 898 string ";"]
adamc@129 899 | DFun vi => p_fun env vi
adamc@129 900 | DFunRec vis =>
adamc@29 901 let
adamc@129 902 val env = E.declBinds env dAll
adamc@29 903 in
adamc@129 904 box [p_list_sep newline (fn (fx, n, args, ran, _) =>
adamc@129 905 box [string "static",
adamc@129 906 space,
adamc@129 907 p_typ env ran,
adamc@129 908 space,
adamc@129 909 string ("__lwn_" ^ fx ^ "_" ^ Int.toString n),
adamc@129 910 string "(lw_context,",
adamc@129 911 space,
adamc@129 912 p_list_sep (box [string ",", space])
adamc@129 913 (fn (_, dom) => p_typ env dom) args,
adamc@129 914 string ");"]) vis,
adamc@29 915 newline,
adamc@129 916 p_list_sep newline (p_fun env) vis,
adamc@129 917 newline]
adamc@29 918 end
adamc@273 919 | DTable (x, _) => box [string "/* SQL table ",
adamc@273 920 string x,
adamc@273 921 string " */",
adamc@273 922 newline]
adamc@275 923 | DDatabase s => box [string "static void lw_db_validate(lw_context);",
adamc@272 924 newline,
adamc@282 925 string "static void lw_db_prepare(lw_context);",
adamc@282 926 newline,
adamc@275 927 newline,
adamc@275 928 string "void lw_db_init(lw_context ctx) {",
adamc@273 929 newline,
adamc@272 930 string "PGconn *conn = PQconnectdb(\"",
adamc@272 931 string (String.toString s),
adamc@272 932 string "\");",
adamc@272 933 newline,
adamc@272 934 string "if (conn == NULL) lw_error(ctx, BOUNDED_RETRY, ",
adamc@272 935 string "\"libpq can't allocate a connection.\");",
adamc@272 936 newline,
adamc@272 937 string "if (PQstatus(conn) != CONNECTION_OK) {",
adamc@272 938 newline,
adamc@272 939 box [string "char msg[1024];",
adamc@272 940 newline,
adamc@272 941 string "strncpy(msg, PQerrorMessage(conn), 1024);",
adamc@272 942 newline,
adamc@272 943 string "msg[1023] = 0;",
adamc@272 944 newline,
adamc@272 945 string "PQfinish(conn);",
adamc@272 946 newline,
adamc@272 947 string "lw_error(ctx, BOUNDED_RETRY, ",
adamc@272 948 string "\"Connection to Postgres server failed: %s\", msg);"],
adamc@272 949 newline,
adamc@272 950 string "}",
adamc@272 951 newline,
adamc@272 952 string "lw_set_db(ctx, conn);",
adamc@272 953 newline,
adamc@275 954 string "lw_db_validate(ctx);",
adamc@275 955 newline,
adamc@282 956 string "lw_db_prepare(ctx);",
adamc@282 957 newline,
adamc@272 958 string "}",
adamc@272 959 newline,
adamc@272 960 newline,
adamc@272 961 string "void lw_db_close(lw_context ctx) {",
adamc@272 962 newline,
adamc@272 963 string "PQfinish(lw_get_db(ctx));",
adamc@272 964 newline,
adamc@272 965 string "}",
adamc@272 966 newline]
adamc@29 967
adamc@282 968 | DPreparedStatements ss =>
adamc@282 969 box [string "static void lw_db_prepare(lw_context ctx) {",
adamc@282 970 newline,
adamc@282 971 string "PGconn *conn = lw_get_db(ctx);",
adamc@282 972 newline,
adamc@282 973 string "PGresult *res;",
adamc@282 974 newline,
adamc@282 975 newline,
adamc@282 976
adamc@282 977 p_list_sepi newline (fn i => fn (s, n) =>
adamc@282 978 box [string "res = PQprepare(conn, \"lw",
adamc@282 979 string (Int.toString i),
adamc@282 980 string "\", \"",
adamc@282 981 string (String.toString s),
adamc@282 982 string "\", ",
adamc@282 983 string (Int.toString n),
adamc@282 984 string ", NULL);",
adamc@282 985 newline,
adamc@282 986 string "if (PQresultStatus(res) != PGRES_COMMAND_OK) {",
adamc@282 987 newline,
adamc@282 988 box [string "char msg[1024];",
adamc@282 989 newline,
adamc@282 990 string "strncpy(msg, PQerrorMessage(conn), 1024);",
adamc@282 991 newline,
adamc@282 992 string "msg[1023] = 0;",
adamc@282 993 newline,
adamc@282 994 string "PQclear(res);",
adamc@282 995 newline,
adamc@282 996 string "PQfinish(conn);",
adamc@282 997 newline,
adamc@282 998 string "lw_error(ctx, FATAL, \"Unable to create prepared statement:\\n",
adamc@282 999 string (String.toString s),
adamc@282 1000 string "\\n%s\", msg);",
adamc@282 1001 newline],
adamc@282 1002 string "}",
adamc@282 1003 newline,
adamc@282 1004 string "PQclear(res);",
adamc@282 1005 newline])
adamc@282 1006 ss,
adamc@282 1007
adamc@282 1008 string "}"]
adamc@282 1009
adamc@144 1010 datatype 'a search =
adamc@144 1011 Found of 'a
adamc@144 1012 | NotFound
adamc@144 1013 | Error
adamc@120 1014
adamc@275 1015 fun p_sqltype' env (tAll as (t, loc)) =
adamc@275 1016 case t of
adamc@275 1017 TFfi ("Basis", "int") => "int8"
adamc@275 1018 | TFfi ("Basis", "float") => "float8"
adamc@275 1019 | TFfi ("Basis", "string") => "text"
adamc@275 1020 | TFfi ("Basis", "bool") => "bool"
adamc@275 1021 | _ => (ErrorMsg.errorAt loc "Don't know SQL equivalent of type";
adamc@275 1022 Print.eprefaces' [("Type", p_typ env tAll)];
adamc@275 1023 "ERROR")
adamc@275 1024
adamc@275 1025 fun p_sqltype env t = string (p_sqltype' env t)
adamc@101 1026
adamc@101 1027 fun p_file env (ds, ps) =
adamc@29 1028 let
adamc@101 1029 val (pds, env) = ListUtil.foldlMap (fn (d, env) =>
adamc@31 1030 (p_decl env d,
adamc@31 1031 E.declBinds env d))
adamc@101 1032 env ds
adamc@144 1033
adamc@144 1034 val fields = foldl (fn ((ek, _, _, ts), fields) =>
adamc@144 1035 case ek of
adamc@144 1036 Core.Link => fields
adamc@144 1037 | Core.Action =>
adamc@280 1038 case List.nth (ts, length ts - 2) of
adamc@144 1039 (TRecord i, _) =>
adamc@144 1040 let
adamc@144 1041 val xts = E.lookupStruct env i
adamc@144 1042 val xtsSet = SS.addList (SS.empty, map #1 xts)
adamc@144 1043 in
adamc@144 1044 foldl (fn ((x, _), fields) =>
adamc@144 1045 let
adamc@144 1046 val xtsSet' = Option.getOpt (SM.find (fields, x), SS.empty)
adamc@144 1047 in
adamc@144 1048 SM.insert (fields, x, SS.union (SS.delete (xtsSet, x),
adamc@144 1049 xtsSet'))
adamc@144 1050 end) fields xts
adamc@144 1051 end
adamc@144 1052 | _ => raise Fail "CjrPrint: Last argument of action isn't record")
adamc@144 1053 SM.empty ps
adamc@144 1054
adamc@144 1055 val fnums = SM.foldli (fn (x, xs, fnums) =>
adamc@144 1056 let
adamc@144 1057 val unusable = SS.foldl (fn (x', unusable) =>
adamc@144 1058 case SM.find (fnums, x') of
adamc@144 1059 NONE => unusable
adamc@144 1060 | SOME n => IS.add (unusable, n))
adamc@144 1061 IS.empty xs
adamc@144 1062
adamc@144 1063 fun findAvailable n =
adamc@144 1064 if IS.member (unusable, n) then
adamc@144 1065 findAvailable (n + 1)
adamc@144 1066 else
adamc@144 1067 n
adamc@144 1068 in
adamc@144 1069 SM.insert (fnums, x, findAvailable 0)
adamc@144 1070 end)
adamc@144 1071 SM.empty fields
adamc@144 1072
adamc@144 1073 fun makeSwitch (fnums, i) =
adamc@144 1074 case SM.foldl (fn (n, NotFound) => Found n
adamc@144 1075 | (n, Error) => Error
adamc@144 1076 | (n, Found n') => if n = n' then
adamc@144 1077 Found n'
adamc@144 1078 else
adamc@144 1079 Error) NotFound fnums of
adamc@144 1080 NotFound => box [string "return",
adamc@144 1081 space,
adamc@144 1082 string "-1;"]
adamc@144 1083 | Found n => box [string "return",
adamc@144 1084 space,
adamc@144 1085 string (Int.toString n),
adamc@144 1086 string ";"]
adamc@144 1087 | Error =>
adamc@144 1088 let
adamc@144 1089 val cmap = SM.foldli (fn (x, n, cmap) =>
adamc@144 1090 let
adamc@144 1091 val ch = if i < size x then
adamc@144 1092 String.sub (x, i)
adamc@144 1093 else
adamc@144 1094 chr 0
adamc@144 1095
adamc@144 1096 val fnums = case CM.find (cmap, ch) of
adamc@144 1097 NONE => SM.empty
adamc@144 1098 | SOME fnums => fnums
adamc@144 1099 val fnums = SM.insert (fnums, x, n)
adamc@144 1100 in
adamc@144 1101 CM.insert (cmap, ch, fnums)
adamc@144 1102 end)
adamc@144 1103 CM.empty fnums
adamc@144 1104
adamc@144 1105 val cmap = CM.listItemsi cmap
adamc@144 1106 in
adamc@144 1107 case cmap of
adamc@144 1108 [(_, fnums)] =>
adamc@144 1109 box [string "if",
adamc@144 1110 space,
adamc@144 1111 string "(name[",
adamc@144 1112 string (Int.toString i),
adamc@144 1113 string "]",
adamc@144 1114 space,
adamc@144 1115 string "==",
adamc@144 1116 space,
adamc@144 1117 string "0)",
adamc@144 1118 space,
adamc@144 1119 string "return",
adamc@144 1120 space,
adamc@144 1121 string "-1;",
adamc@144 1122 newline,
adamc@144 1123 makeSwitch (fnums, i+1)]
adamc@144 1124 | _ =>
adamc@144 1125 box [string "switch",
adamc@144 1126 space,
adamc@144 1127 string "(name[",
adamc@144 1128 string (Int.toString i),
adamc@144 1129 string "])",
adamc@144 1130 space,
adamc@144 1131 string "{",
adamc@144 1132 newline,
adamc@144 1133 box (map (fn (ch, fnums) =>
adamc@144 1134 box [string "case",
adamc@144 1135 space,
adamc@144 1136 if ch = chr 0 then
adamc@144 1137 string "0:"
adamc@144 1138 else
adamc@144 1139 box [string "'",
adamc@144 1140 string (Char.toString ch),
adamc@144 1141 string "':"],
adamc@144 1142 newline,
adamc@144 1143 makeSwitch (fnums, i+1),
adamc@144 1144 newline]) cmap),
adamc@144 1145 string "default:",
adamc@144 1146 newline,
adamc@144 1147 string "return",
adamc@144 1148 space,
adamc@144 1149 string "-1;",
adamc@144 1150 newline,
adamc@144 1151 string "}"]
adamc@144 1152 end
adamc@144 1153
adamc@186 1154 fun capitalize s =
adamc@186 1155 if s = "" then
adamc@186 1156 ""
adamc@186 1157 else
adamc@186 1158 str (Char.toUpper (String.sub (s, 0))) ^ String.extract (s, 1, NONE)
adamc@186 1159
adamc@144 1160 fun unurlify (t, loc) =
adamc@144 1161 case t of
adamc@186 1162 TFfi (m, t) => string ("lw_" ^ m ^ "_unurlify" ^ capitalize t ^ "(ctx, &request)")
adamc@144 1163
adamc@144 1164 | TRecord 0 => string "lw_unit_v"
adamc@144 1165 | TRecord i =>
adamc@144 1166 let
adamc@144 1167 val xts = E.lookupStruct env i
adamc@144 1168 in
adamc@144 1169 box [string "({",
adamc@144 1170 newline,
adamc@144 1171 box (map (fn (x, t) =>
adamc@144 1172 box [p_typ env t,
adamc@144 1173 space,
adamc@144 1174 string x,
adamc@144 1175 space,
adamc@144 1176 string "=",
adamc@144 1177 space,
adamc@144 1178 unurlify t,
adamc@144 1179 string ";",
adamc@144 1180 newline]) xts),
adamc@144 1181 string "struct",
adamc@144 1182 space,
adamc@144 1183 string "__lws_",
adamc@144 1184 string (Int.toString i),
adamc@144 1185 space,
adamc@181 1186 string "tmp",
adamc@144 1187 space,
adamc@144 1188 string "=",
adamc@144 1189 space,
adamc@144 1190 string "{",
adamc@144 1191 space,
adamc@144 1192 p_list_sep (box [string ",", space]) (fn (x, _) => string x) xts,
adamc@144 1193 space,
adamc@144 1194 string "};",
adamc@144 1195 newline,
adamc@181 1196 string "tmp;",
adamc@144 1197 newline,
adamc@144 1198 string "})"]
adamc@144 1199 end
adamc@144 1200
adamc@188 1201 | TDatatype (Enum, i, _) =>
adamc@188 1202 let
adamc@188 1203 val (x, xncs) = E.lookupDatatype env i
adamc@188 1204
adamc@188 1205 fun doEm xncs =
adamc@188 1206 case xncs of
adamc@188 1207 [] => string ("(lw_error(ctx, FATAL, \"Error unurlifying datatype " ^ x ^ "\"), (enum __lwe_"
adamc@188 1208 ^ x ^ "_" ^ Int.toString i ^ ")0)")
adamc@188 1209 | (x', n, to) :: rest =>
adamc@188 1210 box [string "((!strncmp(request, \"",
adamc@188 1211 string x',
adamc@188 1212 string "\", ",
adamc@188 1213 string (Int.toString (size x')),
adamc@188 1214 string ") && (request[",
adamc@188 1215 string (Int.toString (size x')),
adamc@188 1216 string "] == 0 || request[",
adamc@188 1217 string (Int.toString (size x')),
adamc@188 1218 string ("] == '/')) ? __lwc_" ^ x' ^ "_" ^ Int.toString n),
adamc@188 1219 space,
adamc@188 1220 string ":",
adamc@188 1221 space,
adamc@188 1222 doEm rest,
adamc@188 1223 string ")"]
adamc@188 1224 in
adamc@188 1225 doEm xncs
adamc@188 1226 end
adamc@188 1227
adamc@198 1228 | TDatatype (Option, i, xncs) =>
adamc@198 1229 let
adamc@198 1230 val (x, _) = E.lookupDatatype env i
adamc@198 1231
adamc@198 1232 val (no_arg, has_arg, t) =
adamc@198 1233 case !xncs of
adamc@198 1234 [(no_arg, _, NONE), (has_arg, _, SOME t)] =>
adamc@198 1235 (no_arg, has_arg, t)
adamc@198 1236 | [(has_arg, _, SOME t), (no_arg, _, NONE)] =>
adamc@198 1237 (no_arg, has_arg, t)
adamc@198 1238 | _ => raise Fail "CjrPrint: unfooify misclassified Option datatype"
adamc@198 1239 in
adamc@198 1240 box [string "(request[0] == '/' ? ++request : request,",
adamc@198 1241 newline,
adamc@198 1242 string "((!strncmp(request, \"",
adamc@198 1243 string no_arg,
adamc@198 1244 string "\", ",
adamc@198 1245 string (Int.toString (size no_arg)),
adamc@198 1246 string ") && (request[",
adamc@198 1247 string (Int.toString (size no_arg)),
adamc@198 1248 string "] == 0 || request[",
adamc@198 1249 string (Int.toString (size no_arg)),
adamc@198 1250 string "] == '/')) ? (request",
adamc@198 1251 space,
adamc@198 1252 string "+=",
adamc@198 1253 space,
adamc@198 1254 string (Int.toString (size no_arg)),
adamc@198 1255 string ", NULL) : ((!strncmp(request, \"",
adamc@198 1256 string has_arg,
adamc@198 1257 string "\", ",
adamc@198 1258 string (Int.toString (size has_arg)),
adamc@198 1259 string ") && (request[",
adamc@198 1260 string (Int.toString (size has_arg)),
adamc@198 1261 string "] == 0 || request[",
adamc@198 1262 string (Int.toString (size has_arg)),
adamc@198 1263 string "] == '/')) ? (request",
adamc@198 1264 space,
adamc@198 1265 string "+=",
adamc@198 1266 space,
adamc@198 1267 string (Int.toString (size has_arg)),
adamc@200 1268 string ", (request[0] == '/' ? ++request : NULL), ",
adamc@200 1269 newline,
adamc@198 1270
adamc@198 1271 case #1 t of
adamc@198 1272 TDatatype _ => unurlify t
adamc@199 1273 | TFfi ("Basis", "string") => unurlify t
adamc@198 1274 | _ => box [string "({",
adamc@198 1275 newline,
adamc@198 1276 p_typ env t,
adamc@198 1277 space,
adamc@198 1278 string "*tmp",
adamc@198 1279 space,
adamc@198 1280 string "=",
adamc@198 1281 space,
adamc@198 1282 string "lw_malloc(ctx, sizeof(",
adamc@198 1283 p_typ env t,
adamc@198 1284 string "));",
adamc@198 1285 newline,
adamc@198 1286 string "*tmp",
adamc@198 1287 space,
adamc@198 1288 string "=",
adamc@198 1289 space,
adamc@198 1290 unurlify t,
adamc@198 1291 string ";",
adamc@198 1292 newline,
adamc@198 1293 string "tmp;",
adamc@198 1294 newline,
adamc@198 1295 string "})"],
adamc@198 1296 string ")",
adamc@198 1297 newline,
adamc@198 1298 string ":",
adamc@198 1299 space,
adamc@198 1300 string ("(lw_error(ctx, FATAL, \"Error unurlifying datatype " ^ x ^ "\"), NULL))))")]
adamc@198 1301 end
adamc@198 1302
adamc@188 1303 | TDatatype (Default, i, _) =>
adamc@166 1304 let
adamc@166 1305 val (x, xncs) = E.lookupDatatype env i
adamc@166 1306
adamc@166 1307 fun doEm xncs =
adamc@166 1308 case xncs of
adamc@167 1309 [] => string ("(lw_error(ctx, FATAL, \"Error unurlifying datatype " ^ x ^ "\"), NULL)")
adamc@167 1310 | (x', n, to) :: rest =>
adamc@167 1311 box [string "((!strncmp(request, \"",
adamc@167 1312 string x',
adamc@167 1313 string "\", ",
adamc@167 1314 string (Int.toString (size x')),
adamc@167 1315 string ") && (request[",
adamc@167 1316 string (Int.toString (size x')),
adamc@167 1317 string "] == 0 || request[",
adamc@167 1318 string (Int.toString (size x')),
adamc@167 1319 string "] == '/')) ? ({",
adamc@166 1320 newline,
adamc@167 1321 string "struct",
adamc@167 1322 space,
adamc@166 1323 string ("__lwd_" ^ x ^ "_" ^ Int.toString i),
adamc@166 1324 space,
adamc@181 1325 string "*tmp = lw_malloc(ctx, sizeof(struct __lwd_",
adamc@167 1326 string x,
adamc@167 1327 string "_",
adamc@167 1328 string (Int.toString i),
adamc@167 1329 string "));",
adamc@166 1330 newline,
adamc@181 1331 string "tmp->tag",
adamc@166 1332 space,
adamc@166 1333 string "=",
adamc@166 1334 space,
adamc@167 1335 string ("__lwc_" ^ x' ^ "_" ^ Int.toString n),
adamc@166 1336 string ";",
adamc@166 1337 newline,
adamc@166 1338 string "request",
adamc@166 1339 space,
adamc@166 1340 string "+=",
adamc@166 1341 space,
adamc@167 1342 string (Int.toString (size x')),
adamc@166 1343 string ";",
adamc@166 1344 newline,
adamc@200 1345 string "if (request[0] == '/') ++request;",
adamc@200 1346 newline,
adamc@166 1347 case to of
adamc@166 1348 NONE => box []
adamc@197 1349 | SOME t => box [string "tmp->data.lw_",
adamc@167 1350 string x',
adamc@166 1351 space,
adamc@166 1352 string "=",
adamc@166 1353 space,
adamc@166 1354 unurlify t,
adamc@166 1355 string ";",
adamc@166 1356 newline],
adamc@181 1357 string "tmp;",
adamc@166 1358 newline,
adamc@166 1359 string "})",
adamc@166 1360 space,
adamc@166 1361 string ":",
adamc@166 1362 space,
adamc@166 1363 doEm rest,
adamc@166 1364 string ")"]
adamc@166 1365 in
adamc@166 1366 doEm xncs
adamc@166 1367 end
adamc@166 1368
adamc@144 1369 | _ => (ErrorMsg.errorAt loc "Unable to choose a URL decoding function";
adamc@144 1370 space)
adamc@144 1371
adamc@144 1372
adamc@144 1373 fun p_page (ek, s, n, ts) =
adamc@144 1374 let
adamc@144 1375 val (ts, defInputs, inputsVar) =
adamc@144 1376 case ek of
adamc@144 1377 Core.Link => (ts, string "", string "")
adamc@144 1378 | Core.Action =>
adamc@280 1379 case List.nth (ts, length ts - 2) of
adamc@144 1380 (TRecord i, _) =>
adamc@144 1381 let
adamc@144 1382 val xts = E.lookupStruct env i
adamc@144 1383 in
adamc@280 1384 (List.take (ts, length ts - 2),
adamc@144 1385 box [box (map (fn (x, t) => box [p_typ env t,
adamc@144 1386 space,
adamc@144 1387 string "lw_input_",
adamc@144 1388 string x,
adamc@144 1389 string ";",
adamc@144 1390 newline]) xts),
adamc@144 1391 newline,
adamc@144 1392 box (map (fn (x, t) =>
adamc@144 1393 let
adamc@144 1394 val n = case SM.find (fnums, x) of
adamc@144 1395 NONE => raise Fail "CjrPrint: Can't find in fnums"
adamc@144 1396 | SOME n => n
adamc@190 1397
adamc@190 1398 val f = case t of
adamc@190 1399 (TFfi ("Basis", "bool"), _) => "optional_"
adamc@190 1400 | _ => ""
adamc@144 1401 in
adamc@190 1402 box [string "request = lw_get_",
adamc@190 1403 string f,
adamc@190 1404 string "input(ctx, ",
adamc@144 1405 string (Int.toString n),
adamc@144 1406 string ");",
adamc@144 1407 newline,
adamc@144 1408 string "if (request == NULL) {",
adamc@144 1409 newline,
adamc@144 1410 box [string "printf(\"Missing input ",
adamc@144 1411 string x,
adamc@144 1412 string "\\n\");",
adamc@144 1413 newline,
adamc@144 1414 string "exit(1);"],
adamc@144 1415 newline,
adamc@144 1416 string "}",
adamc@144 1417 newline,
adamc@144 1418 string "lw_input_",
adamc@144 1419 string x,
adamc@144 1420 space,
adamc@144 1421 string "=",
adamc@144 1422 space,
adamc@144 1423 unurlify t,
adamc@144 1424 string ";",
adamc@144 1425 newline]
adamc@144 1426 end) xts),
adamc@144 1427 string "struct __lws_",
adamc@144 1428 string (Int.toString i),
adamc@144 1429 space,
adamc@144 1430 string "lw_inputs",
adamc@144 1431 space,
adamc@144 1432 string "= {",
adamc@144 1433 newline,
adamc@144 1434 box (map (fn (x, _) => box [string "lw_input_",
adamc@144 1435 string x,
adamc@144 1436 string ",",
adamc@144 1437 newline]) xts),
adamc@144 1438 string "};",
adamc@144 1439 newline],
adamc@144 1440 box [string ",",
adamc@144 1441 space,
adamc@144 1442 string "lw_inputs"])
adamc@144 1443 end
adamc@144 1444
adamc@144 1445 | _ => raise Fail "CjrPrint: Last argument to an action isn't a record"
adamc@144 1446 in
adamc@144 1447 box [string "if (!strncmp(request, \"",
adamc@144 1448 string (String.toString s),
adamc@144 1449 string "\", ",
adamc@144 1450 string (Int.toString (size s)),
adamc@198 1451 string ") && (request[",
adamc@198 1452 string (Int.toString (size s)),
adamc@198 1453 string "] == 0 || request[",
adamc@198 1454 string (Int.toString (size s)),
adamc@198 1455 string "] == '/')) {",
adamc@144 1456 newline,
adamc@144 1457 string "request += ",
adamc@144 1458 string (Int.toString (size s)),
adamc@144 1459 string ";",
adamc@144 1460 newline,
adamc@144 1461 string "if (*request == '/') ++request;",
adamc@144 1462 newline,
adamc@144 1463 box [string "{",
adamc@144 1464 newline,
adamc@144 1465 box (ListUtil.mapi (fn (i, t) => box [p_typ env t,
adamc@144 1466 space,
adamc@144 1467 string "arg",
adamc@144 1468 string (Int.toString i),
adamc@144 1469 space,
adamc@144 1470 string "=",
adamc@144 1471 space,
adamc@144 1472 unurlify t,
adamc@144 1473 string ";",
adamc@144 1474 newline]) ts),
adamc@144 1475 defInputs,
adamc@144 1476 p_enamed env n,
adamc@144 1477 string "(",
adamc@144 1478 p_list_sep (box [string ",", space])
adamc@144 1479 (fn x => x)
adamc@272 1480 (string "ctx"
adamc@280 1481 :: ListUtil.mapi (fn (i, _) => string ("arg" ^ Int.toString i)) ts),
adamc@144 1482 inputsVar,
adamc@280 1483 string ", lw_unit_v);",
adamc@144 1484 newline,
adamc@144 1485 string "return;",
adamc@144 1486 newline,
adamc@144 1487 string "}",
adamc@144 1488 newline,
adamc@144 1489 string "}"]
adamc@144 1490 ]
adamc@144 1491 end
adamc@144 1492
adamc@144 1493 val pds' = map p_page ps
adamc@275 1494
adamc@275 1495 val tables = List.mapPartial (fn (DTable (s, xts), _) => SOME (s, xts)
adamc@275 1496 | _ => NONE) ds
adamc@275 1497
adamc@275 1498 val validate =
adamc@275 1499 box [string "static void lw_db_validate(lw_context ctx) {",
adamc@275 1500 newline,
adamc@275 1501 string "PGconn *conn = lw_get_db(ctx);",
adamc@275 1502 newline,
adamc@275 1503 string "PGresult *res;",
adamc@275 1504 newline,
adamc@275 1505 newline,
adamc@275 1506 p_list_sep newline
adamc@275 1507 (fn (s, xts) =>
adamc@275 1508 let
adamc@275 1509 val q = "SELECT COUNT(*) FROM pg_class WHERE relname = '"
adamc@275 1510 ^ s ^ "'"
adamc@275 1511
adamc@275 1512 val q' = String.concat ["SELECT COUNT(*) FROM pg_attribute WHERE attrelid = (SELECT oid FROM pg_class WHERE relname = '",
adamc@275 1513 s,
adamc@275 1514 "') AND (",
adamc@275 1515 String.concatWith " OR "
adamc@275 1516 (map (fn (x, t) =>
adamc@275 1517 String.concat ["(attname = 'lw_",
adamc@275 1518 CharVector.map
adamc@275 1519 Char.toLower x,
adamc@275 1520 "' AND atttypid = (SELECT oid FROM pg_type",
adamc@275 1521 " WHERE typname = '",
adamc@275 1522 p_sqltype' env t,
adamc@275 1523 "'))"]) xts),
adamc@275 1524 ")"]
adamc@275 1525
adamc@275 1526 val q'' = String.concat ["SELECT COUNT(*) FROM pg_attribute WHERE attrelid = (SELECT oid FROM pg_class WHERE relname = '",
adamc@275 1527 s,
adamc@275 1528 "') AND attnum >= 0"]
adamc@275 1529 in
adamc@275 1530 box [string "res = PQexec(conn, \"",
adamc@275 1531 string q,
adamc@275 1532 string "\");",
adamc@275 1533 newline,
adamc@275 1534 newline,
adamc@275 1535 string "if (res == NULL) {",
adamc@275 1536 newline,
adamc@275 1537 box [string "PQfinish(conn);",
adamc@275 1538 newline,
adamc@275 1539 string "lw_error(ctx, FATAL, \"Out of memory allocating query result.\");",
adamc@275 1540 newline],
adamc@275 1541 string "}",
adamc@275 1542 newline,
adamc@275 1543 newline,
adamc@275 1544 string "if (PQresultStatus(res) != PGRES_TUPLES_OK) {",
adamc@275 1545 newline,
adamc@275 1546 box [string "char msg[1024];",
adamc@275 1547 newline,
adamc@275 1548 string "strncpy(msg, PQerrorMessage(conn), 1024);",
adamc@275 1549 newline,
adamc@275 1550 string "msg[1023] = 0;",
adamc@275 1551 newline,
adamc@275 1552 string "PQclear(res);",
adamc@275 1553 newline,
adamc@275 1554 string "PQfinish(conn);",
adamc@275 1555 newline,
adamc@275 1556 string "lw_error(ctx, FATAL, \"Query failed:\\n",
adamc@275 1557 string q,
adamc@275 1558 string "\\n%s\", msg);",
adamc@275 1559 newline],
adamc@275 1560 string "}",
adamc@275 1561 newline,
adamc@275 1562 newline,
adamc@275 1563 string "if (strcmp(PQgetvalue(res, 0, 0), \"1\")) {",
adamc@275 1564 newline,
adamc@275 1565 box [string "PQclear(res);",
adamc@275 1566 newline,
adamc@275 1567 string "PQfinish(conn);",
adamc@275 1568 newline,
adamc@275 1569 string "lw_error(ctx, FATAL, \"Table '",
adamc@275 1570 string s,
adamc@275 1571 string "' does not exist.\");",
adamc@275 1572 newline],
adamc@275 1573 string "}",
adamc@275 1574 newline,
adamc@275 1575 newline,
adamc@275 1576 string "PQclear(res);",
adamc@275 1577 newline,
adamc@275 1578
adamc@275 1579 string "res = PQexec(conn, \"",
adamc@275 1580 string q',
adamc@275 1581 string "\");",
adamc@275 1582 newline,
adamc@275 1583 newline,
adamc@275 1584 string "if (res == NULL) {",
adamc@275 1585 newline,
adamc@275 1586 box [string "PQfinish(conn);",
adamc@275 1587 newline,
adamc@275 1588 string "lw_error(ctx, FATAL, \"Out of memory allocating query result.\");",
adamc@275 1589 newline],
adamc@275 1590 string "}",
adamc@275 1591 newline,
adamc@275 1592 newline,
adamc@275 1593 string "if (PQresultStatus(res) != PGRES_TUPLES_OK) {",
adamc@275 1594 newline,
adamc@275 1595 box [string "char msg[1024];",
adamc@275 1596 newline,
adamc@275 1597 string "strncpy(msg, PQerrorMessage(conn), 1024);",
adamc@275 1598 newline,
adamc@275 1599 string "msg[1023] = 0;",
adamc@275 1600 newline,
adamc@275 1601 string "PQclear(res);",
adamc@275 1602 newline,
adamc@275 1603 string "PQfinish(conn);",
adamc@275 1604 newline,
adamc@275 1605 string "lw_error(ctx, FATAL, \"Query failed:\\n",
adamc@275 1606 string q',
adamc@275 1607 string "\\n%s\", msg);",
adamc@275 1608 newline],
adamc@275 1609 string "}",
adamc@275 1610 newline,
adamc@275 1611 newline,
adamc@275 1612 string "if (strcmp(PQgetvalue(res, 0, 0), \"",
adamc@275 1613 string (Int.toString (length xts)),
adamc@275 1614 string "\")) {",
adamc@275 1615 newline,
adamc@275 1616 box [string "PQclear(res);",
adamc@275 1617 newline,
adamc@275 1618 string "PQfinish(conn);",
adamc@275 1619 newline,
adamc@275 1620 string "lw_error(ctx, FATAL, \"Table '",
adamc@275 1621 string s,
adamc@275 1622 string "' has the wrong column types.\");",
adamc@275 1623 newline],
adamc@275 1624 string "}",
adamc@275 1625 newline,
adamc@275 1626 newline,
adamc@275 1627 string "PQclear(res);",
adamc@275 1628 newline,
adamc@275 1629 newline,
adamc@275 1630
adamc@275 1631 string "res = PQexec(conn, \"",
adamc@275 1632 string q'',
adamc@275 1633 string "\");",
adamc@275 1634 newline,
adamc@275 1635 newline,
adamc@275 1636 string "if (res == NULL) {",
adamc@275 1637 newline,
adamc@275 1638 box [string "PQfinish(conn);",
adamc@275 1639 newline,
adamc@275 1640 string "lw_error(ctx, FATAL, \"Out of memory allocating query result.\");",
adamc@275 1641 newline],
adamc@275 1642 string "}",
adamc@275 1643 newline,
adamc@275 1644 newline,
adamc@275 1645 string "if (PQresultStatus(res) != PGRES_TUPLES_OK) {",
adamc@275 1646 newline,
adamc@275 1647 box [string "char msg[1024];",
adamc@275 1648 newline,
adamc@275 1649 string "strncpy(msg, PQerrorMessage(conn), 1024);",
adamc@275 1650 newline,
adamc@275 1651 string "msg[1023] = 0;",
adamc@275 1652 newline,
adamc@275 1653 string "PQclear(res);",
adamc@275 1654 newline,
adamc@275 1655 string "PQfinish(conn);",
adamc@275 1656 newline,
adamc@275 1657 string "lw_error(ctx, FATAL, \"Query failed:\\n",
adamc@275 1658 string q'',
adamc@275 1659 string "\\n%s\", msg);",
adamc@275 1660 newline],
adamc@275 1661 string "}",
adamc@275 1662 newline,
adamc@275 1663 newline,
adamc@275 1664 string "if (strcmp(PQgetvalue(res, 0, 0), \"",
adamc@275 1665 string (Int.toString (length xts)),
adamc@275 1666 string "\")) {",
adamc@275 1667 newline,
adamc@275 1668 box [string "PQclear(res);",
adamc@275 1669 newline,
adamc@275 1670 string "PQfinish(conn);",
adamc@275 1671 newline,
adamc@275 1672 string "lw_error(ctx, FATAL, \"Table '",
adamc@275 1673 string s,
adamc@275 1674 string "' has extra columns.\");",
adamc@275 1675 newline],
adamc@275 1676 string "}",
adamc@275 1677 newline,
adamc@275 1678 newline,
adamc@275 1679 string "PQclear(res);",
adamc@275 1680 newline]
adamc@275 1681 end) tables,
adamc@275 1682 string "}"]
adamc@29 1683 in
adamc@144 1684 box [string "#include <stdio.h>",
adamc@144 1685 newline,
adamc@144 1686 string "#include <stdlib.h>",
adamc@144 1687 newline,
adamc@272 1688 string "#include <string.h>",
adamc@272 1689 newline,
adamc@272 1690 string "#include <postgresql/libpq-fe.h>",
adamc@272 1691 newline,
adamc@144 1692 newline,
adamc@244 1693 string "#include \"urweb.h\"",
adamc@101 1694 newline,
adamc@101 1695 newline,
adamc@101 1696 p_list_sep newline (fn x => x) pds,
adamc@101 1697 newline,
adamc@144 1698 string "int lw_inputs_len = ",
adamc@144 1699 string (Int.toString (SM.foldl Int.max 0 fnums + 1)),
adamc@144 1700 string ";",
adamc@144 1701 newline,
adamc@144 1702 newline,
adamc@144 1703 string "int lw_input_num(char *name) {",
adamc@144 1704 newline,
adamc@144 1705 makeSwitch (fnums, 0),
adamc@144 1706 string "}",
adamc@144 1707 newline,
adamc@144 1708 newline,
adamc@117 1709 string "void lw_handle(lw_context ctx, char *request) {",
adamc@101 1710 newline,
adamc@101 1711 p_list_sep newline (fn x => x) pds',
adamc@101 1712 newline,
adamc@101 1713 string "}",
adamc@275 1714 newline,
adamc@275 1715 newline,
adamc@275 1716 validate,
adamc@101 1717 newline]
adamc@29 1718 end
adamc@29 1719
adamc@274 1720 fun p_sql env (ds, _) =
adamc@274 1721 let
adamc@274 1722 val (pps, _) = ListUtil.foldlMap
adamc@274 1723 (fn (dAll as (d, _), env) =>
adamc@274 1724 let
adamc@274 1725 val pp = case d of
adamc@274 1726 DTable (s, xts) =>
adamc@274 1727 box [string "CREATE TABLE ",
adamc@274 1728 string s,
adamc@274 1729 string "(",
adamc@274 1730 p_list (fn (x, t) =>
adamc@274 1731 box [string "lw_",
adamc@275 1732 string (CharVector.map Char.toLower x),
adamc@274 1733 space,
adamc@274 1734 p_sqltype env t,
adamc@274 1735 space,
adamc@274 1736 string "NOT",
adamc@274 1737 space,
adamc@274 1738 string "NULL"]) xts,
adamc@274 1739 string ");",
adamc@274 1740 newline,
adamc@274 1741 newline]
adamc@274 1742 | _ => box []
adamc@274 1743 in
adamc@274 1744 (pp, E.declBinds env dAll)
adamc@274 1745 end)
adamc@274 1746 env ds
adamc@274 1747 in
adamc@274 1748 box pps
adamc@274 1749 end
adamc@274 1750
adamc@29 1751 end