Mercurial > urweb
changeset 101:717b6f8d8505
First executable generated
| author | Adam Chlipala <adamc@hcoop.net> |
|---|---|
| date | Thu, 10 Jul 2008 11:13:49 -0400 |
| parents | f0f59e918cac |
| children | 5f04adf47f48 |
| files | include/lacweb.h src/cjr.sml src/cjr_env.sig src/cjr_env.sml src/cjr_print.sml src/cjrize.sml src/cloconv.sml src/flat.sml src/flat_env.sml src/flat_print.sml src/flat_util.sml |
| diffstat | 11 files changed, 167 insertions(+), 26 deletions(-) [+] |
line wrap: on
line diff
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/include/lacweb.h Thu Jul 10 11:13:49 2008 -0400 @@ -0,0 +1,3 @@ +typedef int lw_Basis_int; +typedef float lw_Basis_float; +typedef char* lw_Basis_string;
--- a/src/cjr.sml Thu Jul 10 10:11:35 2008 -0400 +++ b/src/cjr.sml Thu Jul 10 11:13:49 2008 -0400 @@ -62,6 +62,6 @@ withtype decl = decl' located -type file = decl list +type file = decl list * ((string * typ) list * exp) list end
--- a/src/cjr_env.sig Thu Jul 10 10:11:35 2008 -0400 +++ b/src/cjr_env.sig Thu Jul 10 11:13:49 2008 -0400 @@ -34,6 +34,7 @@ exception UnboundRel of int exception UnboundNamed of int exception UnboundF of int + exception UnboundStruct of int val pushTNamed : env -> string -> int -> Cjr.typ option -> env val lookupTNamed : env -> int -> string * Cjr.typ option @@ -49,6 +50,9 @@ val pushF : env -> int -> string -> Cjr.typ -> Cjr.typ -> env val lookupF : env -> int -> string * Cjr.typ * Cjr.typ + val pushStruct : env -> int -> (string * Cjr.typ) list -> env + val lookupStruct : env -> int -> (string * Cjr.typ) list + val declBinds : env -> Cjr.decl -> env end
--- a/src/cjr_env.sml Thu Jul 10 10:11:35 2008 -0400 +++ b/src/cjr_env.sml Thu Jul 10 11:13:49 2008 -0400 @@ -35,6 +35,7 @@ exception UnboundRel of int exception UnboundNamed of int exception UnboundF of int +exception UnboundStruct of int type env = { namedT : (string * typ option) IM.map, @@ -43,7 +44,8 @@ relE : (string * typ) list, namedE : (string * typ) IM.map, - F : (string * typ * typ) IM.map + F : (string * typ * typ) IM.map, + structs : (string * typ) list IM.map } val empty = { @@ -53,7 +55,8 @@ relE = [], namedE = IM.empty, - F = IM.empty + F = IM.empty, + structs = IM.empty } fun pushTNamed (env : env) x n co = @@ -63,7 +66,8 @@ relE = #relE env, namedE = #namedE env, - F = #F env} + F = #F env, + structs = #structs env} fun lookupTNamed (env : env) n = case IM.find (#namedT env, n) of @@ -77,7 +81,8 @@ relE = (x, t) :: #relE env, namedE = #namedE env, - F = #F env} + F = #F env, + structs = #structs env} fun lookupERel (env : env) n = (List.nth (#relE env, n)) @@ -94,7 +99,8 @@ relE = #relE env, namedE = IM.insert (#namedE env, n, (x, t)), - F = #F env} + F = #F env, + structs = #structs env} fun lookupENamed (env : env) n = case IM.find (#namedE env, n) of @@ -108,17 +114,33 @@ relE = #relE env, namedE = #namedE env, - F = IM.insert (#F env, n, (x, dom, ran))} + F = IM.insert (#F env, n, (x, dom, ran)), + structs = #structs env} fun lookupF (env : env) n = case IM.find (#F env, n) of NONE => raise UnboundF n | SOME x => x +fun pushStruct (env : env) n xts = + {namedT = #namedT env, + + numRelE = #numRelE env, + relE = #relE env, + namedE = #namedE env, + + F = #F env, + structs = IM.insert (#structs env, n, xts)} + +fun lookupStruct (env : env) n = + case IM.find (#structs env, n) of + NONE => raise UnboundStruct n + | SOME x => x + fun declBinds env (d, _) = case d of DVal (x, n, t, _) => pushENamed env x n t | DFun (n, x, dom, ran, _) => pushF env n x dom ran - | DStruct _ => env + | DStruct (n, xts) => pushStruct env n xts end
--- a/src/cjr_print.sml Thu Jul 10 10:11:35 2008 -0400 +++ b/src/cjr_print.sml Thu Jul 10 11:13:49 2008 -0400 @@ -43,9 +43,7 @@ fun p_typ' par env (t, loc) = case t of - TTop => - (EM.errorAt loc "Undetermined type"; - string "?") + TTop => string "void*" | TFun => (EM.errorAt loc "Undetermined function type"; string "?->") @@ -188,19 +186,73 @@ newline, box[string "return(", p_exp env' e, - string ")"], + string ");"], newline, string "}"] end -fun p_file env file = +fun p_page env (xts, (e, loc)) = + case e of + ERecord (_, xes) => + let + fun read x = ListUtil.search (fn (x', e) => if x' = x then SOME e else NONE) xes + in + case (read "code", read "env") of + (SOME code, SOME envx) => + (case #1 code of + ECode i => + let + val (_, (dom, _), _) = E.lookupF env i + in + case dom of + TRecord ri => + let + val axts = E.lookupStruct env ri + fun read x = ListUtil.search (fn (x', t) => if x' = x then SOME t else NONE) axts + in + case read "arg" of + NONE => string "Page handler is too complicated! [5]" + | SOME (at, _) => + case at of + TRecord ari => + let + val r = (ERecord (ri, [("env", envx), + ("arg", (ERecord (ari, []), loc))]), loc) + in + box [string "return", + space, + p_exp env (EApp (code, r), loc), + string ";"] + end + | _ => string "Page handler is too complicated! [6]" + end + | _ => string "Page handler is too complicated! [4]" + end + | _ => string "Page handler is too complicated! [3]") + + | _ => string "Page handler is too complicated! [1]" + end + | _ => string "Page handler is too complicated! [2]" + +fun p_file env (ds, ps) = let - val (pds, _) = ListUtil.foldlMap (fn (d, env) => + val (pds, env) = ListUtil.foldlMap (fn (d, env) => (p_decl env d, E.declBinds env d)) - env file + env ds + val pds' = map (p_page env) ps in - p_list_sep newline (fn x => x) pds + box [string "#include \"lacweb.h\"", + newline, + newline, + p_list_sep newline (fn x => x) pds, + newline, + string "char *lw_handle(void) {", + newline, + p_list_sep newline (fn x => x) pds', + newline, + string "}", + newline] end end
--- a/src/cjrize.sml Thu Jul 10 10:11:35 2008 -0400 +++ b/src/cjrize.sml Thu Jul 10 11:13:49 2008 -0400 @@ -165,7 +165,7 @@ val (t, sm) = cifyTyp (t, sm) val (e, sm) = cifyExp (e, sm) in - ((L'.DVal (x, n, t, e), loc), sm) + (SOME (L'.DVal (x, n, t, e), loc), NONE, sm) end | L.DFun (n, x, dom, ran, e) => let @@ -173,15 +173,41 @@ val (ran, sm) = cifyTyp (ran, sm) val (e, sm) = cifyExp (e, sm) in - ((L'.DFun (n, x, dom, ran, e), loc), sm) + (SOME (L'.DFun (n, x, dom, ran, e), loc), NONE, sm) + end + | L.DPage (xts, e) => + let + val (xts, sm) = ListUtil.foldlMap (fn ((x, t), sm) => + let + val (t, sm) = cifyTyp (t, sm) + in + ((x, t), sm) + end) + sm xts + val (e, sm) = cifyExp (e, sm) + in + (NONE, SOME (xts, e), sm) end fun cjrize ds = let - val (ds, sm) = ListUtil.foldlMap cifyDecl Sm.empty ds + val (ds, ps, sm) = foldl (fn (d, (ds, ps, sm)) => + let + val (dop, pop, sm) = cifyDecl (d, sm) + val ds = case dop of + NONE => ds + | SOME d => d :: ds + val ps = case pop of + NONE => ps + | SOME p => p :: ps + in + (ds, ps, sm) + end) + ([], [], Sm.empty) ds in - List.revAppend (map (fn v => (L'.DStruct v, ErrorMsg.dummySpan)) (Sm.declares sm), - ds) + (List.revAppend (map (fn v => (L'.DStruct v, ErrorMsg.dummySpan)) (Sm.declares sm), + rev ds), + ps) end end
--- a/src/cloconv.sml Thu Jul 10 10:11:35 2008 -0400 +++ b/src/cloconv.sml Thu Jul 10 11:13:49 2008 -0400 @@ -78,6 +78,7 @@ val exp : t -> string * int * L'.typ * L'.exp -> t val func : t -> string * L'.typ * L'.typ * L'.exp -> t * int + val page : t -> (string * L'.typ) list * L'.exp -> t val decls : t -> L'.decl list val enter : t -> t @@ -95,6 +96,8 @@ fun func (fc, ds, vm) (x, dom, ran, e as (_, loc)) = ((fc+1, (L'.DFun (fc, x, dom, ran, e), loc) :: ds, vm), fc) +fun page (fc, ds, vm) (xts, e as (_, loc)) = (fc, (L'.DPage (xts, e), loc) :: ds, vm) + fun decls (_, ds, _) = rev ds fun enter (fc, ds, vm) = (fc, ds, IS.map (fn n => n + 1) vm) @@ -197,7 +200,13 @@ in Ds.exp D (x, n, t, e) end - | L.DPage _ => raise Fail "Cloconv DPage" + | L.DPage (xts, e) => + let + val xts = map (fn (x, t) => (x, ccTyp t)) xts + val (e, D) = ccExp E.empty (e, D) + in + Ds.page D (xts, e) + end fun cloconv ds = let
--- a/src/flat.sml Thu Jul 10 10:11:35 2008 -0400 +++ b/src/flat.sml Thu Jul 10 11:13:49 2008 -0400 @@ -58,6 +58,7 @@ datatype decl' = DVal of string * int * typ * exp | DFun of int * string * typ * typ * exp + | DPage of (string * typ) list * exp withtype decl = decl' located
--- a/src/flat_env.sml Thu Jul 10 10:11:35 2008 -0400 +++ b/src/flat_env.sml Thu Jul 10 11:13:49 2008 -0400 @@ -111,5 +111,6 @@ case d of DVal (x, n, t, _) => pushENamed env x n t | DFun (n, x, dom, ran, _) => pushF env n x dom ran + | DPage _ => env end
--- a/src/flat_print.sml Thu Jul 10 10:11:35 2008 -0400 +++ b/src/flat_print.sml Thu Jul 10 11:13:49 2008 -0400 @@ -194,6 +194,20 @@ end + | DPage (xcs, e) => box [string "page", + string "[", + p_list (fn (x, t) => + box [string x, + space, + string ":", + space, + p_typ env t]) xcs, + string "]", + space, + string "=", + space, + p_exp env e] + fun p_file env file = let val (pds, _) = ListUtil.foldlMap (fn (d, env) =>
--- a/src/flat_util.sml Thu Jul 10 10:11:35 2008 -0400 +++ b/src/flat_util.sml Thu Jul 10 11:13:49 2008 -0400 @@ -270,6 +270,15 @@ S.map2 (mfe ctx e, fn e' => (DFun (n, x, dom', ran', e'), loc)))) + | DPage (xts, e) => + S.bind2 (ListUtil.mapfold (fn (x, t) => + S.map2 (mft t, + fn t' => + (x, t'))) xts, + fn xts' => + S.map2 (mfe ctx e, + fn e' => + (DPage (xts', e'), loc))) in mfd end @@ -308,11 +317,11 @@ S.bind2 (mfd ctx d, fn d' => let - val b = + val ctx' = case #1 d' of - DVal (x, n, t, e) => NamedE (x, n, t, SOME e) - | DFun v => F v - val ctx' = bind (ctx, b) + DVal (x, n, t, e) => bind (ctx, NamedE (x, n, t, SOME e)) + | DFun v => bind (ctx, F v) + | DPage _ => ctx in S.map2 (mff ctx' ds', fn ds' =>