Mercurial > urweb
changeset 129:78d59cf0a0cc
Compiled (non-mutual) 'val rec'
| author | Adam Chlipala <adamc@hcoop.net> |
|---|---|
| date | Thu, 17 Jul 2008 11:02:10 -0400 |
| parents | b04f7422c832 |
| children | 96bd3350e77d |
| files | src/cjr.sml src/cjr_env.sml src/cjr_print.sml src/cjrize.sml src/mono_print.sml |
| diffstat | 5 files changed, 98 insertions(+), 28 deletions(-) [+] |
line wrap: on
line diff
--- a/src/cjr.sml Thu Jul 17 10:48:25 2008 -0400 +++ b/src/cjr.sml Thu Jul 17 11:02:10 2008 -0400 @@ -58,6 +58,7 @@ DStruct of int * (string * typ) list | 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 withtype decl = decl' located
--- a/src/cjr_env.sml Thu Jul 17 10:48:25 2008 -0400 +++ b/src/cjr_env.sml Thu Jul 17 11:02:10 2008 -0400 @@ -125,6 +125,13 @@ in pushENamed env fx n t end + | DFunRec vis => + foldl (fn ((fx, n, args, ran, _), env) => + let + val t = foldl (fn ((_, arg), t) => (TFun (arg, t), loc)) ran args + in + pushENamed env fx n t + end) env vis | DStruct (n, xts) => pushStruct env n xts end
--- a/src/cjr_print.sml Thu Jul 17 10:48:25 2008 -0400 +++ b/src/cjr_print.sml Thu Jul 17 11:02:10 2008 -0400 @@ -83,10 +83,21 @@ string "(ctx, ", p_list (p_exp env) es, string ")"] - | EApp (e1, e2) => parenIf par (box [p_exp' true env e1, - string "(", - p_exp env e2, - string ")"]) + | EApp (e1, e2) => + let + fun unravel (f, acc) = + case #1 f of + EApp (f', arg) => unravel (f', arg :: acc) + | _ => (f, acc) + + val (f, args) = unravel (e1, [e2]) + in + parenIf par (box [p_exp' true env e1, + string "(ctx,", + space, + p_list_sep (box [string ",", space]) (p_exp env) args, + string ")"]) + end | ERecord (i, xes) => box [string "({", space, @@ -124,7 +135,34 @@ and p_exp env = p_exp' false env -fun p_decl env ((d, _) : decl) = +fun p_fun env (fx, n, args, ran, e) = + let + val nargs = length args + val env' = foldl (fn ((x, dom), env) => E.pushERel env x dom) env args + in + box [string "static", + space, + p_typ env ran, + space, + string ("__lwn_" ^ fx ^ "_" ^ Int.toString n), + string "(", + p_list_sep (box [string ",", space]) (fn x => x) + (string "lw_context ctx" :: ListUtil.mapi (fn (i, (_, dom)) => + box [p_typ env dom, + space, + p_rel env' (nargs - i - 1)]) args), + string ")", + space, + string "{", + newline, + box[string "return(", + p_exp env' e, + string ");"], + newline, + string "}"] + end + +fun p_decl env (dAll as (d, _) : decl) = case d of DStruct (n, xts) => box [string "struct", @@ -149,31 +187,25 @@ space, p_exp env e, string ";"] - | DFun (fx, n, args, ran, e) => + | DFun vi => p_fun env vi + | DFunRec vis => let - val nargs = length args - val env' = foldl (fn ((x, dom), env) => E.pushERel env x dom) env args + val env = E.declBinds env dAll in - box [string "static", - space, - p_typ env ran, - space, - string ("__lwn_" ^ fx ^ "_" ^ Int.toString n), - string "(", - p_list_sep (box [string ",", space]) (fn x => x) - (string "lw_context ctx" :: ListUtil.mapi (fn (i, (_, dom)) => - box [p_typ env dom, - space, - p_rel env' (nargs - i - 1)]) args), - string ")", - space, - string "{", + box [p_list_sep newline (fn (fx, n, args, ran, _) => + box [string "static", + space, + p_typ env ran, + space, + string ("__lwn_" ^ fx ^ "_" ^ Int.toString n), + string "(lw_context,", + space, + p_list_sep (box [string ",", space]) + (fn (_, dom) => p_typ env dom) args, + string ");"]) vis, newline, - box[string "return(", - p_exp env' e, - string ");"], - newline, - string "}"] + p_list_sep newline (p_fun env) vis, + newline] end fun unurlify (t, loc) =
--- a/src/cjrize.sml Thu Jul 17 10:48:25 2008 -0400 +++ b/src/cjrize.sml Thu Jul 17 11:02:10 2008 -0400 @@ -195,7 +195,36 @@ in (SOME (d, loc), NONE, sm) end - | L.DValRec _ => raise Fail "Cjrize DValRec" + | L.DValRec vis => + let + val (vis, sm) = ListUtil.foldlMap + (fn ((x, n, t, e, _), sm) => + let + val (t, sm) = cifyTyp (t, sm) + + fun unravel (tAll as (t, _), eAll as (e, _)) = + case (t, e) of + (L'.TFun (dom, ran), L.EAbs (ax, _, _, e)) => + let + val (args, t, e) = unravel (ran, e) + in + ((ax, dom) :: args, t, e) + end + | (L'.TFun _, _) => + (ErrorMsg.errorAt loc "Function isn't explicit at code generation"; + ([], tAll, eAll)) + | _ => ([], tAll, eAll) + + val (args, ran, e) = unravel (t, e) + val (e, sm) = cifyExp (e, sm) + in + ((x, n, args, ran, e), sm) + end) + sm vis + in + (SOME (L'.DFunRec vis, loc), NONE, sm) + end + | L.DExport (s, n, ts) => let val (ts, sm) = ListUtil.foldlMap cifyTyp sm ts