aboutsummaryrefslogtreecommitdiffhomepage
diff options
context:
space:
mode:
Diffstat
-rw-r--r--include/urweb.h1
-rw-r--r--src/c/urweb.c14
-rw-r--r--src/cjr_print.sml195
3 files changed, 133 insertions, 77 deletions
diff --git a/include/urweb.h b/include/urweb.h
index 641893de..b923e1b0 100644
--- a/include/urweb.h
+++ b/include/urweb.h
@@ -58,3 +58,4 @@ lw_Basis_string lw_Basis_unurlifyString(lw_context, char **);
lw_Basis_bool lw_Basis_unurlifyBool(lw_context, char **);
lw_Basis_string lw_Basis_strcat(lw_context, lw_Basis_string, lw_Basis_string);
+lw_Basis_string lw_Basis_strdup(lw_context, lw_Basis_string);
diff --git a/src/c/urweb.c b/src/c/urweb.c
index 10d474f4..f0e93e46 100644
--- a/src/c/urweb.c
+++ b/src/c/urweb.c
@@ -575,3 +575,17 @@ lw_Basis_string lw_Basis_strcat(lw_context ctx, lw_Basis_string s1, lw_Basis_str
return s;
}
+
+lw_Basis_string lw_Basis_strdup(lw_context ctx, lw_Basis_string s1) {
+ int len = strlen(s1) + 1;
+ char *s;
+
+ lw_check_heap(ctx, len);
+
+ s = ctx->heap_front;
+
+ strcpy(s, s1);
+ ctx->heap_front += len;
+
+ return s;
+}
diff --git a/src/cjr_print.sml b/src/cjr_print.sml
index a12e5bc1..938821be 100644
--- a/src/cjr_print.sml
+++ b/src/cjr_print.sml
@@ -321,6 +321,18 @@ fun patConInfo env pc =
"lw_" ^ m ^ "_" ^ con,
"lw_" ^ con)
+fun p_unsql env (tAll as (t, loc)) e =
+ case t of
+ TFfi ("Basis", "int") => box [string "*(lw_Basis_int *)", e]
+ | TFfi ("Basis", "float") => box [string "*(lw_Basis_float *)", e]
+ | TFfi ("Basis", "string") => box [string "lw_Basis_strdup(ctx, ", e, string ")"]
+ | TFfi ("Basis", "bool") => box [string "(*(int *)",
+ e,
+ string " ? lw_Basis_True : lw_Basis_False)"]
+ | _ => (ErrorMsg.errorAt loc "Don't know how to unmarshal type from SQL";
+ Print.eprefaces' [("Type", p_typ env tAll)];
+ string "ERROR")
+
fun p_exp' par env (e, loc) =
case e of
EPrim p => Prim.p_t_GCC p
@@ -549,86 +561,115 @@ fun p_exp' par env (e, loc) =
string "})"]
| EQuery {exps, tables, rnum, state, query, body, initial} =>
- box [string "({",
- newline,
- string "PGconn *conn = lw_get_db(ctx);",
- newline,
- string "char *query = ",
- p_exp env query,
- string ";",
- newline,
- string "int n, i;",
- newline,
- p_typ env state,
- space,
- string "acc",
- space,
- string "=",
- space,
- p_exp env initial,
- string ";",
- newline,
- string "PGresult *res = PQexecParams(conn, query, 0, NULL, NULL, NULL, NULL, 1);",
- newline,
- newline,
+ let
+ val exps = map (fn (x, t) => ("__lwf_" ^ x, t)) exps
+ val tables = ListUtil.mapConcat (fn (x, xts) =>
+ map (fn (x', t) => ("__lwf_" ^ x ^ ".__lwf_" ^ x', t)) xts)
+ tables
+
+ val outputs = exps @ tables
+ in
+ box [string "({",
+ newline,
+ string "PGconn *conn = lw_get_db(ctx);",
+ newline,
+ string "char *query = ",
+ p_exp env query,
+ string ";",
+ newline,
+ string "int n, i;",
+ newline,
+ p_typ env state,
+ space,
+ string "acc",
+ space,
+ string "=",
+ space,
+ p_exp env initial,
+ string ";",
+ newline,
+ string "PGresult *res = PQexecParams(conn, query, 0, NULL, NULL, NULL, NULL, 1);",
+ newline,
+ newline,
- string "if (res == NULL) lw_error(ctx, FATAL, \"Out of memory allocating query result.\");",
- newline,
- newline,
+ string "if (res == NULL) lw_error(ctx, FATAL, \"Out of memory allocating query result.\");",
+ newline,
+ newline,
- string "if (PQresultStatus(res) != PGRES_TUPLES_OK) {",
- newline,
- box [string "PQclear(res);",
- newline,
- string "lw_error(ctx, FATAL, \"",
- string (ErrorMsg.spanToString loc),
- string ": Query failed:\\n%s\\n%s\", query, PQerrorMessage(conn));",
- newline],
- string "}",
- newline,
- newline,
+ string "if (PQresultStatus(res) != PGRES_TUPLES_OK) {",
+ newline,
+ box [string "PQclear(res);",
+ newline,
+ string "lw_error(ctx, FATAL, \"",
+ string (ErrorMsg.spanToString loc),
+ string ": Query failed:\\n%s\\n%s\", query, PQerrorMessage(conn));",
+ newline],
+ string "}",
+ newline,
+ newline,
- string "n = PQntuples(res);",
- newline,
- string "for (i = 0; i < n; ++i) {",
- newline,
- box [string "struct",
- space,
- string "__lws_",
- string (Int.toString rnum),
- space,
- string "__lwr_r_",
- string (Int.toString (E.countERels env)),
- string ";",
- newline,
- p_typ env state,
- space,
- string "__lwr_acc_",
- string (Int.toString (E.countERels env + 1)),
- space,
- string "=",
- space,
- string "acc;",
- newline,
- newline,
- string "acc",
- space,
- string "=",
- space,
- p_exp (E.pushERel
- (E.pushERel env "r" (TRecord rnum, loc))
- "acc" state)
- body,
- string ";",
- newline],
- string "}",
- newline,
- newline,
- string "PQclear(res);",
- newline,
- string "acc;",
- newline,
- string "})"]
+ string "n = PQntuples(res);",
+ newline,
+ string "for (i = 0; i < n; ++i) {",
+ newline,
+ box [string "struct",
+ space,
+ string "__lws_",
+ string (Int.toString rnum),
+ space,
+ string "__lwr_r_",
+ string (Int.toString (E.countERels env)),
+ string ";",
+ newline,
+ p_typ env state,
+ space,
+ string "__lwr_acc_",
+ string (Int.toString (E.countERels env + 1)),
+ space,
+ string "=",
+ space,
+ string "acc;",
+ newline,
+ newline,
+
+ p_list_sepi (box []) (fn i =>
+ fn (proj, t) =>
+ box [string "__lwr_r_",
+ string (Int.toString (E.countERels env)),
+ string ".",
+ string proj,
+ space,
+ string "=",
+ space,
+ p_unsql env t
+ (box [string "PQgetvalue(res, i, ",
+ string (Int.toString i),
+ string ")"]),
+ string ";",
+ newline]) outputs,
+
+ newline,
+ newline,
+
+ string "acc",
+ space,
+ string "=",
+ space,
+ p_exp (E.pushERel
+ (E.pushERel env "r" (TRecord rnum, loc))
+ "acc" state)
+ body,
+ string ";",
+ newline],
+ string "}",
+ newline,
+ newline,
+ string "PQclear(res);",
+ newline,
+ string "acc;",
+ newline,
+ string "})"]
+ end
and p_exp env = p_exp' false env
generated by cgit v1.2.3 (git 2.39.1) at 2024-06-29 20:50:16 +0000