Mercurial > urweb

comparison src/cjr_print.sml @ 311:9ad92047a499

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Rename 'lw' prefixes to 'uw'
author Adam Chlipala <adamc@hcoop.net>
date Sun, 07 Sep 2008 15:40:42 -0400
parents 52d4c60518d4
children a07f476d9b61
comparison
equal deleted inserted replaced
310:0aee86b8a6d6 311:9ad92047a499
66 string "(", 66 string "(",
67 p_typ env t1, 67 p_typ env t1,
68 string ")"]) 68 string ")"])
69 | TRecord i => box [string "struct", 69 | TRecord i => box [string "struct",
70 space, 70 space,
71 string "__lws_", 71 string "__uws_",
72 string (Int.toString i)] 72 string (Int.toString i)]
73 | TDatatype (Enum, n, _) => 73 | TDatatype (Enum, n, _) =>
74 (box [string "enum", 74 (box [string "enum",
75 space, 75 space,
76 string ("__lwe_" ^ #1 (E.lookupDatatype env n) ^ "_" ^ Int.toString n)] 76 string ("__uwe_" ^ #1 (E.lookupDatatype env n) ^ "_" ^ Int.toString n)]
77 handle CjrEnv.UnboundNamed _ => string ("__lwd_UNBOUND__" ^ Int.toString n)) 77 handle CjrEnv.UnboundNamed _ => string ("__uwd_UNBOUND__" ^ Int.toString n))
78 | TDatatype (Option, n, xncs) => 78 | TDatatype (Option, n, xncs) =>
79 (case ListUtil.search #3 (!xncs) of 79 (case ListUtil.search #3 (!xncs) of
80 NONE => raise Fail "CjrPrint: TDatatype marked Option has no constructor with an argument" 80 NONE => raise Fail "CjrPrint: TDatatype marked Option has no constructor with an argument"
81 | SOME t => 81 | SOME t =>
82 case #1 t of 82 case #1 t of
85 | _ => box [p_typ' par env t, 85 | _ => box [p_typ' par env t,
86 string "*"]) 86 string "*"])
87 | TDatatype (Default, n, _) => 87 | TDatatype (Default, n, _) =>
88 (box [string "struct", 88 (box [string "struct",
89 space, 89 space,
90 string ("__lwd_" ^ #1 (E.lookupDatatype env n) ^ "_" ^ Int.toString n ^ "*")] 90 string ("__uwd_" ^ #1 (E.lookupDatatype env n) ^ "_" ^ Int.toString n ^ "*")]
91 handle CjrEnv.UnboundNamed _ => string ("__lwd_UNBOUND__" ^ Int.toString n)) 91 handle CjrEnv.UnboundNamed _ => string ("__uwd_UNBOUND__" ^ Int.toString n))
92 | TFfi (m, x) => box [string "lw_", string m, string "_", string x] 92 | TFfi (m, x) => box [string "uw_", string m, string "_", string x]
93 | TOption t => 93 | TOption t =>
94 (case #1 t of 94 (case #1 t of
95 TDatatype _ => p_typ' par env t 95 TDatatype _ => p_typ' par env t
96 | TFfi ("Basis", "string") => p_typ' par env t 96 | TFfi ("Basis", "string") => p_typ' par env t
97 | _ => box [p_typ' par env t, 97 | _ => box [p_typ' par env t,
98 string "*"]) 98 string "*"])
99 99
100 and p_typ env = p_typ' false env 100 and p_typ env = p_typ' false env
101 101
102 fun p_rel env n = string ("__lwr_" ^ #1 (E.lookupERel env n) ^ "_" ^ Int.toString (E.countERels env - n - 1)) 102 fun p_rel env n = string ("__uwr_" ^ #1 (E.lookupERel env n) ^ "_" ^ Int.toString (E.countERels env - n - 1))
103 handle CjrEnv.UnboundRel _ => string ("__lwr_UNBOUND_" ^ Int.toString (E.countERels env - n - 1)) 103 handle CjrEnv.UnboundRel _ => string ("__uwr_UNBOUND_" ^ Int.toString (E.countERels env - n - 1))
104 104
105 fun p_enamed env n = 105 fun p_enamed env n =
106 string ("__lwn_" ^ #1 (E.lookupENamed env n) ^ "_" ^ Int.toString n) 106 string ("__uwn_" ^ #1 (E.lookupENamed env n) ^ "_" ^ Int.toString n)
107 handle CjrEnv.UnboundNamed _ => string ("__lwn_UNBOUND_" ^ Int.toString n) 107 handle CjrEnv.UnboundNamed _ => string ("__uwn_UNBOUND_" ^ Int.toString n)
108 108
109 fun p_con_named env n = 109 fun p_con_named env n =
110 string ("__lwc_" ^ #1 (E.lookupConstructor env n) ^ "_" ^ Int.toString n) 110 string ("__uwc_" ^ #1 (E.lookupConstructor env n) ^ "_" ^ Int.toString n)
111 handle CjrEnv.UnboundNamed _ => string ("__lwc_UNBOUND_" ^ Int.toString n) 111 handle CjrEnv.UnboundNamed _ => string ("__uwc_UNBOUND_" ^ Int.toString n)
112 112
113 fun p_pat_preamble env (p, _) = 113 fun p_pat_preamble env (p, _) =
114 case p of 114 case p of
115 PWild => (box [], 115 PWild => (box [],
116 env) 116 env)
117 | PVar (x, t) => (box [p_typ env t, 117 | PVar (x, t) => (box [p_typ env t,
118 space, 118 space,
119 string "__lwr_", 119 string "__uwr_",
120 string x, 120 string x,
121 string "_", 121 string "_",
122 string (Int.toString (E.countERels env)), 122 string (Int.toString (E.countERels env)),
123 string ";", 123 string ";",
124 newline], 124 newline],
137 | PSome (_, p) => p_pat_preamble env p 137 | PSome (_, p) => p_pat_preamble env p
138 138
139 fun p_patCon env pc = 139 fun p_patCon env pc =
140 case pc of 140 case pc of
141 PConVar n => p_con_named env n 141 PConVar n => p_con_named env n
142 | PConFfi {mod = m, con, ...} => string ("lw_" ^ m ^ "_" ^ con) 142 | PConFfi {mod = m, con, ...} => string ("uw_" ^ m ^ "_" ^ con)
143 143
144 fun p_pat (env, exit, depth) (p, _) = 144 fun p_pat (env, exit, depth) (p, _) =
145 case p of 145 case p of
146 PWild => 146 PWild =>
147 (box [], env) 147 (box [], env)
148 | PVar (x, t) => 148 | PVar (x, t) =>
149 (box [string "__lwr_", 149 (box [string "__uwr_",
150 string x, 150 string x,
151 string "_", 151 string "_",
152 string (Int.toString (E.countERels env)), 152 string (Int.toString (E.countERels env)),
153 space, 153 space,
154 string "=", 154 string "=",
196 val (x, to) = case pc of 196 val (x, to) = case pc of
197 PConVar n => 197 PConVar n =>
198 let 198 let
199 val (x, to, _) = E.lookupConstructor env n 199 val (x, to, _) = E.lookupConstructor env n
200 in 200 in
201 ("lw_" ^ x, to) 201 ("uw_" ^ x, to)
202 end 202 end
203 | PConFfi {mod = m, con, arg, ...} => 203 | PConFfi {mod = m, con, arg, ...} =>
204 ("lw_" ^ m ^ "_" ^ con, arg) 204 ("uw_" ^ m ^ "_" ^ con, arg)
205 205
206 val t = case to of 206 val t = case to of
207 NONE => raise Fail "CjrPrint: Constructor mismatch" 207 NONE => raise Fail "CjrPrint: Constructor mismatch"
208 | SOME t => t 208 | SOME t => t
209 in 209 in
284 space, 284 space,
285 string "=", 285 string "=",
286 space, 286 space,
287 string "disc", 287 string "disc",
288 string (Int.toString depth), 288 string (Int.toString depth),
289 string ".__lwf_", 289 string ".__uwf_",
290 string x, 290 string x,
291 string ";", 291 string ";",
292 newline, 292 newline,
293 p, 293 p,
294 newline, 294 newline,
377 PConVar n => 377 PConVar n =>
378 let 378 let
379 val (x, _, dn) = E.lookupConstructor env n 379 val (x, _, dn) = E.lookupConstructor env n
380 val (dx, _) = E.lookupDatatype env dn 380 val (dx, _) = E.lookupDatatype env dn
381 in 381 in
382 ("__lwd_" ^ dx ^ "_" ^ Int.toString dn, 382 ("__uwd_" ^ dx ^ "_" ^ Int.toString dn,
383 "__lwc_" ^ x ^ "_" ^ Int.toString n, 383 "__uwc_" ^ x ^ "_" ^ Int.toString n,
384 "lw_" ^ x) 384 "uw_" ^ x)
385 end 385 end
386 | PConFfi {mod = m, datatyp, con, ...} => 386 | PConFfi {mod = m, datatyp, con, ...} =>
387 ("lw_" ^ m ^ "_" ^ datatyp, 387 ("uw_" ^ m ^ "_" ^ datatyp,
388 "lw_" ^ m ^ "_" ^ con, 388 "uw_" ^ m ^ "_" ^ con,
389 "lw_" ^ con) 389 "uw_" ^ con)
390 390
391 fun p_unsql env (tAll as (t, loc)) e = 391 fun p_unsql env (tAll as (t, loc)) e =
392 case t of 392 case t of
393 TFfi ("Basis", "int") => box [string "lw_Basis_stringToInt_error(ctx, ", e, string ")"] 393 TFfi ("Basis", "int") => box [string "uw_Basis_stringToInt_error(ctx, ", e, string ")"]
394 | TFfi ("Basis", "float") => box [string "lw_Basis_stringToFloat_error(ctx, ", e, string ")"] 394 | TFfi ("Basis", "float") => box [string "uw_Basis_stringToFloat_error(ctx, ", e, string ")"]
395 | TFfi ("Basis", "string") => box [string "lw_Basis_strdup(ctx, ", e, string ")"] 395 | TFfi ("Basis", "string") => box [string "uw_Basis_strdup(ctx, ", e, string ")"]
396 | TFfi ("Basis", "bool") => box [string "lw_Basis_stringToBool_error(ctx, ", e, string ")"] 396 | TFfi ("Basis", "bool") => box [string "uw_Basis_stringToBool_error(ctx, ", e, string ")"]
397 | _ => (ErrorMsg.errorAt loc "Don't know how to unmarshal type from SQL"; 397 | _ => (ErrorMsg.errorAt loc "Don't know how to unmarshal type from SQL";
398 Print.eprefaces' [("Type", p_typ env tAll)]; 398 Print.eprefaces' [("Type", p_typ env tAll)];
399 string "ERROR") 399 string "ERROR")
400 400
401 datatype sql_type = 401 datatype sql_type =
404 | String 404 | String
405 | Bool 405 | Bool
406 406
407 fun p_sql_type t = 407 fun p_sql_type t =
408 string (case t of 408 string (case t of
409 Int => "lw_Basis_int" 409 Int => "uw_Basis_int"
410 | Float => "lw_Basis_float" 410 | Float => "uw_Basis_float"
411 | String => "lw_Basis_string" 411 | String => "uw_Basis_string"
412 | Bool => "lw_Basis_bool") 412 | Bool => "uw_Basis_bool")
413 413
414 fun getPargs (e, _) = 414 fun getPargs (e, _) =
415 case e of 415 case e of
416 EPrim (Prim.String _) => [] 416 EPrim (Prim.String _) => []
417 | EFfiApp ("Basis", "strcat", [e1, e2]) => getPargs e1 @ getPargs e2 417 | EFfiApp ("Basis", "strcat", [e1, e2]) => getPargs e1 @ getPargs e2
423 423
424 | _ => raise Fail "CjrPrint: getPargs" 424 | _ => raise Fail "CjrPrint: getPargs"
425 425
426 fun p_ensql t e = 426 fun p_ensql t e =
427 case t of 427 case t of
428 Int => box [string "lw_Basis_attrifyInt(ctx, ", e, string ")"] 428 Int => box [string "uw_Basis_attrifyInt(ctx, ", e, string ")"]
429 | Float => box [string "lw_Basis_attrifyFloat(ctx, ", e, string ")"] 429 | Float => box [string "uw_Basis_attrifyFloat(ctx, ", e, string ")"]
430 | String => e 430 | String => e
431 | Bool => box [string "(", e, string " ? \"TRUE\" : \"FALSE\")"] 431 | Bool => box [string "(", e, string " ? \"TRUE\" : \"FALSE\")"]
432 432
433 fun p_ensql_len t e = 433 fun p_ensql_len t e =
434 case t of 434 case t of
435 Int => string "sizeof(lw_Basis_int)" 435 Int => string "sizeof(uw_Basis_int)"
436 | Float => string "sizeof(lw_Basis_float)" 436 | Float => string "sizeof(uw_Basis_float)"
437 | String => box [string "strlen(", e, string ")"] 437 | String => box [string "strlen(", e, string ")"]
438 | Bool => string "sizeof(lw_Basis_bool)" 438 | Bool => string "sizeof(uw_Basis_bool)"
439 439
440 fun p_exp' par env (e, loc) = 440 fun p_exp' par env (e, loc) =
441 case e of 441 case e of
442 EPrim p => Prim.p_t_GCC p 442 EPrim p => Prim.p_t_GCC p
443 | ERel n => p_rel env n 443 | ERel n => p_rel env n
463 space, 463 space,
464 string "*tmp", 464 string "*tmp",
465 space, 465 space,
466 string "=", 466 string "=",
467 space, 467 space,
468 string "lw_malloc(ctx, sizeof(", 468 string "uw_malloc(ctx, sizeof(",
469 p_typ env t, 469 p_typ env t,
470 string "));", 470 string "));",
471 newline, 471 newline,
472 string "*tmp", 472 string "*tmp",
473 space, 473 space,
491 space, 491 space,
492 string "*tmp", 492 string "*tmp",
493 space, 493 space,
494 string "=", 494 string "=",
495 space, 495 space,
496 string "lw_malloc(ctx, sizeof(struct ", 496 string "uw_malloc(ctx, sizeof(struct ",
497 string xd, 497 string xd,
498 string "));", 498 string "));",
499 newline, 499 newline,
500 string "tmp->tag", 500 string "tmp->tag",
501 space, 501 space,
529 space, 529 space,
530 string "*tmp", 530 string "*tmp",
531 space, 531 space,
532 string "=", 532 string "=",
533 space, 533 space,
534 string "lw_malloc(ctx, sizeof(", 534 string "uw_malloc(ctx, sizeof(",
535 p_typ env t, 535 p_typ env t,
536 string "));", 536 string "));",
537 newline, 537 newline,
538 string "*tmp", 538 string "*tmp",
539 space, 539 space,
543 newline, 543 newline,
544 string "tmp;", 544 string "tmp;",
545 newline, 545 newline,
546 string "})"]) 546 string "})"])
547 547
548 | EFfi (m, x) => box [string "lw_", string m, string "_", string x] 548 | EFfi (m, x) => box [string "uw_", string m, string "_", string x]
549 | EError (e, t) => 549 | EError (e, t) =>
550 box [string "({", 550 box [string "({",
551 newline, 551 newline,
552 p_typ env t, 552 p_typ env t,
553 space, 553 space,
554 string "tmp;", 554 string "tmp;",
555 newline, 555 newline,
556 string "lw_error(ctx, FATAL, \"", 556 string "uw_error(ctx, FATAL, \"",
557 string (ErrorMsg.spanToString loc), 557 string (ErrorMsg.spanToString loc),
558 string ": %s\", ", 558 string ": %s\", ",
559 p_exp env e, 559 p_exp env e,
560 string ");", 560 string ");",
561 newline, 561 newline,
562 string "tmp;", 562 string "tmp;",
563 newline, 563 newline,
564 string "})"] 564 string "})"]
565 | EFfiApp (m, x, es) => box [string "lw_", 565 | EFfiApp (m, x, es) => box [string "uw_",
566 string m, 566 string m,
567 string "_", 567 string "_",
568 string x, 568 string x,
569 string "(ctx, ", 569 string "(ctx, ",
570 p_list (p_exp env) es, 570 p_list (p_exp env) es,
587 587
588 | ERecord (i, xes) => box [string "({", 588 | ERecord (i, xes) => box [string "({",
589 space, 589 space,
590 string "struct", 590 string "struct",
591 space, 591 space,
592 string ("__lws_" ^ Int.toString i), 592 string ("__uws_" ^ Int.toString i),
593 space, 593 space,
594 string "tmp", 594 string "tmp",
595 space, 595 space,
596 string "=", 596 string "=",
597 space, 597 space,
603 string "tmp;", 603 string "tmp;",
604 space, 604 space,
605 string "})" ] 605 string "})" ]
606 | EField (e, x) => 606 | EField (e, x) =>
607 box [p_exp' true env e, 607 box [p_exp' true env e,
608 string ".__lwf_", 608 string ".__uwf_",
609 string x] 609 string x]
610 610
611 | ECase (e, pes, {disc, result}) => 611 | ECase (e, pes, {disc, result}) =>
612 let 612 let
613 val final = newGoto () 613 val final = newGoto ()
663 p_typ env result, 663 p_typ env result,
664 space, 664 space,
665 string "result;", 665 string "result;",
666 newline, 666 newline,
667 body, 667 body,
668 string "lw_error(ctx, FATAL, \"", 668 string "uw_error(ctx, FATAL, \"",
669 string (ErrorMsg.spanToString loc), 669 string (ErrorMsg.spanToString loc),
670 string ": pattern match failure\");", 670 string ": pattern match failure\");",
671 newline, 671 newline,
672 final, 672 final,
673 string ":", 673 string ":",
675 string "result;", 675 string "result;",
676 newline, 676 newline,
677 string "})"] 677 string "})"]
678 end 678 end
679 679
680 | EWrite e => box [string "(lw_write(ctx, ", 680 | EWrite e => box [string "(uw_write(ctx, ",
681 p_exp env e, 681 p_exp env e,
682 string "), lw_unit_v)"] 682 string "), uw_unit_v)"]
683 683
684 | ESeq (e1, e2) => box [string "(", 684 | ESeq (e1, e2) => box [string "(",
685 p_exp env e1, 685 p_exp env e1,
686 string ",", 686 string ",",
687 space, 687 space,
689 string ")"] 689 string ")"]
690 | ELet (x, t, e1, e2) => box [string "({", 690 | ELet (x, t, e1, e2) => box [string "({",
691 newline, 691 newline,
692 p_typ env t, 692 p_typ env t,
693 space, 693 space,
694 string "__lwr_", 694 string "__uwr_",
695 string x, 695 string x,
696 string "_", 696 string "_",
697 string (Int.toString (E.countERels env)), 697 string (Int.toString (E.countERels env)),
698 space, 698 space,
699 string "=", 699 string "=",
706 newline, 706 newline,
707 string "})"] 707 string "})"]
708 708
709 | EQuery {exps, tables, rnum, state, query, body, initial, prepared} => 709 | EQuery {exps, tables, rnum, state, query, body, initial, prepared} =>
710 let 710 let
711 val exps = map (fn (x, t) => ("__lwf_" ^ x, t)) exps 711 val exps = map (fn (x, t) => ("__uwf_" ^ x, t)) exps
712 val tables = ListUtil.mapConcat (fn (x, xts) => 712 val tables = ListUtil.mapConcat (fn (x, xts) =>
713 map (fn (x', t) => ("__lwf_" ^ x ^ ".__lwf_" ^ x', t)) xts) 713 map (fn (x', t) => ("__uwf_" ^ x ^ ".__uwf_" ^ x', t)) xts)
714 tables 714 tables
715 715
716 val outputs = exps @ tables 716 val outputs = exps @ tables
717 in 717 in
718 box [string "({", 718 box [string "({",
719 newline, 719 newline,
720 string "PGconn *conn = lw_get_db(ctx);", 720 string "PGconn *conn = uw_get_db(ctx);",
721 newline, 721 newline,
722 case prepared of 722 case prepared of
723 NONE => box [string "char *query = ", 723 NONE => box [string "char *query = ",
724 p_exp env query, 724 p_exp env query,
725 string ";", 725 string ";",
764 string ";", 764 string ";",
765 newline, 765 newline,
766 string "PGresult *res = ", 766 string "PGresult *res = ",
767 case prepared of 767 case prepared of
768 NONE => string "PQexecParams(conn, query, 0, NULL, NULL, NULL, NULL, 0);" 768 NONE => string "PQexecParams(conn, query, 0, NULL, NULL, NULL, NULL, 0);"
769 | SOME n => box [string "PQexecPrepared(conn, \"lw", 769 | SOME n => box [string "PQexecPrepared(conn, \"uw",
770 string (Int.toString n), 770 string (Int.toString n),
771 string "\", ", 771 string "\", ",
772 string (Int.toString (length (getPargs query))), 772 string (Int.toString (length (getPargs query))),
773 string ", paramValues, NULL, NULL, 0);"], 773 string ", paramValues, NULL, NULL, 0);"],
774 newline, 774 newline,
775 newline, 775 newline,
776 776
777 string "if (res == NULL) lw_error(ctx, FATAL, \"Out of memory allocating query result.\");", 777 string "if (res == NULL) uw_error(ctx, FATAL, \"Out of memory allocating query result.\");",
778 newline, 778 newline,
779 newline, 779 newline,
780 780
781 string "if (PQresultStatus(res) != PGRES_TUPLES_OK) {", 781 string "if (PQresultStatus(res) != PGRES_TUPLES_OK) {",
782 newline, 782 newline,
783 box [string "PQclear(res);", 783 box [string "PQclear(res);",
784 newline, 784 newline,
785 string "lw_error(ctx, FATAL, \"", 785 string "uw_error(ctx, FATAL, \"",
786 string (ErrorMsg.spanToString loc), 786 string (ErrorMsg.spanToString loc),
787 string ": Query failed:\\n%s\\n%s\", ", 787 string ": Query failed:\\n%s\\n%s\", ",
788 case prepared of 788 case prepared of
789 NONE => string "query" 789 NONE => string "query"
790 | SOME _ => p_exp env query, 790 | SOME _ => p_exp env query,
798 newline, 798 newline,
799 string "for (i = 0; i < n; ++i) {", 799 string "for (i = 0; i < n; ++i) {",
800 newline, 800 newline,
801 box [string "struct", 801 box [string "struct",
802 space, 802 space,
803 string "__lws_", 803 string "__uws_",
804 string (Int.toString rnum), 804 string (Int.toString rnum),
805 space, 805 space,
806 string "__lwr_r_", 806 string "__uwr_r_",
807 string (Int.toString (E.countERels env)), 807 string (Int.toString (E.countERels env)),
808 string ";", 808 string ";",
809 newline, 809 newline,
810 p_typ env state, 810 p_typ env state,
811 space, 811 space,
812 string "__lwr_acc_", 812 string "__uwr_acc_",
813 string (Int.toString (E.countERels env + 1)), 813 string (Int.toString (E.countERels env + 1)),
814 space, 814 space,
815 string "=", 815 string "=",
816 space, 816 space,
817 string "acc;", 817 string "acc;",
818 newline, 818 newline,
819 newline, 819 newline,
820 820
821 p_list_sepi (box []) (fn i => 821 p_list_sepi (box []) (fn i =>
822 fn (proj, t) => 822 fn (proj, t) =>
823 box [string "__lwr_r_", 823 box [string "__uwr_r_",
824 string (Int.toString (E.countERels env)), 824 string (Int.toString (E.countERels env)),
825 string ".", 825 string ".",
826 string proj, 826 string proj,
827 space, 827 space,
828 string "=", 828 string "=",
858 end 858 end
859 859
860 | EDml {dml, prepared} => 860 | EDml {dml, prepared} =>
861 box [string "({", 861 box [string "({",
862 newline, 862 newline,
863 string "PGconn *conn = lw_get_db(ctx);", 863 string "PGconn *conn = uw_get_db(ctx);",
864 newline, 864 newline,
865 case prepared of 865 case prepared of
866 NONE => box [string "char *dml = ", 866 NONE => box [string "char *dml = ",
867 p_exp env dml, 867 p_exp env dml,
868 string ";", 868 string ";",
898 newline, 898 newline,
899 newline, 899 newline,
900 string "PGresult *res = ", 900 string "PGresult *res = ",
901 case prepared of 901 case prepared of
902 NONE => string "PQexecParams(conn, dml, 0, NULL, NULL, NULL, NULL, 0);" 902 NONE => string "PQexecParams(conn, dml, 0, NULL, NULL, NULL, NULL, 0);"
903 | SOME n => box [string "PQexecPrepared(conn, \"lw", 903 | SOME n => box [string "PQexecPrepared(conn, \"uw",
904 string (Int.toString n), 904 string (Int.toString n),
905 string "\", ", 905 string "\", ",
906 string (Int.toString (length (getPargs dml))), 906 string (Int.toString (length (getPargs dml))),
907 string ", paramValues, NULL, NULL, 0);"], 907 string ", paramValues, NULL, NULL, 0);"],
908 newline, 908 newline,
909 newline, 909 newline,
910 910
911 string "if (res == NULL) lw_error(ctx, FATAL, \"Out of memory allocating DML result.\");", 911 string "if (res == NULL) uw_error(ctx, FATAL, \"Out of memory allocating DML result.\");",
912 newline, 912 newline,
913 newline, 913 newline,
914 914
915 string "if (PQresultStatus(res) != PGRES_COMMAND_OK) {", 915 string "if (PQresultStatus(res) != PGRES_COMMAND_OK) {",
916 newline, 916 newline,
917 box [string "PQclear(res);", 917 box [string "PQclear(res);",
918 newline, 918 newline,
919 string "lw_error(ctx, FATAL, \"", 919 string "uw_error(ctx, FATAL, \"",
920 string (ErrorMsg.spanToString loc), 920 string (ErrorMsg.spanToString loc),
921 string ": DML failed:\\n%s\\n%s\", ", 921 string ": DML failed:\\n%s\\n%s\", ",
922 case prepared of 922 case prepared of
923 NONE => string "dml" 923 NONE => string "dml"
924 | SOME _ => p_exp env dml, 924 | SOME _ => p_exp env dml,
928 newline, 928 newline,
929 newline, 929 newline,
930 930
931 string "PQclear(res);", 931 string "PQclear(res);",
932 newline, 932 newline,
933 string "lw_unit_v;", 933 string "uw_unit_v;",
934 newline, 934 newline,
935 string "})"] 935 string "})"]
936 936
937 and p_exp env = p_exp' false env 937 and p_exp env = p_exp' false env
938 938
943 in 943 in
944 box [string "static", 944 box [string "static",
945 space, 945 space,
946 p_typ env ran, 946 p_typ env ran,
947 space, 947 space,
948 string ("__lwn_" ^ fx ^ "_" ^ Int.toString n), 948 string ("__uwn_" ^ fx ^ "_" ^ Int.toString n),
949 string "(", 949 string "(",
950 p_list_sep (box [string ",", space]) (fn x => x) 950 p_list_sep (box [string ",", space]) (fn x => x)
951 (string "lw_context ctx" :: ListUtil.mapi (fn (i, (_, dom)) => 951 (string "uw_context ctx" :: ListUtil.mapi (fn (i, (_, dom)) =>
952 box [p_typ env dom, 952 box [p_typ env dom,
953 space, 953 space,
954 p_rel env' (nargs - i - 1)]) args), 954 p_rel env' (nargs - i - 1)]) args),
955 string ")", 955 string ")",
956 space, 956 space,
969 let 969 let
970 val env = E.declBinds env dAll 970 val env = E.declBinds env dAll
971 in 971 in
972 box [string "struct", 972 box [string "struct",
973 space, 973 space,
974 string ("__lws_" ^ Int.toString n), 974 string ("__uws_" ^ Int.toString n),
975 space, 975 space,
976 string "{", 976 string "{",
977 newline, 977 newline,
978 p_list_sep (box []) (fn (x, t) => box [p_typ env t, 978 p_list_sep (box []) (fn (x, t) => box [p_typ env t,
979 space, 979 space,
980 string "__lwf_", 980 string "__uwf_",
981 string x, 981 string x,
982 string ";", 982 string ";",
983 newline]) xts, 983 newline]) xts,
984 string "};"] 984 string "};"]
985 end 985 end
986 | DDatatype (Enum, x, n, xncs) => 986 | DDatatype (Enum, x, n, xncs) =>
987 box [string "enum", 987 box [string "enum",
988 space, 988 space,
989 string ("__lwe_" ^ x ^ "_" ^ Int.toString n), 989 string ("__uwe_" ^ x ^ "_" ^ Int.toString n),
990 space, 990 space,
991 string "{", 991 string "{",
992 space, 992 space,
993 p_list_sep (box [string ",", space]) (fn (x, n, _) => string ("__lwc_" ^ x ^ "_" ^ Int.toString n)) xncs, 993 p_list_sep (box [string ",", space]) (fn (x, n, _) => string ("__uwc_" ^ x ^ "_" ^ Int.toString n)) xncs,
994 space, 994 space,
995 string "};"] 995 string "};"]
996 | DDatatype (Option, _, _, _) => box [] 996 | DDatatype (Option, _, _, _) => box []
997 | DDatatype (Default, x, n, xncs) => 997 | DDatatype (Default, x, n, xncs) =>
998 let 998 let
999 val xncsArgs = List.mapPartial (fn (x, n, NONE) => NONE 999 val xncsArgs = List.mapPartial (fn (x, n, NONE) => NONE
1000 | (x, n, SOME t) => SOME (x, n, t)) xncs 1000 | (x, n, SOME t) => SOME (x, n, t)) xncs
1001 in 1001 in
1002 box [string "enum", 1002 box [string "enum",
1003 space, 1003 space,
1004 string ("__lwe_" ^ x ^ "_" ^ Int.toString n), 1004 string ("__uwe_" ^ x ^ "_" ^ Int.toString n),
1005 space, 1005 space,
1006 string "{", 1006 string "{",
1007 space, 1007 space,
1008 p_list_sep (box [string ",", space]) (fn (x, n, _) => string ("__lwc_" ^ x ^ "_" ^ Int.toString n)) xncs, 1008 p_list_sep (box [string ",", space]) (fn (x, n, _) => string ("__uwc_" ^ x ^ "_" ^ Int.toString n)) xncs,
1009 space, 1009 space,
1010 string "};", 1010 string "};",
1011 newline, 1011 newline,
1012 newline, 1012 newline,
1013 string "struct", 1013 string "struct",
1014 space, 1014 space,
1015 string ("__lwd_" ^ x ^ "_" ^ Int.toString n), 1015 string ("__uwd_" ^ x ^ "_" ^ Int.toString n),
1016 space, 1016 space,
1017 string "{", 1017 string "{",
1018 newline, 1018 newline,
1019 string "enum", 1019 string "enum",
1020 space, 1020 space,
1021 string ("__lwe_" ^ x ^ "_" ^ Int.toString n), 1021 string ("__uwe_" ^ x ^ "_" ^ Int.toString n),
1022 space, 1022 space,
1023 string "tag;", 1023 string "tag;",
1024 newline, 1024 newline,
1025 box (case xncsArgs of 1025 box (case xncsArgs of
1026 [] => [] 1026 [] => []
1028 space, 1028 space,
1029 string "{", 1029 string "{",
1030 newline, 1030 newline,
1031 p_list_sep newline (fn (x, n, t) => box [p_typ env t, 1031 p_list_sep newline (fn (x, n, t) => box [p_typ env t,
1032 space, 1032 space,
1033 string ("lw_" ^ x), 1033 string ("uw_" ^ x),
1034 string ";"]) xncsArgs, 1034 string ";"]) xncsArgs,
1035 newline, 1035 newline,
1036 string "}", 1036 string "}",
1037 space, 1037 space,
1038 string "data;", 1038 string "data;",
1043 | DDatatypeForward _ => box [] 1043 | DDatatypeForward _ => box []
1044 1044
1045 | DVal (x, n, t, e) => 1045 | DVal (x, n, t, e) =>
1046 box [p_typ env t, 1046 box [p_typ env t,
1047 space, 1047 space,
1048 string ("__lwn_" ^ x ^ "_" ^ Int.toString n), 1048 string ("__uwn_" ^ x ^ "_" ^ Int.toString n),
1049 space, 1049 space,
1050 string "=", 1050 string "=",
1051 space, 1051 space,
1052 p_exp env e, 1052 p_exp env e,
1053 string ";"] 1053 string ";"]
1059 box [p_list_sep newline (fn (fx, n, args, ran, _) => 1059 box [p_list_sep newline (fn (fx, n, args, ran, _) =>
1060 box [string "static", 1060 box [string "static",
1061 space, 1061 space,
1062 p_typ env ran, 1062 p_typ env ran,
1063 space, 1063 space,
1064 string ("__lwn_" ^ fx ^ "_" ^ Int.toString n), 1064 string ("__uwn_" ^ fx ^ "_" ^ Int.toString n),
1065 string "(lw_context,", 1065 string "(uw_context,",
1066 space, 1066 space,
1067 p_list_sep (box [string ",", space]) 1067 p_list_sep (box [string ",", space])
1068 (fn (_, dom) => p_typ env dom) args, 1068 (fn (_, dom) => p_typ env dom) args,
1069 string ");"]) vis, 1069 string ");"]) vis,
1070 newline, 1070 newline,
1073 end 1073 end
1074 | DTable (x, _) => box [string "/* SQL table ", 1074 | DTable (x, _) => box [string "/* SQL table ",
1075 string x, 1075 string x,
1076 string " */", 1076 string " */",
1077 newline] 1077 newline]
1078 | DDatabase s => box [string "static void lw_db_validate(lw_context);", 1078 | DDatabase s => box [string "static void uw_db_validate(uw_context);",
1079 newline, 1079 newline,
1080 string "static void lw_db_prepare(lw_context);", 1080 string "static void uw_db_prepare(uw_context);",
1081 newline, 1081 newline,
1082 newline, 1082 newline,
1083 string "void lw_db_init(lw_context ctx) {", 1083 string "void uw_db_init(uw_context ctx) {",
1084 newline, 1084 newline,
1085 string "PGconn *conn = PQconnectdb(\"", 1085 string "PGconn *conn = PQconnectdb(\"",
1086 string (String.toString s), 1086 string (String.toString s),
1087 string "\");", 1087 string "\");",
1088 newline, 1088 newline,
1089 string "if (conn == NULL) lw_error(ctx, BOUNDED_RETRY, ", 1089 string "if (conn == NULL) uw_error(ctx, BOUNDED_RETRY, ",
1090 string "\"libpq can't allocate a connection.\");", 1090 string "\"libpq can't allocate a connection.\");",
1091 newline, 1091 newline,
1092 string "if (PQstatus(conn) != CONNECTION_OK) {", 1092 string "if (PQstatus(conn) != CONNECTION_OK) {",
1093 newline, 1093 newline,
1094 box [string "char msg[1024];", 1094 box [string "char msg[1024];",
1097 newline, 1097 newline,
1098 string "msg[1023] = 0;", 1098 string "msg[1023] = 0;",
1099 newline, 1099 newline,
1100 string "PQfinish(conn);", 1100 string "PQfinish(conn);",
1101 newline, 1101 newline,
1102 string "lw_error(ctx, BOUNDED_RETRY, ", 1102 string "uw_error(ctx, BOUNDED_RETRY, ",
1103 string "\"Connection to Postgres server failed: %s\", msg);"], 1103 string "\"Connection to Postgres server failed: %s\", msg);"],
1104 newline, 1104 newline,
1105 string "}", 1105 string "}",
1106 newline, 1106 newline,
1107 string "lw_set_db(ctx, conn);", 1107 string "uw_set_db(ctx, conn);",
1108 newline, 1108 newline,
1109 string "lw_db_validate(ctx);", 1109 string "uw_db_validate(ctx);",
1110 newline, 1110 newline,
1111 string "lw_db_prepare(ctx);", 1111 string "uw_db_prepare(ctx);",
1112 newline, 1112 newline,
1113 string "}", 1113 string "}",
1114 newline, 1114 newline,
1115 newline, 1115 newline,
1116 string "void lw_db_close(lw_context ctx) {", 1116 string "void uw_db_close(uw_context ctx) {",
1117 newline, 1117 newline,
1118 string "PQfinish(lw_get_db(ctx));", 1118 string "PQfinish(uw_get_db(ctx));",
1119 newline, 1119 newline,
1120 string "}", 1120 string "}",
1121 newline] 1121 newline]
1122 1122
1123 | DPreparedStatements ss => 1123 | DPreparedStatements ss =>
1124 box [string "static void lw_db_prepare(lw_context ctx) {", 1124 box [string "static void uw_db_prepare(uw_context ctx) {",
1125 newline, 1125 newline,
1126 string "PGconn *conn = lw_get_db(ctx);", 1126 string "PGconn *conn = uw_get_db(ctx);",
1127 newline, 1127 newline,
1128 string "PGresult *res;", 1128 string "PGresult *res;",
1129 newline, 1129 newline,
1130 newline, 1130 newline,
1131 1131
1132 p_list_sepi newline (fn i => fn (s, n) => 1132 p_list_sepi newline (fn i => fn (s, n) =>
1133 box [string "res = PQprepare(conn, \"lw", 1133 box [string "res = PQprepare(conn, \"uw",
1134 string (Int.toString i), 1134 string (Int.toString i),
1135 string "\", \"", 1135 string "\", \"",
1136 string (String.toString s), 1136 string (String.toString s),
1137 string "\", ", 1137 string "\", ",
1138 string (Int.toString n), 1138 string (Int.toString n),
1148 newline, 1148 newline,
1149 string "PQclear(res);", 1149 string "PQclear(res);",
1150 newline, 1150 newline,
1151 string "PQfinish(conn);", 1151 string "PQfinish(conn);",
1152 newline, 1152 newline,
1153 string "lw_error(ctx, FATAL, \"Unable to create prepared statement:\\n", 1153 string "uw_error(ctx, FATAL, \"Unable to create prepared statement:\\n",
1154 string (String.toString s), 1154 string (String.toString s),
1155 string "\\n%s\", msg);", 1155 string "\\n%s\", msg);",
1156 newline], 1156 newline],
1157 string "}", 1157 string "}",
1158 newline, 1158 newline,
1312 else 1312 else
1313 str (Char.toUpper (String.sub (s, 0))) ^ String.extract (s, 1, NONE) 1313 str (Char.toUpper (String.sub (s, 0))) ^ String.extract (s, 1, NONE)
1314 1314
1315 fun unurlify (t, loc) = 1315 fun unurlify (t, loc) =
1316 case t of 1316 case t of
1317 TFfi (m, t) => string ("lw_" ^ m ^ "_unurlify" ^ capitalize t ^ "(ctx, &request)") 1317 TFfi (m, t) => string ("uw_" ^ m ^ "_unurlify" ^ capitalize t ^ "(ctx, &request)")
1318 1318
1319 | TRecord 0 => string "lw_unit_v" 1319 | TRecord 0 => string "uw_unit_v"
1320 | TRecord i => 1320 | TRecord i =>
1321 let 1321 let
1322 val xts = E.lookupStruct env i 1322 val xts = E.lookupStruct env i
1323 in 1323 in
1324 box [string "({", 1324 box [string "({",
1333 unurlify t, 1333 unurlify t,
1334 string ";", 1334 string ";",
1335 newline]) xts), 1335 newline]) xts),
1336 string "struct", 1336 string "struct",
1337 space, 1337 space,
1338 string "__lws_", 1338 string "__uws_",
1339 string (Int.toString i), 1339 string (Int.toString i),
1340 space, 1340 space,
1341 string "tmp", 1341 string "tmp",
1342 space, 1342 space,
1343 string "=", 1343 string "=",
1357 let 1357 let
1358 val (x, xncs) = E.lookupDatatype env i 1358 val (x, xncs) = E.lookupDatatype env i
1359 1359
1360 fun doEm xncs = 1360 fun doEm xncs =
1361 case xncs of 1361 case xncs of
1362 [] => string ("(lw_error(ctx, FATAL, \"Error unurlifying datatype " ^ x ^ "\"), (enum __lwe_" 1362 [] => string ("(uw_error(ctx, FATAL, \"Error unurlifying datatype " ^ x ^ "\"), (enum __uwe_"
1363 ^ x ^ "_" ^ Int.toString i ^ ")0)") 1363 ^ x ^ "_" ^ Int.toString i ^ ")0)")
1364 | (x', n, to) :: rest => 1364 | (x', n, to) :: rest =>
1365 box [string "((!strncmp(request, \"", 1365 box [string "((!strncmp(request, \"",
1366 string x', 1366 string x',
1367 string "\", ", 1367 string "\", ",
1368 string (Int.toString (size x')), 1368 string (Int.toString (size x')),
1369 string ") && (request[", 1369 string ") && (request[",
1370 string (Int.toString (size x')), 1370 string (Int.toString (size x')),
1371 string "] == 0 || request[", 1371 string "] == 0 || request[",
1372 string (Int.toString (size x')), 1372 string (Int.toString (size x')),
1373 string ("] == '/')) ? __lwc_" ^ x' ^ "_" ^ Int.toString n), 1373 string ("] == '/')) ? __uwc_" ^ x' ^ "_" ^ Int.toString n),
1374 space, 1374 space,
1375 string ":", 1375 string ":",
1376 space, 1376 space,
1377 doEm rest, 1377 doEm rest,
1378 string ")"] 1378 string ")"]
1432 space, 1432 space,
1433 string "*tmp", 1433 string "*tmp",
1434 space, 1434 space,
1435 string "=", 1435 string "=",
1436 space, 1436 space,
1437 string "lw_malloc(ctx, sizeof(", 1437 string "uw_malloc(ctx, sizeof(",
1438 p_typ env t, 1438 p_typ env t,
1439 string "));", 1439 string "));",
1440 newline, 1440 newline,
1441 string "*tmp", 1441 string "*tmp",
1442 space, 1442 space,
1450 string "})"], 1450 string "})"],
1451 string ")", 1451 string ")",
1452 newline, 1452 newline,
1453 string ":", 1453 string ":",
1454 space, 1454 space,
1455 string ("(lw_error(ctx, FATAL, \"Error unurlifying datatype " ^ x ^ "\"), NULL))))")] 1455 string ("(uw_error(ctx, FATAL, \"Error unurlifying datatype " ^ x ^ "\"), NULL))))")]
1456 end 1456 end
1457 1457
1458 | TDatatype (Default, i, _) => 1458 | TDatatype (Default, i, _) =>
1459 let 1459 let
1460 val (x, xncs) = E.lookupDatatype env i 1460 val (x, xncs) = E.lookupDatatype env i
1461 1461
1462 fun doEm xncs = 1462 fun doEm xncs =
1463 case xncs of 1463 case xncs of
1464 [] => string ("(lw_error(ctx, FATAL, \"Error unurlifying datatype " ^ x ^ "\"), NULL)") 1464 [] => string ("(uw_error(ctx, FATAL, \"Error unurlifying datatype " ^ x ^ "\"), NULL)")
1465 | (x', n, to) :: rest => 1465 | (x', n, to) :: rest =>
1466 box [string "((!strncmp(request, \"", 1466 box [string "((!strncmp(request, \"",
1467 string x', 1467 string x',
1468 string "\", ", 1468 string "\", ",
1469 string (Int.toString (size x')), 1469 string (Int.toString (size x')),
1473 string (Int.toString (size x')), 1473 string (Int.toString (size x')),
1474 string "] == '/')) ? ({", 1474 string "] == '/')) ? ({",
1475 newline, 1475 newline,
1476 string "struct", 1476 string "struct",
1477 space, 1477 space,
1478 string ("__lwd_" ^ x ^ "_" ^ Int.toString i), 1478 string ("__uwd_" ^ x ^ "_" ^ Int.toString i),
1479 space, 1479 space,
1480 string "*tmp = lw_malloc(ctx, sizeof(struct __lwd_", 1480 string "*tmp = uw_malloc(ctx, sizeof(struct __uwd_",
1481 string x, 1481 string x,
1482 string "_", 1482 string "_",
1483 string (Int.toString i), 1483 string (Int.toString i),
1484 string "));", 1484 string "));",
1485 newline, 1485 newline,
1486 string "tmp->tag", 1486 string "tmp->tag",
1487 space, 1487 space,
1488 string "=", 1488 string "=",
1489 space, 1489 space,
1490 string ("__lwc_" ^ x' ^ "_" ^ Int.toString n), 1490 string ("__uwc_" ^ x' ^ "_" ^ Int.toString n),
1491 string ";", 1491 string ";",
1492 newline, 1492 newline,
1493 string "request", 1493 string "request",
1494 space, 1494 space,
1495 string "+=", 1495 string "+=",
1499 newline, 1499 newline,
1500 string "if (request[0] == '/') ++request;", 1500 string "if (request[0] == '/') ++request;",
1501 newline, 1501 newline,
1502 case to of 1502 case to of
1503 NONE => box [] 1503 NONE => box []
1504 | SOME t => box [string "tmp->data.lw_", 1504 | SOME t => box [string "tmp->data.uw_",
1505 string x', 1505 string x',
1506 space, 1506 space,
1507 string "=", 1507 string "=",
1508 space, 1508 space,
1509 unurlify t, 1509 unurlify t,
1537 val xts = E.lookupStruct env i 1537 val xts = E.lookupStruct env i
1538 in 1538 in
1539 (List.take (ts, length ts - 2), 1539 (List.take (ts, length ts - 2),
1540 box [box (map (fn (x, t) => box [p_typ env t, 1540 box [box (map (fn (x, t) => box [p_typ env t,
1541 space, 1541 space,
1542 string "lw_input_", 1542 string "uw_input_",
1543 string x, 1543 string x,
1544 string ";", 1544 string ";",
1545 newline]) xts), 1545 newline]) xts),
1546 newline, 1546 newline,
1547 box (map (fn (x, t) => 1547 box (map (fn (x, t) =>
1552 1552
1553 val f = case t of 1553 val f = case t of
1554 (TFfi ("Basis", "bool"), _) => "optional_" 1554 (TFfi ("Basis", "bool"), _) => "optional_"
1555 | _ => "" 1555 | _ => ""
1556 in 1556 in
1557 box [string "request = lw_get_", 1557 box [string "request = uw_get_",
1558 string f, 1558 string f,
1559 string "input(ctx, ", 1559 string "input(ctx, ",
1560 string (Int.toString n), 1560 string (Int.toString n),
1561 string ");", 1561 string ");",
1562 newline, 1562 newline,
1568 newline, 1568 newline,
1569 string "exit(1);"], 1569 string "exit(1);"],
1570 newline, 1570 newline,
1571 string "}", 1571 string "}",
1572 newline, 1572 newline,
1573 string "lw_input_", 1573 string "uw_input_",
1574 string x, 1574 string x,
1575 space, 1575 space,
1576 string "=", 1576 string "=",
1577 space, 1577 space,
1578 unurlify t, 1578 unurlify t,
1579 string ";", 1579 string ";",
1580 newline] 1580 newline]
1581 end) xts), 1581 end) xts),
1582 string "struct __lws_", 1582 string "struct __uws_",
1583 string (Int.toString i), 1583 string (Int.toString i),
1584 space, 1584 space,
1585 string "lw_inputs", 1585 string "uw_inputs",
1586 space, 1586 space,
1587 string "= {", 1587 string "= {",
1588 newline, 1588 newline,
1589 box (map (fn (x, _) => box [string "lw_input_", 1589 box (map (fn (x, _) => box [string "uw_input_",
1590 string x, 1590 string x,
1591 string ",", 1591 string ",",
1592 newline]) xts), 1592 newline]) xts),
1593 string "};", 1593 string "};",
1594 newline], 1594 newline],
1595 box [string ",", 1595 box [string ",",
1596 space, 1596 space,
1597 string "lw_inputs"]) 1597 string "uw_inputs"])
1598 end 1598 end
1599 1599
1600 | _ => raise Fail "CjrPrint: Last argument to an action isn't a record" 1600 | _ => raise Fail "CjrPrint: Last argument to an action isn't a record"
1601 in 1601 in
1602 box [string "if (!strncmp(request, \"", 1602 box [string "if (!strncmp(request, \"",
1633 p_list_sep (box [string ",", space]) 1633 p_list_sep (box [string ",", space])
1634 (fn x => x) 1634 (fn x => x)
1635 (string "ctx" 1635 (string "ctx"
1636 :: ListUtil.mapi (fn (i, _) => string ("arg" ^ Int.toString i)) ts), 1636 :: ListUtil.mapi (fn (i, _) => string ("arg" ^ Int.toString i)) ts),
1637 inputsVar, 1637 inputsVar,
1638 string ", lw_unit_v);", 1638 string ", uw_unit_v);",
1639 newline, 1639 newline,
1640 string "return;", 1640 string "return;",
1641 newline, 1641 newline,
1642 string "}", 1642 string "}",
1643 newline, 1643 newline,
1649 1649
1650 val tables = List.mapPartial (fn (DTable (s, xts), _) => SOME (s, xts) 1650 val tables = List.mapPartial (fn (DTable (s, xts), _) => SOME (s, xts)
1651 | _ => NONE) ds 1651 | _ => NONE) ds
1652 1652
1653 val validate = 1653 val validate =
1654 box [string "static void lw_db_validate(lw_context ctx) {", 1654 box [string "static void uw_db_validate(uw_context ctx) {",
1655 newline, 1655 newline,
1656 string "PGconn *conn = lw_get_db(ctx);", 1656 string "PGconn *conn = uw_get_db(ctx);",
1657 newline, 1657 newline,
1658 string "PGresult *res;", 1658 string "PGresult *res;",
1659 newline, 1659 newline,
1660 newline, 1660 newline,
1661 p_list_sep newline 1661 p_list_sep newline
1667 val q' = String.concat ["SELECT COUNT(*) FROM pg_attribute WHERE attrelid = (SELECT oid FROM pg_class WHERE relname = '", 1667 val q' = String.concat ["SELECT COUNT(*) FROM pg_attribute WHERE attrelid = (SELECT oid FROM pg_class WHERE relname = '",
1668 s, 1668 s,
1669 "') AND (", 1669 "') AND (",
1670 String.concatWith " OR " 1670 String.concatWith " OR "
1671 (map (fn (x, t) => 1671 (map (fn (x, t) =>
1672 String.concat ["(attname = 'lw_", 1672 String.concat ["(attname = 'uw_",
1673 CharVector.map 1673 CharVector.map
1674 Char.toLower x, 1674 Char.toLower x,
1675 "' AND atttypid = (SELECT oid FROM pg_type", 1675 "' AND atttypid = (SELECT oid FROM pg_type",
1676 " WHERE typname = '", 1676 " WHERE typname = '",
1677 p_sqltype' env t, 1677 p_sqltype' env t,
1689 newline, 1689 newline,
1690 string "if (res == NULL) {", 1690 string "if (res == NULL) {",
1691 newline, 1691 newline,
1692 box [string "PQfinish(conn);", 1692 box [string "PQfinish(conn);",
1693 newline, 1693 newline,
1694 string "lw_error(ctx, FATAL, \"Out of memory allocating query result.\");", 1694 string "uw_error(ctx, FATAL, \"Out of memory allocating query result.\");",
1695 newline], 1695 newline],
1696 string "}", 1696 string "}",
1697 newline, 1697 newline,
1698 newline, 1698 newline,
1699 string "if (PQresultStatus(res) != PGRES_TUPLES_OK) {", 1699 string "if (PQresultStatus(res) != PGRES_TUPLES_OK) {",
1706 newline, 1706 newline,
1707 string "PQclear(res);", 1707 string "PQclear(res);",
1708 newline, 1708 newline,
1709 string "PQfinish(conn);", 1709 string "PQfinish(conn);",
1710 newline, 1710 newline,
1711 string "lw_error(ctx, FATAL, \"Query failed:\\n", 1711 string "uw_error(ctx, FATAL, \"Query failed:\\n",
1712 string q, 1712 string q,
1713 string "\\n%s\", msg);", 1713 string "\\n%s\", msg);",
1714 newline], 1714 newline],
1715 string "}", 1715 string "}",
1716 newline, 1716 newline,
1719 newline, 1719 newline,
1720 box [string "PQclear(res);", 1720 box [string "PQclear(res);",
1721 newline, 1721 newline,
1722 string "PQfinish(conn);", 1722 string "PQfinish(conn);",
1723 newline, 1723 newline,
1724 string "lw_error(ctx, FATAL, \"Table '", 1724 string "uw_error(ctx, FATAL, \"Table '",
1725 string s, 1725 string s,
1726 string "' does not exist.\");", 1726 string "' does not exist.\");",
1727 newline], 1727 newline],
1728 string "}", 1728 string "}",
1729 newline, 1729 newline,
1738 newline, 1738 newline,
1739 string "if (res == NULL) {", 1739 string "if (res == NULL) {",
1740 newline, 1740 newline,
1741 box [string "PQfinish(conn);", 1741 box [string "PQfinish(conn);",
1742 newline, 1742 newline,
1743 string "lw_error(ctx, FATAL, \"Out of memory allocating query result.\");", 1743 string "uw_error(ctx, FATAL, \"Out of memory allocating query result.\");",
1744 newline], 1744 newline],
1745 string "}", 1745 string "}",
1746 newline, 1746 newline,
1747 newline, 1747 newline,
1748 string "if (PQresultStatus(res) != PGRES_TUPLES_OK) {", 1748 string "if (PQresultStatus(res) != PGRES_TUPLES_OK) {",
1755 newline, 1755 newline,
1756 string "PQclear(res);", 1756 string "PQclear(res);",
1757 newline, 1757 newline,
1758 string "PQfinish(conn);", 1758 string "PQfinish(conn);",
1759 newline, 1759 newline,
1760 string "lw_error(ctx, FATAL, \"Query failed:\\n", 1760 string "uw_error(ctx, FATAL, \"Query failed:\\n",
1761 string q', 1761 string q',
1762 string "\\n%s\", msg);", 1762 string "\\n%s\", msg);",
1763 newline], 1763 newline],
1764 string "}", 1764 string "}",
1765 newline, 1765 newline,
1770 newline, 1770 newline,
1771 box [string "PQclear(res);", 1771 box [string "PQclear(res);",
1772 newline, 1772 newline,
1773 string "PQfinish(conn);", 1773 string "PQfinish(conn);",
1774 newline, 1774 newline,
1775 string "lw_error(ctx, FATAL, \"Table '", 1775 string "uw_error(ctx, FATAL, \"Table '",
1776 string s, 1776 string s,
1777 string "' has the wrong column types.\");", 1777 string "' has the wrong column types.\");",
1778 newline], 1778 newline],
1779 string "}", 1779 string "}",
1780 newline, 1780 newline,
1790 newline, 1790 newline,
1791 string "if (res == NULL) {", 1791 string "if (res == NULL) {",
1792 newline, 1792 newline,
1793 box [string "PQfinish(conn);", 1793 box [string "PQfinish(conn);",
1794 newline, 1794 newline,
1795 string "lw_error(ctx, FATAL, \"Out of memory allocating query result.\");", 1795 string "uw_error(ctx, FATAL, \"Out of memory allocating query result.\");",
1796 newline], 1796 newline],
1797 string "}", 1797 string "}",
1798 newline, 1798 newline,
1799 newline, 1799 newline,
1800 string "if (PQresultStatus(res) != PGRES_TUPLES_OK) {", 1800 string "if (PQresultStatus(res) != PGRES_TUPLES_OK) {",
1807 newline, 1807 newline,
1808 string "PQclear(res);", 1808 string "PQclear(res);",
1809 newline, 1809 newline,
1810 string "PQfinish(conn);", 1810 string "PQfinish(conn);",
1811 newline, 1811 newline,
1812 string "lw_error(ctx, FATAL, \"Query failed:\\n", 1812 string "uw_error(ctx, FATAL, \"Query failed:\\n",
1813 string q'', 1813 string q'',
1814 string "\\n%s\", msg);", 1814 string "\\n%s\", msg);",
1815 newline], 1815 newline],
1816 string "}", 1816 string "}",
1817 newline, 1817 newline,
1822 newline, 1822 newline,
1823 box [string "PQclear(res);", 1823 box [string "PQclear(res);",
1824 newline, 1824 newline,
1825 string "PQfinish(conn);", 1825 string "PQfinish(conn);",
1826 newline, 1826 newline,
1827 string "lw_error(ctx, FATAL, \"Table '", 1827 string "uw_error(ctx, FATAL, \"Table '",
1828 string s, 1828 string s,
1829 string "' has extra columns.\");", 1829 string "' has extra columns.\");",
1830 newline], 1830 newline],
1831 string "}", 1831 string "}",
1832 newline, 1832 newline,
1848 string "#include \"urweb.h\"", 1848 string "#include \"urweb.h\"",
1849 newline, 1849 newline,
1850 newline, 1850 newline,
1851 p_list_sep newline (fn x => x) pds, 1851 p_list_sep newline (fn x => x) pds,
1852 newline, 1852 newline,
1853 string "int lw_inputs_len = ", 1853 string "int uw_inputs_len = ",
1854 string (Int.toString (SM.foldl Int.max 0 fnums + 1)), 1854 string (Int.toString (SM.foldl Int.max 0 fnums + 1)),
1855 string ";", 1855 string ";",
1856 newline, 1856 newline,
1857 newline, 1857 newline,
1858 string "int lw_input_num(char *name) {", 1858 string "int uw_input_num(char *name) {",
1859 newline, 1859 newline,
1860 makeSwitch (fnums, 0), 1860 makeSwitch (fnums, 0),
1861 string "}", 1861 string "}",
1862 newline, 1862 newline,
1863 newline, 1863 newline,
1864 string "void lw_handle(lw_context ctx, char *request) {", 1864 string "void uw_handle(uw_context ctx, char *request) {",
1865 newline, 1865 newline,
1866 p_list_sep newline (fn x => x) pds', 1866 p_list_sep newline (fn x => x) pds',
1867 newline, 1867 newline,
1868 string "}", 1868 string "}",
1869 newline, 1869 newline,
1881 DTable (s, xts) => 1881 DTable (s, xts) =>
1882 box [string "CREATE TABLE ", 1882 box [string "CREATE TABLE ",
1883 string s, 1883 string s,
1884 string "(", 1884 string "(",
1885 p_list (fn (x, t) => 1885 p_list (fn (x, t) =>
1886 box [string "lw_", 1886 box [string "uw_",
1887 string (CharVector.map Char.toLower x), 1887 string (CharVector.map Char.toLower x),
1888 space, 1888 space,
1889 p_sqltype env t, 1889 p_sqltype env t,
1890 space, 1890 space,
1891 string "NOT", 1891 string "NOT",