Mercurial > urweb

annotate src/cjr_print.sml @ 278:137744c5b1ae

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
First query example working
author Adam Chlipala <adamc@hcoop.net>
date Tue, 02 Sep 2008 16:10:07 -0400
parents 286f734db702
children fdd7a698be01
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@182 336 fun p_exp' par env (e, loc) =
adamc@29 337 case e of
adamc@276 338 EPrim p => Prim.p_t_GCC p
adamc@29 339 | ERel n => p_rel env n
adamc@109 340 | ENamed n => p_enamed env n
adamc@188 341 | ECon (Enum, pc, _) => p_patCon env pc
adamc@198 342 | ECon (Option, pc, NONE) => string "NULL"
adamc@198 343 | ECon (Option, pc, SOME e) =>
adamc@198 344 let
adamc@198 345 val to = case pc of
adamc@198 346 PConVar n => #2 (E.lookupConstructor env n)
adamc@198 347 | PConFfi {arg, ...} => arg
adamc@198 348
adamc@198 349 val t = case to of
adamc@198 350 NONE => raise Fail "CjrPrint: ECon argument status mismatch"
adamc@198 351 | SOME t => t
adamc@198 352 in
adamc@198 353 case #1 t of
adamc@198 354 TDatatype _ => p_exp' par env e
adamc@199 355 | TFfi ("Basis", "string") => p_exp' par env e
adamc@198 356 | _ => box [string "({",
adamc@198 357 newline,
adamc@198 358 p_typ env t,
adamc@198 359 space,
adamc@198 360 string "*tmp",
adamc@198 361 space,
adamc@198 362 string "=",
adamc@198 363 space,
adamc@198 364 string "lw_malloc(ctx, sizeof(",
adamc@198 365 p_typ env t,
adamc@198 366 string "));",
adamc@198 367 newline,
adamc@198 368 string "*tmp",
adamc@198 369 space,
adamc@198 370 string "=",
adamc@198 371 p_exp' par env e,
adamc@198 372 string ";",
adamc@198 373 newline,
adamc@198 374 string "tmp;",
adamc@198 375 newline,
adamc@198 376 string "})"]
adamc@198 377 end
adamc@188 378 | ECon (Default, pc, eo) =>
adamc@181 379 let
adamc@196 380 val (xd, xc, xn) = patConInfo env pc
adamc@181 381 in
adamc@182 382 box [string "({",
adamc@181 383 newline,
adamc@181 384 string "struct",
adamc@181 385 space,
adamc@185 386 string xd,
adamc@181 387 space,
adamc@181 388 string "*tmp",
adamc@181 389 space,
adamc@181 390 string "=",
adamc@181 391 space,
adamc@185 392 string "lw_malloc(ctx, sizeof(struct ",
adamc@185 393 string xd,
adamc@181 394 string "));",
adamc@181 395 newline,
adamc@181 396 string "tmp->tag",
adamc@181 397 space,
adamc@181 398 string "=",
adamc@181 399 space,
adamc@185 400 string xc,
adamc@181 401 string ";",
adamc@181 402 newline,
adamc@181 403 case eo of
adamc@181 404 NONE => box []
adamc@185 405 | SOME e => box [string "tmp->data.",
adamc@196 406 string xn,
adamc@181 407 space,
adamc@181 408 string "=",
adamc@181 409 space,
adamc@181 410 p_exp env e,
adamc@181 411 string ";",
adamc@181 412 newline],
adamc@181 413 string "tmp;",
adamc@181 414 newline,
adamc@181 415 string "})"]
adamc@181 416 end
adamc@109 417
adamc@53 418 | EFfi (m, x) => box [string "lw_", string m, string "_", string x]
adamc@53 419 | EFfiApp (m, x, es) => box [string "lw_",
adamc@53 420 string m,
adamc@53 421 string "_",
adamc@53 422 string x,
adamc@117 423 string "(ctx, ",
adamc@53 424 p_list (p_exp env) es,
adamc@53 425 string ")"]
adamc@129 426 | EApp (e1, e2) =>
adamc@129 427 let
adamc@129 428 fun unravel (f, acc) =
adamc@129 429 case #1 f of
adamc@129 430 EApp (f', arg) => unravel (f', arg :: acc)
adamc@129 431 | _ => (f, acc)
adamc@129 432
adamc@129 433 val (f, args) = unravel (e1, [e2])
adamc@129 434 in
adamc@129 435 parenIf par (box [p_exp' true env e1,
adamc@129 436 string "(ctx,",
adamc@129 437 space,
adamc@129 438 p_list_sep (box [string ",", space]) (p_exp env) args,
adamc@129 439 string ")"])
adamc@129 440 end
adamc@29 441
adamc@29 442 | ERecord (i, xes) => box [string "({",
adamc@29 443 space,
adamc@29 444 string "struct",
adamc@29 445 space,
adamc@29 446 string ("__lws_" ^ Int.toString i),
adamc@29 447 space,
adamc@181 448 string "tmp",
adamc@29 449 space,
adamc@29 450 string "=",
adamc@29 451 space,
adamc@29 452 string "{",
adamc@29 453 p_list (fn (_, e) =>
adamc@29 454 p_exp env e) xes,
adamc@29 455 string "};",
adamc@29 456 space,
adamc@181 457 string "tmp;",
adamc@29 458 space,
adamc@29 459 string "})" ]
adamc@29 460 | EField (e, x) =>
adamc@29 461 box [p_exp' true env e,
adamc@182 462 string ".__lwf_",
adamc@29 463 string x]
adamc@29 464
adamc@182 465 | ECase (e, pes, {disc, result}) =>
adamc@182 466 let
adamc@182 467 val final = newGoto ()
adamc@182 468
adamc@182 469 val body = foldl (fn ((p, e), body) =>
adamc@182 470 let
adamc@182 471 val exit = newGoto ()
adamc@182 472 val (pr, _) = p_pat_preamble env p
adamc@182 473 val (p, env) = p_pat (env,
adamc@182 474 box [string "goto",
adamc@182 475 space,
adamc@182 476 exit,
adamc@182 477 string ";"],
adamc@182 478 0) p
adamc@182 479 in
adamc@182 480 box [body,
adamc@182 481 box [string "{",
adamc@182 482 newline,
adamc@182 483 pr,
adamc@182 484 newline,
adamc@182 485 p,
adamc@182 486 newline,
adamc@182 487 string "result",
adamc@182 488 space,
adamc@182 489 string "=",
adamc@182 490 space,
adamc@182 491 p_exp env e,
adamc@182 492 string ";",
adamc@182 493 newline,
adamc@182 494 string "goto",
adamc@182 495 space,
adamc@182 496 final,
adamc@182 497 string ";",
adamc@182 498 newline,
adamc@182 499 string "}"],
adamc@182 500 newline,
adamc@182 501 exit,
adamc@182 502 string ":",
adamc@182 503 newline]
adamc@182 504 end) (box []) pes
adamc@182 505 in
adamc@182 506 box [string "({",
adamc@182 507 newline,
adamc@182 508 p_typ env disc,
adamc@182 509 space,
adamc@182 510 string "disc0",
adamc@182 511 space,
adamc@182 512 string "=",
adamc@182 513 space,
adamc@182 514 p_exp env e,
adamc@182 515 string ";",
adamc@182 516 newline,
adamc@182 517 p_typ env result,
adamc@182 518 space,
adamc@182 519 string "result;",
adamc@182 520 newline,
adamc@182 521 body,
adamc@182 522 string "lw_error(ctx, FATAL, \"",
adamc@182 523 string (ErrorMsg.spanToString loc),
adamc@182 524 string ": pattern match failure\");",
adamc@182 525 newline,
adamc@182 526 final,
adamc@182 527 string ":",
adamc@182 528 space,
adamc@182 529 string "result;",
adamc@182 530 newline,
adamc@182 531 string "})"]
adamc@182 532 end
adamc@181 533
adamc@117 534 | EWrite e => box [string "(lw_write(ctx, ",
adamc@102 535 p_exp env e,
adamc@102 536 string "), lw_unit_v)"]
adamc@102 537
adamc@106 538 | ESeq (e1, e2) => box [string "(",
adamc@106 539 p_exp env e1,
adamc@106 540 string ",",
adamc@106 541 space,
adamc@106 542 p_exp env e2,
adamc@106 543 string ")"]
adamc@269 544 | ELet (x, t, e1, e2) => box [string "({",
adamc@269 545 newline,
adamc@269 546 p_typ env t,
adamc@269 547 space,
adamc@272 548 string "__lwr_",
adamc@272 549 string x,
adamc@272 550 string "_",
adamc@272 551 string (Int.toString (E.countERels env)),
adamc@269 552 space,
adamc@269 553 string "=",
adamc@269 554 space,
adamc@269 555 p_exp env e1,
adamc@269 556 string ";",
adamc@269 557 newline,
adamc@269 558 p_exp (E.pushERel env x t) e2,
adamc@269 559 string ";",
adamc@269 560 newline,
adamc@269 561 string "})"]
adamc@269 562
adamc@269 563 | EQuery {exps, tables, rnum, state, query, body, initial} =>
adamc@278 564 let
adamc@278 565 val exps = map (fn (x, t) => ("__lwf_" ^ x, t)) exps
adamc@278 566 val tables = ListUtil.mapConcat (fn (x, xts) =>
adamc@278 567 map (fn (x', t) => ("__lwf_" ^ x ^ ".__lwf_" ^ x', t)) xts)
adamc@278 568 tables
adamc@278 569
adamc@278 570 val outputs = exps @ tables
adamc@278 571 in
adamc@278 572 box [string "({",
adamc@278 573 newline,
adamc@278 574 string "PGconn *conn = lw_get_db(ctx);",
adamc@278 575 newline,
adamc@278 576 string "char *query = ",
adamc@278 577 p_exp env query,
adamc@278 578 string ";",
adamc@278 579 newline,
adamc@278 580 string "int n, i;",
adamc@278 581 newline,
adamc@278 582 p_typ env state,
adamc@278 583 space,
adamc@278 584 string "acc",
adamc@278 585 space,
adamc@278 586 string "=",
adamc@278 587 space,
adamc@278 588 p_exp env initial,
adamc@278 589 string ";",
adamc@278 590 newline,
adamc@278 591 string "PGresult *res = PQexecParams(conn, query, 0, NULL, NULL, NULL, NULL, 1);",
adamc@278 592 newline,
adamc@278 593 newline,
adamc@277 594
adamc@278 595 string "if (res == NULL) lw_error(ctx, FATAL, \"Out of memory allocating query result.\");",
adamc@278 596 newline,
adamc@278 597 newline,
adamc@277 598
adamc@278 599 string "if (PQresultStatus(res) != PGRES_TUPLES_OK) {",
adamc@278 600 newline,
adamc@278 601 box [string "PQclear(res);",
adamc@278 602 newline,
adamc@278 603 string "lw_error(ctx, FATAL, \"",
adamc@278 604 string (ErrorMsg.spanToString loc),
adamc@278 605 string ": Query failed:\\n%s\\n%s\", query, PQerrorMessage(conn));",
adamc@278 606 newline],
adamc@278 607 string "}",
adamc@278 608 newline,
adamc@278 609 newline,
adamc@277 610
adamc@278 611 string "n = PQntuples(res);",
adamc@278 612 newline,
adamc@278 613 string "for (i = 0; i < n; ++i) {",
adamc@278 614 newline,
adamc@278 615 box [string "struct",
adamc@278 616 space,
adamc@278 617 string "__lws_",
adamc@278 618 string (Int.toString rnum),
adamc@278 619 space,
adamc@278 620 string "__lwr_r_",
adamc@278 621 string (Int.toString (E.countERels env)),
adamc@278 622 string ";",
adamc@278 623 newline,
adamc@278 624 p_typ env state,
adamc@278 625 space,
adamc@278 626 string "__lwr_acc_",
adamc@278 627 string (Int.toString (E.countERels env + 1)),
adamc@278 628 space,
adamc@278 629 string "=",
adamc@278 630 space,
adamc@278 631 string "acc;",
adamc@278 632 newline,
adamc@278 633 newline,
adamc@278 634
adamc@278 635 p_list_sepi (box []) (fn i =>
adamc@278 636 fn (proj, t) =>
adamc@278 637 box [string "__lwr_r_",
adamc@278 638 string (Int.toString (E.countERels env)),
adamc@278 639 string ".",
adamc@278 640 string proj,
adamc@278 641 space,
adamc@278 642 string "=",
adamc@278 643 space,
adamc@278 644 p_unsql env t
adamc@278 645 (box [string "PQgetvalue(res, i, ",
adamc@278 646 string (Int.toString i),
adamc@278 647 string ")"]),
adamc@278 648 string ";",
adamc@278 649 newline]) outputs,
adamc@278 650
adamc@278 651 newline,
adamc@278 652 newline,
adamc@278 653
adamc@278 654 string "acc",
adamc@278 655 space,
adamc@278 656 string "=",
adamc@278 657 space,
adamc@278 658 p_exp (E.pushERel
adamc@278 659 (E.pushERel env "r" (TRecord rnum, loc))
adamc@278 660 "acc" state)
adamc@278 661 body,
adamc@278 662 string ";",
adamc@278 663 newline],
adamc@278 664 string "}",
adamc@278 665 newline,
adamc@278 666 newline,
adamc@278 667 string "PQclear(res);",
adamc@278 668 newline,
adamc@278 669 string "acc;",
adamc@278 670 newline,
adamc@278 671 string "})"]
adamc@278 672 end
adamc@106 673
adamc@29 674 and p_exp env = p_exp' false env
adamc@29 675
adamc@129 676 fun p_fun env (fx, n, args, ran, e) =
adamc@129 677 let
adamc@129 678 val nargs = length args
adamc@129 679 val env' = foldl (fn ((x, dom), env) => E.pushERel env x dom) env args
adamc@129 680 in
adamc@129 681 box [string "static",
adamc@129 682 space,
adamc@129 683 p_typ env ran,
adamc@129 684 space,
adamc@129 685 string ("__lwn_" ^ fx ^ "_" ^ Int.toString n),
adamc@129 686 string "(",
adamc@129 687 p_list_sep (box [string ",", space]) (fn x => x)
adamc@129 688 (string "lw_context ctx" :: ListUtil.mapi (fn (i, (_, dom)) =>
adamc@129 689 box [p_typ env dom,
adamc@129 690 space,
adamc@129 691 p_rel env' (nargs - i - 1)]) args),
adamc@129 692 string ")",
adamc@129 693 space,
adamc@129 694 string "{",
adamc@129 695 newline,
adamc@129 696 box[string "return(",
adamc@129 697 p_exp env' e,
adamc@129 698 string ");"],
adamc@129 699 newline,
adamc@129 700 string "}"]
adamc@129 701 end
adamc@129 702
adamc@129 703 fun p_decl env (dAll as (d, _) : decl) =
adamc@29 704 case d of
adamc@29 705 DStruct (n, xts) =>
adamc@196 706 let
adamc@196 707 val env = E.declBinds env dAll
adamc@196 708 in
adamc@196 709 box [string "struct",
adamc@196 710 space,
adamc@196 711 string ("__lws_" ^ Int.toString n),
adamc@196 712 space,
adamc@196 713 string "{",
adamc@196 714 newline,
adamc@196 715 p_list_sep (box []) (fn (x, t) => box [p_typ env t,
adamc@196 716 space,
adamc@196 717 string "__lwf_",
adamc@196 718 string x,
adamc@196 719 string ";",
adamc@196 720 newline]) xts,
adamc@196 721 string "};"]
adamc@196 722 end
adamc@188 723 | DDatatype (Enum, x, n, xncs) =>
adamc@188 724 box [string "enum",
adamc@188 725 space,
adamc@188 726 string ("__lwe_" ^ x ^ "_" ^ Int.toString n),
adamc@188 727 space,
adamc@188 728 string "{",
adamc@188 729 space,
adamc@188 730 p_list_sep (box [string ",", space]) (fn (x, n, _) => string ("__lwc_" ^ x ^ "_" ^ Int.toString n)) xncs,
adamc@188 731 space,
adamc@188 732 string "};"]
adamc@198 733 | DDatatype (Option, _, _, _) => box []
adamc@188 734 | DDatatype (Default, x, n, xncs) =>
adamc@165 735 let
adamc@165 736 val xncsArgs = List.mapPartial (fn (x, n, NONE) => NONE
adamc@165 737 | (x, n, SOME t) => SOME (x, n, t)) xncs
adamc@165 738 in
adamc@165 739 box [string "enum",
adamc@165 740 space,
adamc@165 741 string ("__lwe_" ^ x ^ "_" ^ Int.toString n),
adamc@165 742 space,
adamc@165 743 string "{",
adamc@165 744 space,
adamc@165 745 p_list_sep (box [string ",", space]) (fn (x, n, _) => string ("__lwc_" ^ x ^ "_" ^ Int.toString n)) xncs,
adamc@165 746 space,
adamc@165 747 string "};",
adamc@165 748 newline,
adamc@165 749 newline,
adamc@165 750 string "struct",
adamc@165 751 space,
adamc@167 752 string ("__lwd_" ^ x ^ "_" ^ Int.toString n),
adamc@165 753 space,
adamc@165 754 string "{",
adamc@165 755 newline,
adamc@165 756 string "enum",
adamc@165 757 space,
adamc@165 758 string ("__lwe_" ^ x ^ "_" ^ Int.toString n),
adamc@165 759 space,
adamc@165 760 string "tag;",
adamc@165 761 newline,
adamc@165 762 box (case xncsArgs of
adamc@165 763 [] => []
adamc@165 764 | _ => [string "union",
adamc@165 765 space,
adamc@165 766 string "{",
adamc@165 767 newline,
adamc@165 768 p_list_sep newline (fn (x, n, t) => box [p_typ env t,
adamc@165 769 space,
adamc@196 770 string ("lw_" ^ x),
adamc@165 771 string ";"]) xncsArgs,
adamc@165 772 newline,
adamc@165 773 string "}",
adamc@165 774 space,
adamc@165 775 string "data;",
adamc@165 776 newline]),
adamc@165 777 string "};"]
adamc@188 778 end
adamc@29 779
adamc@196 780 | DDatatypeForward _ => box []
adamc@196 781
adamc@29 782 | DVal (x, n, t, e) =>
adamc@29 783 box [p_typ env t,
adamc@29 784 space,
adamc@29 785 string ("__lwn_" ^ x ^ "_" ^ Int.toString n),
adamc@29 786 space,
adamc@29 787 string "=",
adamc@29 788 space,
adamc@29 789 p_exp env e,
adamc@29 790 string ";"]
adamc@129 791 | DFun vi => p_fun env vi
adamc@129 792 | DFunRec vis =>
adamc@29 793 let
adamc@129 794 val env = E.declBinds env dAll
adamc@29 795 in
adamc@129 796 box [p_list_sep newline (fn (fx, n, args, ran, _) =>
adamc@129 797 box [string "static",
adamc@129 798 space,
adamc@129 799 p_typ env ran,
adamc@129 800 space,
adamc@129 801 string ("__lwn_" ^ fx ^ "_" ^ Int.toString n),
adamc@129 802 string "(lw_context,",
adamc@129 803 space,
adamc@129 804 p_list_sep (box [string ",", space])
adamc@129 805 (fn (_, dom) => p_typ env dom) args,
adamc@129 806 string ");"]) vis,
adamc@29 807 newline,
adamc@129 808 p_list_sep newline (p_fun env) vis,
adamc@129 809 newline]
adamc@29 810 end
adamc@273 811 | DTable (x, _) => box [string "/* SQL table ",
adamc@273 812 string x,
adamc@273 813 string " */",
adamc@273 814 newline]
adamc@275 815 | DDatabase s => box [string "static void lw_db_validate(lw_context);",
adamc@272 816 newline,
adamc@275 817 newline,
adamc@275 818 string "void lw_db_init(lw_context ctx) {",
adamc@273 819 newline,
adamc@272 820 string "PGconn *conn = PQconnectdb(\"",
adamc@272 821 string (String.toString s),
adamc@272 822 string "\");",
adamc@272 823 newline,
adamc@272 824 string "if (conn == NULL) lw_error(ctx, BOUNDED_RETRY, ",
adamc@272 825 string "\"libpq can't allocate a connection.\");",
adamc@272 826 newline,
adamc@272 827 string "if (PQstatus(conn) != CONNECTION_OK) {",
adamc@272 828 newline,
adamc@272 829 box [string "char msg[1024];",
adamc@272 830 newline,
adamc@272 831 string "strncpy(msg, PQerrorMessage(conn), 1024);",
adamc@272 832 newline,
adamc@272 833 string "msg[1023] = 0;",
adamc@272 834 newline,
adamc@272 835 string "PQfinish(conn);",
adamc@272 836 newline,
adamc@272 837 string "lw_error(ctx, BOUNDED_RETRY, ",
adamc@272 838 string "\"Connection to Postgres server failed: %s\", msg);"],
adamc@272 839 newline,
adamc@272 840 string "}",
adamc@272 841 newline,
adamc@272 842 string "lw_set_db(ctx, conn);",
adamc@272 843 newline,
adamc@275 844 string "lw_db_validate(ctx);",
adamc@275 845 newline,
adamc@272 846 string "}",
adamc@272 847 newline,
adamc@272 848 newline,
adamc@272 849 string "void lw_db_close(lw_context ctx) {",
adamc@272 850 newline,
adamc@272 851 string "PQfinish(lw_get_db(ctx));",
adamc@272 852 newline,
adamc@272 853 string "}",
adamc@272 854 newline]
adamc@29 855
adamc@144 856 datatype 'a search =
adamc@144 857 Found of 'a
adamc@144 858 | NotFound
adamc@144 859 | Error
adamc@120 860
adamc@275 861 fun p_sqltype' env (tAll as (t, loc)) =
adamc@275 862 case t of
adamc@275 863 TFfi ("Basis", "int") => "int8"
adamc@275 864 | TFfi ("Basis", "float") => "float8"
adamc@275 865 | TFfi ("Basis", "string") => "text"
adamc@275 866 | TFfi ("Basis", "bool") => "bool"
adamc@275 867 | _ => (ErrorMsg.errorAt loc "Don't know SQL equivalent of type";
adamc@275 868 Print.eprefaces' [("Type", p_typ env tAll)];
adamc@275 869 "ERROR")
adamc@275 870
adamc@275 871 fun p_sqltype env t = string (p_sqltype' env t)
adamc@101 872
adamc@101 873 fun p_file env (ds, ps) =
adamc@29 874 let
adamc@101 875 val (pds, env) = ListUtil.foldlMap (fn (d, env) =>
adamc@31 876 (p_decl env d,
adamc@31 877 E.declBinds env d))
adamc@101 878 env ds
adamc@144 879
adamc@144 880 val fields = foldl (fn ((ek, _, _, ts), fields) =>
adamc@144 881 case ek of
adamc@144 882 Core.Link => fields
adamc@144 883 | Core.Action =>
adamc@144 884 case List.last ts of
adamc@144 885 (TRecord i, _) =>
adamc@144 886 let
adamc@144 887 val xts = E.lookupStruct env i
adamc@144 888 val xtsSet = SS.addList (SS.empty, map #1 xts)
adamc@144 889 in
adamc@144 890 foldl (fn ((x, _), fields) =>
adamc@144 891 let
adamc@144 892 val xtsSet' = Option.getOpt (SM.find (fields, x), SS.empty)
adamc@144 893 in
adamc@144 894 SM.insert (fields, x, SS.union (SS.delete (xtsSet, x),
adamc@144 895 xtsSet'))
adamc@144 896 end) fields xts
adamc@144 897 end
adamc@144 898 | _ => raise Fail "CjrPrint: Last argument of action isn't record")
adamc@144 899 SM.empty ps
adamc@144 900
adamc@144 901 val fnums = SM.foldli (fn (x, xs, fnums) =>
adamc@144 902 let
adamc@144 903 val unusable = SS.foldl (fn (x', unusable) =>
adamc@144 904 case SM.find (fnums, x') of
adamc@144 905 NONE => unusable
adamc@144 906 | SOME n => IS.add (unusable, n))
adamc@144 907 IS.empty xs
adamc@144 908
adamc@144 909 fun findAvailable n =
adamc@144 910 if IS.member (unusable, n) then
adamc@144 911 findAvailable (n + 1)
adamc@144 912 else
adamc@144 913 n
adamc@144 914 in
adamc@144 915 SM.insert (fnums, x, findAvailable 0)
adamc@144 916 end)
adamc@144 917 SM.empty fields
adamc@144 918
adamc@144 919 fun makeSwitch (fnums, i) =
adamc@144 920 case SM.foldl (fn (n, NotFound) => Found n
adamc@144 921 | (n, Error) => Error
adamc@144 922 | (n, Found n') => if n = n' then
adamc@144 923 Found n'
adamc@144 924 else
adamc@144 925 Error) NotFound fnums of
adamc@144 926 NotFound => box [string "return",
adamc@144 927 space,
adamc@144 928 string "-1;"]
adamc@144 929 | Found n => box [string "return",
adamc@144 930 space,
adamc@144 931 string (Int.toString n),
adamc@144 932 string ";"]
adamc@144 933 | Error =>
adamc@144 934 let
adamc@144 935 val cmap = SM.foldli (fn (x, n, cmap) =>
adamc@144 936 let
adamc@144 937 val ch = if i < size x then
adamc@144 938 String.sub (x, i)
adamc@144 939 else
adamc@144 940 chr 0
adamc@144 941
adamc@144 942 val fnums = case CM.find (cmap, ch) of
adamc@144 943 NONE => SM.empty
adamc@144 944 | SOME fnums => fnums
adamc@144 945 val fnums = SM.insert (fnums, x, n)
adamc@144 946 in
adamc@144 947 CM.insert (cmap, ch, fnums)
adamc@144 948 end)
adamc@144 949 CM.empty fnums
adamc@144 950
adamc@144 951 val cmap = CM.listItemsi cmap
adamc@144 952 in
adamc@144 953 case cmap of
adamc@144 954 [(_, fnums)] =>
adamc@144 955 box [string "if",
adamc@144 956 space,
adamc@144 957 string "(name[",
adamc@144 958 string (Int.toString i),
adamc@144 959 string "]",
adamc@144 960 space,
adamc@144 961 string "==",
adamc@144 962 space,
adamc@144 963 string "0)",
adamc@144 964 space,
adamc@144 965 string "return",
adamc@144 966 space,
adamc@144 967 string "-1;",
adamc@144 968 newline,
adamc@144 969 makeSwitch (fnums, i+1)]
adamc@144 970 | _ =>
adamc@144 971 box [string "switch",
adamc@144 972 space,
adamc@144 973 string "(name[",
adamc@144 974 string (Int.toString i),
adamc@144 975 string "])",
adamc@144 976 space,
adamc@144 977 string "{",
adamc@144 978 newline,
adamc@144 979 box (map (fn (ch, fnums) =>
adamc@144 980 box [string "case",
adamc@144 981 space,
adamc@144 982 if ch = chr 0 then
adamc@144 983 string "0:"
adamc@144 984 else
adamc@144 985 box [string "'",
adamc@144 986 string (Char.toString ch),
adamc@144 987 string "':"],
adamc@144 988 newline,
adamc@144 989 makeSwitch (fnums, i+1),
adamc@144 990 newline]) cmap),
adamc@144 991 string "default:",
adamc@144 992 newline,
adamc@144 993 string "return",
adamc@144 994 space,
adamc@144 995 string "-1;",
adamc@144 996 newline,
adamc@144 997 string "}"]
adamc@144 998 end
adamc@144 999
adamc@186 1000 fun capitalize s =
adamc@186 1001 if s = "" then
adamc@186 1002 ""
adamc@186 1003 else
adamc@186 1004 str (Char.toUpper (String.sub (s, 0))) ^ String.extract (s, 1, NONE)
adamc@186 1005
adamc@144 1006 fun unurlify (t, loc) =
adamc@144 1007 case t of
adamc@186 1008 TFfi (m, t) => string ("lw_" ^ m ^ "_unurlify" ^ capitalize t ^ "(ctx, &request)")
adamc@144 1009
adamc@144 1010 | TRecord 0 => string "lw_unit_v"
adamc@144 1011 | TRecord i =>
adamc@144 1012 let
adamc@144 1013 val xts = E.lookupStruct env i
adamc@144 1014 in
adamc@144 1015 box [string "({",
adamc@144 1016 newline,
adamc@144 1017 box (map (fn (x, t) =>
adamc@144 1018 box [p_typ env t,
adamc@144 1019 space,
adamc@144 1020 string x,
adamc@144 1021 space,
adamc@144 1022 string "=",
adamc@144 1023 space,
adamc@144 1024 unurlify t,
adamc@144 1025 string ";",
adamc@144 1026 newline]) xts),
adamc@144 1027 string "struct",
adamc@144 1028 space,
adamc@144 1029 string "__lws_",
adamc@144 1030 string (Int.toString i),
adamc@144 1031 space,
adamc@181 1032 string "tmp",
adamc@144 1033 space,
adamc@144 1034 string "=",
adamc@144 1035 space,
adamc@144 1036 string "{",
adamc@144 1037 space,
adamc@144 1038 p_list_sep (box [string ",", space]) (fn (x, _) => string x) xts,
adamc@144 1039 space,
adamc@144 1040 string "};",
adamc@144 1041 newline,
adamc@181 1042 string "tmp;",
adamc@144 1043 newline,
adamc@144 1044 string "})"]
adamc@144 1045 end
adamc@144 1046
adamc@188 1047 | TDatatype (Enum, i, _) =>
adamc@188 1048 let
adamc@188 1049 val (x, xncs) = E.lookupDatatype env i
adamc@188 1050
adamc@188 1051 fun doEm xncs =
adamc@188 1052 case xncs of
adamc@188 1053 [] => string ("(lw_error(ctx, FATAL, \"Error unurlifying datatype " ^ x ^ "\"), (enum __lwe_"
adamc@188 1054 ^ x ^ "_" ^ Int.toString i ^ ")0)")
adamc@188 1055 | (x', n, to) :: rest =>
adamc@188 1056 box [string "((!strncmp(request, \"",
adamc@188 1057 string x',
adamc@188 1058 string "\", ",
adamc@188 1059 string (Int.toString (size x')),
adamc@188 1060 string ") && (request[",
adamc@188 1061 string (Int.toString (size x')),
adamc@188 1062 string "] == 0 || request[",
adamc@188 1063 string (Int.toString (size x')),
adamc@188 1064 string ("] == '/')) ? __lwc_" ^ x' ^ "_" ^ Int.toString n),
adamc@188 1065 space,
adamc@188 1066 string ":",
adamc@188 1067 space,
adamc@188 1068 doEm rest,
adamc@188 1069 string ")"]
adamc@188 1070 in
adamc@188 1071 doEm xncs
adamc@188 1072 end
adamc@188 1073
adamc@198 1074 | TDatatype (Option, i, xncs) =>
adamc@198 1075 let
adamc@198 1076 val (x, _) = E.lookupDatatype env i
adamc@198 1077
adamc@198 1078 val (no_arg, has_arg, t) =
adamc@198 1079 case !xncs of
adamc@198 1080 [(no_arg, _, NONE), (has_arg, _, SOME t)] =>
adamc@198 1081 (no_arg, has_arg, t)
adamc@198 1082 | [(has_arg, _, SOME t), (no_arg, _, NONE)] =>
adamc@198 1083 (no_arg, has_arg, t)
adamc@198 1084 | _ => raise Fail "CjrPrint: unfooify misclassified Option datatype"
adamc@198 1085 in
adamc@198 1086 box [string "(request[0] == '/' ? ++request : request,",
adamc@198 1087 newline,
adamc@198 1088 string "((!strncmp(request, \"",
adamc@198 1089 string no_arg,
adamc@198 1090 string "\", ",
adamc@198 1091 string (Int.toString (size no_arg)),
adamc@198 1092 string ") && (request[",
adamc@198 1093 string (Int.toString (size no_arg)),
adamc@198 1094 string "] == 0 || request[",
adamc@198 1095 string (Int.toString (size no_arg)),
adamc@198 1096 string "] == '/')) ? (request",
adamc@198 1097 space,
adamc@198 1098 string "+=",
adamc@198 1099 space,
adamc@198 1100 string (Int.toString (size no_arg)),
adamc@198 1101 string ", NULL) : ((!strncmp(request, \"",
adamc@198 1102 string has_arg,
adamc@198 1103 string "\", ",
adamc@198 1104 string (Int.toString (size has_arg)),
adamc@198 1105 string ") && (request[",
adamc@198 1106 string (Int.toString (size has_arg)),
adamc@198 1107 string "] == 0 || request[",
adamc@198 1108 string (Int.toString (size has_arg)),
adamc@198 1109 string "] == '/')) ? (request",
adamc@198 1110 space,
adamc@198 1111 string "+=",
adamc@198 1112 space,
adamc@198 1113 string (Int.toString (size has_arg)),
adamc@200 1114 string ", (request[0] == '/' ? ++request : NULL), ",
adamc@200 1115 newline,
adamc@198 1116
adamc@198 1117 case #1 t of
adamc@198 1118 TDatatype _ => unurlify t
adamc@199 1119 | TFfi ("Basis", "string") => unurlify t
adamc@198 1120 | _ => box [string "({",
adamc@198 1121 newline,
adamc@198 1122 p_typ env t,
adamc@198 1123 space,
adamc@198 1124 string "*tmp",
adamc@198 1125 space,
adamc@198 1126 string "=",
adamc@198 1127 space,
adamc@198 1128 string "lw_malloc(ctx, sizeof(",
adamc@198 1129 p_typ env t,
adamc@198 1130 string "));",
adamc@198 1131 newline,
adamc@198 1132 string "*tmp",
adamc@198 1133 space,
adamc@198 1134 string "=",
adamc@198 1135 space,
adamc@198 1136 unurlify t,
adamc@198 1137 string ";",
adamc@198 1138 newline,
adamc@198 1139 string "tmp;",
adamc@198 1140 newline,
adamc@198 1141 string "})"],
adamc@198 1142 string ")",
adamc@198 1143 newline,
adamc@198 1144 string ":",
adamc@198 1145 space,
adamc@198 1146 string ("(lw_error(ctx, FATAL, \"Error unurlifying datatype " ^ x ^ "\"), NULL))))")]
adamc@198 1147 end
adamc@198 1148
adamc@188 1149 | TDatatype (Default, i, _) =>
adamc@166 1150 let
adamc@166 1151 val (x, xncs) = E.lookupDatatype env i
adamc@166 1152
adamc@166 1153 fun doEm xncs =
adamc@166 1154 case xncs of
adamc@167 1155 [] => string ("(lw_error(ctx, FATAL, \"Error unurlifying datatype " ^ x ^ "\"), NULL)")
adamc@167 1156 | (x', n, to) :: rest =>
adamc@167 1157 box [string "((!strncmp(request, \"",
adamc@167 1158 string x',
adamc@167 1159 string "\", ",
adamc@167 1160 string (Int.toString (size x')),
adamc@167 1161 string ") && (request[",
adamc@167 1162 string (Int.toString (size x')),
adamc@167 1163 string "] == 0 || request[",
adamc@167 1164 string (Int.toString (size x')),
adamc@167 1165 string "] == '/')) ? ({",
adamc@166 1166 newline,
adamc@167 1167 string "struct",
adamc@167 1168 space,
adamc@166 1169 string ("__lwd_" ^ x ^ "_" ^ Int.toString i),
adamc@166 1170 space,
adamc@181 1171 string "*tmp = lw_malloc(ctx, sizeof(struct __lwd_",
adamc@167 1172 string x,
adamc@167 1173 string "_",
adamc@167 1174 string (Int.toString i),
adamc@167 1175 string "));",
adamc@166 1176 newline,
adamc@181 1177 string "tmp->tag",
adamc@166 1178 space,
adamc@166 1179 string "=",
adamc@166 1180 space,
adamc@167 1181 string ("__lwc_" ^ x' ^ "_" ^ Int.toString n),
adamc@166 1182 string ";",
adamc@166 1183 newline,
adamc@166 1184 string "request",
adamc@166 1185 space,
adamc@166 1186 string "+=",
adamc@166 1187 space,
adamc@167 1188 string (Int.toString (size x')),
adamc@166 1189 string ";",
adamc@166 1190 newline,
adamc@200 1191 string "if (request[0] == '/') ++request;",
adamc@200 1192 newline,
adamc@166 1193 case to of
adamc@166 1194 NONE => box []
adamc@197 1195 | SOME t => box [string "tmp->data.lw_",
adamc@167 1196 string x',
adamc@166 1197 space,
adamc@166 1198 string "=",
adamc@166 1199 space,
adamc@166 1200 unurlify t,
adamc@166 1201 string ";",
adamc@166 1202 newline],
adamc@181 1203 string "tmp;",
adamc@166 1204 newline,
adamc@166 1205 string "})",
adamc@166 1206 space,
adamc@166 1207 string ":",
adamc@166 1208 space,
adamc@166 1209 doEm rest,
adamc@166 1210 string ")"]
adamc@166 1211 in
adamc@166 1212 doEm xncs
adamc@166 1213 end
adamc@166 1214
adamc@144 1215 | _ => (ErrorMsg.errorAt loc "Unable to choose a URL decoding function";
adamc@144 1216 space)
adamc@144 1217
adamc@144 1218
adamc@144 1219 fun p_page (ek, s, n, ts) =
adamc@144 1220 let
adamc@144 1221 val (ts, defInputs, inputsVar) =
adamc@144 1222 case ek of
adamc@144 1223 Core.Link => (ts, string "", string "")
adamc@144 1224 | Core.Action =>
adamc@144 1225 case List.last ts of
adamc@144 1226 (TRecord i, _) =>
adamc@144 1227 let
adamc@144 1228 val xts = E.lookupStruct env i
adamc@144 1229 in
adamc@144 1230 (List.drop (ts, 1),
adamc@144 1231 box [box (map (fn (x, t) => box [p_typ env t,
adamc@144 1232 space,
adamc@144 1233 string "lw_input_",
adamc@144 1234 string x,
adamc@144 1235 string ";",
adamc@144 1236 newline]) xts),
adamc@144 1237 newline,
adamc@144 1238 box (map (fn (x, t) =>
adamc@144 1239 let
adamc@144 1240 val n = case SM.find (fnums, x) of
adamc@144 1241 NONE => raise Fail "CjrPrint: Can't find in fnums"
adamc@144 1242 | SOME n => n
adamc@190 1243
adamc@190 1244 val f = case t of
adamc@190 1245 (TFfi ("Basis", "bool"), _) => "optional_"
adamc@190 1246 | _ => ""
adamc@144 1247 in
adamc@190 1248 box [string "request = lw_get_",
adamc@190 1249 string f,
adamc@190 1250 string "input(ctx, ",
adamc@144 1251 string (Int.toString n),
adamc@144 1252 string ");",
adamc@144 1253 newline,
adamc@144 1254 string "if (request == NULL) {",
adamc@144 1255 newline,
adamc@144 1256 box [string "printf(\"Missing input ",
adamc@144 1257 string x,
adamc@144 1258 string "\\n\");",
adamc@144 1259 newline,
adamc@144 1260 string "exit(1);"],
adamc@144 1261 newline,
adamc@144 1262 string "}",
adamc@144 1263 newline,
adamc@144 1264 string "lw_input_",
adamc@144 1265 string x,
adamc@144 1266 space,
adamc@144 1267 string "=",
adamc@144 1268 space,
adamc@144 1269 unurlify t,
adamc@144 1270 string ";",
adamc@144 1271 newline]
adamc@144 1272 end) xts),
adamc@144 1273 string "struct __lws_",
adamc@144 1274 string (Int.toString i),
adamc@144 1275 space,
adamc@144 1276 string "lw_inputs",
adamc@144 1277 space,
adamc@144 1278 string "= {",
adamc@144 1279 newline,
adamc@144 1280 box (map (fn (x, _) => box [string "lw_input_",
adamc@144 1281 string x,
adamc@144 1282 string ",",
adamc@144 1283 newline]) xts),
adamc@144 1284 string "};",
adamc@144 1285 newline],
adamc@144 1286 box [string ",",
adamc@144 1287 space,
adamc@144 1288 string "lw_inputs"])
adamc@144 1289 end
adamc@144 1290
adamc@144 1291 | _ => raise Fail "CjrPrint: Last argument to an action isn't a record"
adamc@144 1292 in
adamc@144 1293 box [string "if (!strncmp(request, \"",
adamc@144 1294 string (String.toString s),
adamc@144 1295 string "\", ",
adamc@144 1296 string (Int.toString (size s)),
adamc@198 1297 string ") && (request[",
adamc@198 1298 string (Int.toString (size s)),
adamc@198 1299 string "] == 0 || request[",
adamc@198 1300 string (Int.toString (size s)),
adamc@198 1301 string "] == '/')) {",
adamc@144 1302 newline,
adamc@144 1303 string "request += ",
adamc@144 1304 string (Int.toString (size s)),
adamc@144 1305 string ";",
adamc@144 1306 newline,
adamc@144 1307 string "if (*request == '/') ++request;",
adamc@144 1308 newline,
adamc@144 1309 box [string "{",
adamc@144 1310 newline,
adamc@144 1311 box (ListUtil.mapi (fn (i, t) => box [p_typ env t,
adamc@144 1312 space,
adamc@144 1313 string "arg",
adamc@144 1314 string (Int.toString i),
adamc@144 1315 space,
adamc@144 1316 string "=",
adamc@144 1317 space,
adamc@144 1318 unurlify t,
adamc@144 1319 string ";",
adamc@144 1320 newline]) ts),
adamc@144 1321 defInputs,
adamc@144 1322 p_enamed env n,
adamc@144 1323 string "(",
adamc@144 1324 p_list_sep (box [string ",", space])
adamc@144 1325 (fn x => x)
adamc@272 1326 (string "ctx"
adamc@272 1327 :: ListUtil.mapi (fn (i, _) => string ("arg" ^ Int.toString i)) ts
adamc@272 1328 @ [string "lw_unit_v"]),
adamc@144 1329 inputsVar,
adamc@144 1330 string ");",
adamc@144 1331 newline,
adamc@144 1332 string "return;",
adamc@144 1333 newline,
adamc@144 1334 string "}",
adamc@144 1335 newline,
adamc@144 1336 string "}"]
adamc@144 1337 ]
adamc@144 1338 end
adamc@144 1339
adamc@144 1340 val pds' = map p_page ps
adamc@275 1341
adamc@275 1342 val tables = List.mapPartial (fn (DTable (s, xts), _) => SOME (s, xts)
adamc@275 1343 | _ => NONE) ds
adamc@275 1344
adamc@275 1345 val validate =
adamc@275 1346 box [string "static void lw_db_validate(lw_context ctx) {",
adamc@275 1347 newline,
adamc@275 1348 string "PGconn *conn = lw_get_db(ctx);",
adamc@275 1349 newline,
adamc@275 1350 string "PGresult *res;",
adamc@275 1351 newline,
adamc@275 1352 newline,
adamc@275 1353 p_list_sep newline
adamc@275 1354 (fn (s, xts) =>
adamc@275 1355 let
adamc@275 1356 val q = "SELECT COUNT(*) FROM pg_class WHERE relname = '"
adamc@275 1357 ^ s ^ "'"
adamc@275 1358
adamc@275 1359 val q' = String.concat ["SELECT COUNT(*) FROM pg_attribute WHERE attrelid = (SELECT oid FROM pg_class WHERE relname = '",
adamc@275 1360 s,
adamc@275 1361 "') AND (",
adamc@275 1362 String.concatWith " OR "
adamc@275 1363 (map (fn (x, t) =>
adamc@275 1364 String.concat ["(attname = 'lw_",
adamc@275 1365 CharVector.map
adamc@275 1366 Char.toLower x,
adamc@275 1367 "' AND atttypid = (SELECT oid FROM pg_type",
adamc@275 1368 " WHERE typname = '",
adamc@275 1369 p_sqltype' env t,
adamc@275 1370 "'))"]) xts),
adamc@275 1371 ")"]
adamc@275 1372
adamc@275 1373 val q'' = String.concat ["SELECT COUNT(*) FROM pg_attribute WHERE attrelid = (SELECT oid FROM pg_class WHERE relname = '",
adamc@275 1374 s,
adamc@275 1375 "') AND attnum >= 0"]
adamc@275 1376 in
adamc@275 1377 box [string "res = PQexec(conn, \"",
adamc@275 1378 string q,
adamc@275 1379 string "\");",
adamc@275 1380 newline,
adamc@275 1381 newline,
adamc@275 1382 string "if (res == NULL) {",
adamc@275 1383 newline,
adamc@275 1384 box [string "PQfinish(conn);",
adamc@275 1385 newline,
adamc@275 1386 string "lw_error(ctx, FATAL, \"Out of memory allocating query result.\");",
adamc@275 1387 newline],
adamc@275 1388 string "}",
adamc@275 1389 newline,
adamc@275 1390 newline,
adamc@275 1391 string "if (PQresultStatus(res) != PGRES_TUPLES_OK) {",
adamc@275 1392 newline,
adamc@275 1393 box [string "char msg[1024];",
adamc@275 1394 newline,
adamc@275 1395 string "strncpy(msg, PQerrorMessage(conn), 1024);",
adamc@275 1396 newline,
adamc@275 1397 string "msg[1023] = 0;",
adamc@275 1398 newline,
adamc@275 1399 string "PQclear(res);",
adamc@275 1400 newline,
adamc@275 1401 string "PQfinish(conn);",
adamc@275 1402 newline,
adamc@275 1403 string "lw_error(ctx, FATAL, \"Query failed:\\n",
adamc@275 1404 string q,
adamc@275 1405 string "\\n%s\", msg);",
adamc@275 1406 newline],
adamc@275 1407 string "}",
adamc@275 1408 newline,
adamc@275 1409 newline,
adamc@275 1410 string "if (strcmp(PQgetvalue(res, 0, 0), \"1\")) {",
adamc@275 1411 newline,
adamc@275 1412 box [string "PQclear(res);",
adamc@275 1413 newline,
adamc@275 1414 string "PQfinish(conn);",
adamc@275 1415 newline,
adamc@275 1416 string "lw_error(ctx, FATAL, \"Table '",
adamc@275 1417 string s,
adamc@275 1418 string "' does not exist.\");",
adamc@275 1419 newline],
adamc@275 1420 string "}",
adamc@275 1421 newline,
adamc@275 1422 newline,
adamc@275 1423 string "PQclear(res);",
adamc@275 1424 newline,
adamc@275 1425
adamc@275 1426 string "res = PQexec(conn, \"",
adamc@275 1427 string q',
adamc@275 1428 string "\");",
adamc@275 1429 newline,
adamc@275 1430 newline,
adamc@275 1431 string "if (res == NULL) {",
adamc@275 1432 newline,
adamc@275 1433 box [string "PQfinish(conn);",
adamc@275 1434 newline,
adamc@275 1435 string "lw_error(ctx, FATAL, \"Out of memory allocating query result.\");",
adamc@275 1436 newline],
adamc@275 1437 string "}",
adamc@275 1438 newline,
adamc@275 1439 newline,
adamc@275 1440 string "if (PQresultStatus(res) != PGRES_TUPLES_OK) {",
adamc@275 1441 newline,
adamc@275 1442 box [string "char msg[1024];",
adamc@275 1443 newline,
adamc@275 1444 string "strncpy(msg, PQerrorMessage(conn), 1024);",
adamc@275 1445 newline,
adamc@275 1446 string "msg[1023] = 0;",
adamc@275 1447 newline,
adamc@275 1448 string "PQclear(res);",
adamc@275 1449 newline,
adamc@275 1450 string "PQfinish(conn);",
adamc@275 1451 newline,
adamc@275 1452 string "lw_error(ctx, FATAL, \"Query failed:\\n",
adamc@275 1453 string q',
adamc@275 1454 string "\\n%s\", msg);",
adamc@275 1455 newline],
adamc@275 1456 string "}",
adamc@275 1457 newline,
adamc@275 1458 newline,
adamc@275 1459 string "if (strcmp(PQgetvalue(res, 0, 0), \"",
adamc@275 1460 string (Int.toString (length xts)),
adamc@275 1461 string "\")) {",
adamc@275 1462 newline,
adamc@275 1463 box [string "PQclear(res);",
adamc@275 1464 newline,
adamc@275 1465 string "PQfinish(conn);",
adamc@275 1466 newline,
adamc@275 1467 string "lw_error(ctx, FATAL, \"Table '",
adamc@275 1468 string s,
adamc@275 1469 string "' has the wrong column types.\");",
adamc@275 1470 newline],
adamc@275 1471 string "}",
adamc@275 1472 newline,
adamc@275 1473 newline,
adamc@275 1474 string "PQclear(res);",
adamc@275 1475 newline,
adamc@275 1476 newline,
adamc@275 1477
adamc@275 1478 string "res = PQexec(conn, \"",
adamc@275 1479 string q'',
adamc@275 1480 string "\");",
adamc@275 1481 newline,
adamc@275 1482 newline,
adamc@275 1483 string "if (res == NULL) {",
adamc@275 1484 newline,
adamc@275 1485 box [string "PQfinish(conn);",
adamc@275 1486 newline,
adamc@275 1487 string "lw_error(ctx, FATAL, \"Out of memory allocating query result.\");",
adamc@275 1488 newline],
adamc@275 1489 string "}",
adamc@275 1490 newline,
adamc@275 1491 newline,
adamc@275 1492 string "if (PQresultStatus(res) != PGRES_TUPLES_OK) {",
adamc@275 1493 newline,
adamc@275 1494 box [string "char msg[1024];",
adamc@275 1495 newline,
adamc@275 1496 string "strncpy(msg, PQerrorMessage(conn), 1024);",
adamc@275 1497 newline,
adamc@275 1498 string "msg[1023] = 0;",
adamc@275 1499 newline,
adamc@275 1500 string "PQclear(res);",
adamc@275 1501 newline,
adamc@275 1502 string "PQfinish(conn);",
adamc@275 1503 newline,
adamc@275 1504 string "lw_error(ctx, FATAL, \"Query failed:\\n",
adamc@275 1505 string q'',
adamc@275 1506 string "\\n%s\", msg);",
adamc@275 1507 newline],
adamc@275 1508 string "}",
adamc@275 1509 newline,
adamc@275 1510 newline,
adamc@275 1511 string "if (strcmp(PQgetvalue(res, 0, 0), \"",
adamc@275 1512 string (Int.toString (length xts)),
adamc@275 1513 string "\")) {",
adamc@275 1514 newline,
adamc@275 1515 box [string "PQclear(res);",
adamc@275 1516 newline,
adamc@275 1517 string "PQfinish(conn);",
adamc@275 1518 newline,
adamc@275 1519 string "lw_error(ctx, FATAL, \"Table '",
adamc@275 1520 string s,
adamc@275 1521 string "' has extra columns.\");",
adamc@275 1522 newline],
adamc@275 1523 string "}",
adamc@275 1524 newline,
adamc@275 1525 newline,
adamc@275 1526 string "PQclear(res);",
adamc@275 1527 newline]
adamc@275 1528 end) tables,
adamc@275 1529 string "}"]
adamc@29 1530 in
adamc@144 1531 box [string "#include <stdio.h>",
adamc@144 1532 newline,
adamc@144 1533 string "#include <stdlib.h>",
adamc@144 1534 newline,
adamc@272 1535 string "#include <string.h>",
adamc@272 1536 newline,
adamc@272 1537 string "#include <postgresql/libpq-fe.h>",
adamc@272 1538 newline,
adamc@144 1539 newline,
adamc@244 1540 string "#include \"urweb.h\"",
adamc@101 1541 newline,
adamc@101 1542 newline,
adamc@101 1543 p_list_sep newline (fn x => x) pds,
adamc@101 1544 newline,
adamc@144 1545 string "int lw_inputs_len = ",
adamc@144 1546 string (Int.toString (SM.foldl Int.max 0 fnums + 1)),
adamc@144 1547 string ";",
adamc@144 1548 newline,
adamc@144 1549 newline,
adamc@144 1550 string "int lw_input_num(char *name) {",
adamc@144 1551 newline,
adamc@144 1552 makeSwitch (fnums, 0),
adamc@144 1553 string "}",
adamc@144 1554 newline,
adamc@144 1555 newline,
adamc@117 1556 string "void lw_handle(lw_context ctx, char *request) {",
adamc@101 1557 newline,
adamc@101 1558 p_list_sep newline (fn x => x) pds',
adamc@101 1559 newline,
adamc@101 1560 string "}",
adamc@275 1561 newline,
adamc@275 1562 newline,
adamc@275 1563 validate,
adamc@101 1564 newline]
adamc@29 1565 end
adamc@29 1566
adamc@274 1567 fun p_sql env (ds, _) =
adamc@274 1568 let
adamc@274 1569 val (pps, _) = ListUtil.foldlMap
adamc@274 1570 (fn (dAll as (d, _), env) =>
adamc@274 1571 let
adamc@274 1572 val pp = case d of
adamc@274 1573 DTable (s, xts) =>
adamc@274 1574 box [string "CREATE TABLE ",
adamc@274 1575 string s,
adamc@274 1576 string "(",
adamc@274 1577 p_list (fn (x, t) =>
adamc@274 1578 box [string "lw_",
adamc@275 1579 string (CharVector.map Char.toLower x),
adamc@274 1580 space,
adamc@274 1581 p_sqltype env t,
adamc@274 1582 space,
adamc@274 1583 string "NOT",
adamc@274 1584 space,
adamc@274 1585 string "NULL"]) xts,
adamc@274 1586 string ");",
adamc@274 1587 newline,
adamc@274 1588 newline]
adamc@274 1589 | _ => box []
adamc@274 1590 in
adamc@274 1591 (pp, E.declBinds env dAll)
adamc@274 1592 end)
adamc@274 1593 env ds
adamc@274 1594 in
adamc@274 1595 box pps
adamc@274 1596 end
adamc@274 1597
adamc@29 1598 end