From 4d83cf46590e7c48581612fd9fe6218b896b89b8 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Tue, 2 Sep 2008 13:09:54 -0400 Subject: Table declarations pushed to Cjr --- src/cjr.sml | 2 ++ src/cjr_env.sml | 1 + src/cjr_print.sml | 6 ++++++ src/cjrize.sml | 11 +++++++++++ src/mono.sml | 2 ++ src/mono_env.sml | 1 + src/mono_print.sml | 12 ++++++++++++ src/mono_shake.sml | 2 ++ src/mono_util.sml | 2 ++ src/monoize.sml | 22 +++++++++++++--------- 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,7 +688,13 @@ 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), 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 -- cgit v1.2.3