Mercurial > urweb

annotate src/cjr_print.sml @ 277:286f734db702

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