summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--src/cjr.sml2
-rw-r--r--src/cjr_env.sml1
-rw-r--r--src/cjr_print.sml6
-rw-r--r--src/cjrize.sml11
-rw-r--r--src/mono.sml2
-rw-r--r--src/mono_env.sml1
-rw-r--r--src/mono_print.sml12
-rw-r--r--src/mono_shake.sml2
-rw-r--r--src/mono_util.sml2
-rw-r--r--src/monoize.sml22
10 files changed, 52 insertions, 9 deletions
diff --git a/src/cjr.sml b/src/cjr.sml
index 727874a9..4d6608ce 100644
--- a/src/cjr.sml
+++ b/src/cjr.sml
@@ -87,6 +87,8 @@ datatype decl' =
| DVal of string * int * typ * exp
| DFun of string * int * (string * typ) list * typ * exp
| DFunRec of (string * int * (string * typ) list * typ * exp) list
+
+ | DTable of string * (string * typ) list
| DDatabase of string
withtype decl = decl' located
diff --git a/src/cjr_env.sml b/src/cjr_env.sml
index 609bb699..482b93f6 100644
--- a/src/cjr_env.sml
+++ b/src/cjr_env.sml
@@ -162,6 +162,7 @@ fun declBinds env (d, loc) =
in
pushENamed env fx n t
end) env vis
+ | DTable _ => env
| DDatabase _ => env
diff --git a/src/cjr_print.sml b/src/cjr_print.sml
index fd534c4a..de8f21fc 100644
--- a/src/cjr_print.sml
+++ b/src/cjr_print.sml
@@ -688,8 +688,14 @@ fun p_decl env (dAll as (d, _) : decl) =
p_list_sep newline (p_fun env) vis,
newline]
end
+ | DTable (x, _) => box [string "/* SQL table ",
+ string x,
+ string " */",
+ newline]
| DDatabase s => box [string "void lw_db_init(lw_context ctx) {",
newline,
+ string "PGresult *res;",
+ newline,
string "PGconn *conn = PQconnectdb(\"",
string (String.toString s),
string "\");",
diff --git a/src/cjrize.sml b/src/cjrize.sml
index c4c77021..88fae6f0 100644
--- a/src/cjrize.sml
+++ b/src/cjrize.sml
@@ -423,6 +423,17 @@ fun cifyDecl ((d, loc), sm) =
(NONE, SOME (ek, "/" ^ s, n, ts), sm)
end
+ | L.DTable (s, xts) =>
+ let
+ val (xts, sm) = ListUtil.foldlMap (fn ((x, t), sm) =>
+ let
+ val (t, sm) = cifyTyp (t, sm)
+ in
+ ((x, t), sm)
+ end) sm xts
+ in
+ (SOME (L'.DTable (s, xts), loc), NONE, sm)
+ end
| L.DDatabase s => (SOME (L'.DDatabase s, loc), NONE, sm)
fun cjrize ds =
diff --git a/src/mono.sml b/src/mono.sml
index 3b6cc87e..cbe935c0 100644
--- a/src/mono.sml
+++ b/src/mono.sml
@@ -90,6 +90,8 @@ datatype decl' =
| DVal of string * int * typ * exp * string
| DValRec of (string * int * typ * exp * string) list
| DExport of Core.export_kind * string * int * typ list
+
+ | DTable of string * (string * typ) list
| DDatabase of string
withtype decl = decl' located
diff --git a/src/mono_env.sml b/src/mono_env.sml
index 7352400a..387e887e 100644
--- a/src/mono_env.sml
+++ b/src/mono_env.sml
@@ -107,6 +107,7 @@ fun declBinds env (d, loc) =
| DVal (x, n, t, e, s) => pushENamed env x n t (SOME e) s
| DValRec vis => foldl (fn ((x, n, t, e, s), env) => pushENamed env x n t NONE s) env vis
| DExport _ => env
+ | DTable _ => env
| DDatabase _ => env
fun patBinds env (p, loc) =
diff --git a/src/mono_print.sml b/src/mono_print.sml
index 450c5bee..3c090124 100644
--- a/src/mono_print.sml
+++ b/src/mono_print.sml
@@ -313,6 +313,18 @@ fun p_decl env (dAll as (d, _) : decl) =
p_typ env t,
string ")"]) ts]
+ | DTable (s, xts) => box [string "(* SQL table ",
+ string s,
+ space,
+ string ":",
+ space,
+ p_list (fn (x, t) => box [string x,
+ space,
+ string ":",
+ space,
+ p_typ env t]) xts,
+ space,
+ string "*)"]
| DDatabase s => box [string "database",
space,
string s]
diff --git a/src/mono_shake.sml b/src/mono_shake.sml
index 8276b4d6..dddb1d9a 100644
--- a/src/mono_shake.sml
+++ b/src/mono_shake.sml
@@ -54,6 +54,7 @@ fun shake file =
| ((DValRec vis, _), (cdef, edef)) =>
(cdef, foldl (fn ((_, n, t, e, _), edef) => IM.insert (edef, n, (t, e))) edef vis)
| ((DExport _, _), acc) => acc
+ | ((DTable _, _), acc) => acc
| ((DDatabase _, _), acc) => acc)
(IM.empty, IM.empty) file
@@ -108,6 +109,7 @@ fun shake file =
| (DVal (_, n, _, _, _), _) => IS.member (#exp s, n)
| (DValRec vis, _) => List.exists (fn (_, n, _, _, _) => IS.member (#exp s, n)) vis
| (DExport _, _) => true
+ | (DTable _, _) => true
| (DDatabase _, _) => true) file
end
diff --git a/src/mono_util.sml b/src/mono_util.sml
index 9dddb477..2b257641 100644
--- a/src/mono_util.sml
+++ b/src/mono_util.sml
@@ -342,6 +342,7 @@ fun mapfoldB {typ = fc, exp = fe, decl = fd, bind} =
S.map2 (ListUtil.mapfold mft ts,
fn ts' =>
(DExport (ek, s, n, ts'), loc))
+ | DTable _ => S.return2 dAll
| DDatabase _ => S.return2 dAll
and mfvi ctx (x, n, t, e, s) =
@@ -405,6 +406,7 @@ fun mapfoldB (all as {bind, ...}) =
| DValRec vis => foldl (fn ((x, n, t, e, s), ctx) =>
bind (ctx, NamedE (x, n, t, NONE, s))) ctx vis
| DExport _ => ctx
+ | DTable _ => ctx
| DDatabase _ => ctx
in
S.map2 (mff ctx' ds',
diff --git a/src/monoize.sml b/src/monoize.sml
index f3b34a54..0930d28b 100644
--- a/src/monoize.sml
+++ b/src/monoize.sml
@@ -1372,7 +1372,7 @@ fun monoDecl (env, fm) (all as (d, loc)) =
val env' = Env.declBinds env all
val d = (L'.DDatatype (x, n, map (fn (x, n, to) => (x, n, Option.map (monoType env') to)) xncs), loc)
in
- SOME (env', fm, d)
+ SOME (env', fm, [d])
end
| L.DDatatype _ => poly ()
| L.DVal (x, n, t, e, s) =>
@@ -1381,7 +1381,7 @@ fun monoDecl (env, fm) (all as (d, loc)) =
in
SOME (Env.pushENamed env x n t NONE s,
fm,
- (L'.DVal (x, n, monoType env t, e, s), loc))
+ [(L'.DVal (x, n, monoType env t, e, s), loc)])
end
| L.DValRec vis =>
let
@@ -1398,7 +1398,7 @@ fun monoDecl (env, fm) (all as (d, loc)) =
in
SOME (env,
fm,
- (L'.DValRec vis, loc))
+ [(L'.DValRec vis, loc)])
end
| L.DExport (ek, n) =>
let
@@ -1411,19 +1411,23 @@ fun monoDecl (env, fm) (all as (d, loc)) =
val ts = map (monoType env) (unwind t)
in
- SOME (env, fm, (L'.DExport (ek, s, n, ts), loc))
+ SOME (env, fm, [(L'.DExport (ek, s, n, ts), loc)])
end
- | L.DTable (x, n, _, s) =>
+ | L.DTable (x, n, (L.CRecord (_, xts), _), s) =>
let
val t = (L.CFfi ("Basis", "string"), loc)
val t' = (L'.TFfi ("Basis", "string"), loc)
val e = (L'.EPrim (Prim.String s), loc)
+
+ val xts = map (fn (x, t) => (monoName env x, monoType env t)) xts
in
SOME (Env.pushENamed env x n t NONE s,
fm,
- (L'.DVal (x, n, t', e, s), loc))
+ [(L'.DTable (s, xts), loc),
+ (L'.DVal (x, n, t', e, s), loc)])
end
- | L.DDatabase s => SOME (env, fm, (L'.DDatabase s, loc))
+ | L.DTable _ => poly ()
+ | L.DDatabase s => SOME (env, fm, [(L'.DDatabase s, loc)])
end
fun monoize env ds =
@@ -1431,10 +1435,10 @@ fun monoize env ds =
val (_, _, ds) = List.foldl (fn (d, (env, fm, ds)) =>
case monoDecl (env, fm) d of
NONE => (env, fm, ds)
- | SOME (env, fm, d) =>
+ | SOME (env, fm, ds') =>
(env,
Fm.enter fm,
- d :: Fm.decls fm @ ds))
+ ds' @ Fm.decls fm @ ds))
(env, Fm.empty (CoreUtil.File.maxName ds + 1), []) ds
in
rev ds
generated by cgit v1.2.3 (git 2.39.1) at 2024-06-09 06:27:43 +0000