From 9f8b222f6667f4e7dec2105ea4f5c2abdfd29dc9 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Sun, 7 Sep 2008 13:29:01 -0400 Subject: pquery working with all four types of columns --- src/cjr.sml | 1 + src/cjr_print.sml | 1 + src/cjrize.sml | 6 ++++++ src/compiler.sml | 4 ++-- src/elab_env.sml | 35 +++++++++++++++++++++++------------ src/mono.sml | 1 + src/mono_print.sml | 1 + src/mono_reduce.sml | 1 + src/mono_util.sml | 4 ++++ src/monoize.sml | 8 ++++++++ src/prepare.sml | 1 + 11 files changed, 49 insertions(+), 14 deletions(-) (limited to 'src') diff --git a/src/cjr.sml b/src/cjr.sml index 74c4bca2..ac30bd9f 100644 --- a/src/cjr.sml +++ b/src/cjr.sml @@ -60,6 +60,7 @@ datatype exp' = | ERel of int | ENamed of int | ECon of datatype_kind * patCon * exp option + | ENone of typ | ESome of typ * exp | EFfi of string * string | EFfiApp of string * string * exp list diff --git a/src/cjr_print.sml b/src/cjr_print.sml index 24dedb6c..022b9a68 100644 --- a/src/cjr_print.sml +++ b/src/cjr_print.sml @@ -518,6 +518,7 @@ fun p_exp' par env (e, loc) = newline, string "})"] end + | ENone _ => string "NULL" | ESome (t, e) => (case #1 t of TDatatype _ => p_exp' par env e diff --git a/src/cjrize.sml b/src/cjrize.sml index e137c6fd..1f515552 100644 --- a/src/cjrize.sml +++ b/src/cjrize.sml @@ -211,6 +211,12 @@ fun cifyExp (eAll as (e, loc), sm) = in ((L'.ECon (dk, pc, eo), loc), sm) end + | L.ENone t => + let + val (t, sm) = cifyTyp (t, sm) + in + ((L'.ENone t, loc), sm) + end | L.ESome (t, e) => let val (t, sm) = cifyTyp (t, sm) diff --git a/src/compiler.sml b/src/compiler.sml index 09080809..1578da71 100644 --- a/src/compiler.sml +++ b/src/compiler.sml @@ -467,8 +467,8 @@ val toSqlify = transform sqlify "sqlify" o toMono_opt2 fun compileC {cname, oname, ename} = let - val compile = "gcc -s -O3 -I include -c " ^ cname ^ " -o " ^ oname - val link = "gcc -s -O3 -pthread -lpq clib/urweb.o " ^ oname ^ " clib/driver.o -o " ^ ename + val compile = "gcc -Wstrict-prototypes -Werror -s -O3 -I include -c " ^ cname ^ " -o " ^ oname + val link = "gcc -Werror -s -O3 -pthread -lpq clib/urweb.o " ^ oname ^ " clib/driver.o -o " ^ ename in if not (OS.Process.isSuccess (OS.Process.system compile)) then print "C compilation failed\n" diff --git a/src/elab_env.sml b/src/elab_env.sml index 89a2b4ff..1b9de129 100644 --- a/src/elab_env.sml +++ b/src/elab_env.sml @@ -991,17 +991,23 @@ fun declBinds env (d, loc) = DCon (x, n, k, c) => pushCNamedAs env x n k (SOME c) | DDatatype (x, n, xs, xncs) => let - val env = pushCNamedAs env x n (KType, loc) NONE + val k = (KType, loc) + val nxs = length xs + val (tb, kb) = ListUtil.foldli (fn (i, x', (tb, kb)) => + ((CApp (tb, (CRel (nxs - i - 1), loc)), loc), + (KArrow (k, kb), loc))) + ((CNamed n, loc), k) xs + + val env = pushCNamedAs env x n kb NONE val env = pushDatatype env n xs xncs in foldl (fn ((x', n', to), env) => let val t = case to of - NONE => (CNamed n, loc) - | SOME t => (TFun (t, (CNamed n, loc)), loc) - val k = (KType, loc) - val t = foldr (fn (x, t) => (TCFun (Explicit, x, k, t), loc)) t xs + NONE => tb + | SOME t => (TFun (t, tb), loc) + val t = foldr (fn (x, t) => (TCFun (Implicit, x, k, t), loc)) t xs in pushENamedAs env x' n' t end) @@ -1010,19 +1016,24 @@ fun declBinds env (d, loc) = | DDatatypeImp (x, n, m, ms, x', xs, xncs) => let val t = (CModProj (m, ms, x'), loc) - val env = pushCNamedAs env x n (KType, loc) (SOME t) + val k = (KType, loc) + val nxs = length xs + val (tb, kb) = ListUtil.foldli (fn (i, x', (tb, kb)) => + ((CApp (tb, (CRel (nxs - i - 1), loc)), loc), + (KArrow (k, kb), loc))) + ((CNamed n, loc), k) xs + + val t' = foldr (fn (x, t) => (TCFun (Implicit, x, k, t), loc)) t xs + val env = pushCNamedAs env x n kb (SOME t') val env = pushDatatype env n xs xncs - - val t = (CNamed n, loc) in foldl (fn ((x', n', to), env) => let val t = case to of - NONE => (CNamed n, loc) - | SOME t => (TFun (t, (CNamed n, loc)), loc) - val k = (KType, loc) - val t = foldr (fn (x, t) => (TCFun (Explicit, x, k, t), loc)) t xs + NONE => tb + | SOME t => (TFun (t, tb), loc) + val t = foldr (fn (x, t) => (TCFun (Implicit, x, k, t), loc)) t xs in pushENamedAs env x' n' t end) diff --git a/src/mono.sml b/src/mono.sml index 8c69443a..ce34c585 100644 --- a/src/mono.sml +++ b/src/mono.sml @@ -60,6 +60,7 @@ datatype exp' = | ERel of int | ENamed of int | ECon of datatype_kind * patCon * exp option + | ENone of typ | ESome of typ * exp | EFfi of string * string | EFfiApp of string * string * exp list diff --git a/src/mono_print.sml b/src/mono_print.sml index 19084a65..643cb657 100644 --- a/src/mono_print.sml +++ b/src/mono_print.sml @@ -130,6 +130,7 @@ fun p_exp' par env (e, _) = | ECon (_, pc, SOME e) => parenIf par (box [p_patCon env pc, space, p_exp' true env e]) + | ENone _ => string "None" | ESome (_, e) => parenIf par (box [string "Some", space, p_exp' true env e]) diff --git a/src/mono_reduce.sml b/src/mono_reduce.sml index 42f32256..9ae44e47 100644 --- a/src/mono_reduce.sml +++ b/src/mono_reduce.sml @@ -45,6 +45,7 @@ fun impure (e, _) = | ERel _ => false | ENamed _ => false | ECon (_, _, eo) => (case eo of NONE => false | SOME e => impure e) + | ENone _ => false | ESome (_, e) => impure e | EFfi _ => false | EFfiApp _ => false diff --git a/src/mono_util.sml b/src/mono_util.sml index 90ae3a4f..3e6a9f0f 100644 --- a/src/mono_util.sml +++ b/src/mono_util.sml @@ -145,6 +145,10 @@ fun mapfoldB {typ = fc, exp = fe, bind} = S.map2 (mfe ctx e, fn e' => (ECon (dk, n, SOME e'), loc)) + | ENone t => + S.map2 (mft t, + fn t' => + (ENone t', loc)) | ESome (t, e) => S.bind2 (mft t, fn t' => diff --git a/src/monoize.sml b/src/monoize.sml index ebca1d43..09735568 100644 --- a/src/monoize.sml +++ b/src/monoize.sml @@ -478,6 +478,14 @@ fun monoExp (env, st, fm) (all as (e, loc)) = in ((L'.ECon (dk, monoPatCon env pc, eo), loc), fm) end + | L.ECon (L.Option, _, [t], NONE) => + ((L'.ENone (monoType env t), loc), fm) + | L.ECon (L.Option, _, [t], SOME e) => + let + val (e, fm) = monoExp (env, st, fm) e + in + ((L'.ESome (monoType env t, e), loc), fm) + end | L.ECon _ => poly () | L.ECApp ((L.EFfi ("Basis", "show"), _), t) => diff --git a/src/prepare.sml b/src/prepare.sml index f74b8747..a1dd0e79 100644 --- a/src/prepare.sml +++ b/src/prepare.sml @@ -60,6 +60,7 @@ fun prepExp (e as (_, loc), sns) = in ((ECon (dk, pc, SOME e), loc), sns) end + | ENone t => (e, sns) | ESome (t, e) => let val (e, sns) = prepExp (e, sns) -- cgit v1.2.3