diff options
Diffstat (limited to 'src')
| -rw-r--r-- | src/cjr.sml | 1 | ||||
| -rw-r--r-- | src/cjr_env.sml | 7 | ||||
| -rw-r--r-- | src/cjr_print.sml | 86 | ||||
| -rw-r--r-- | src/cjrize.sml | 31 | ||||
| -rw-r--r-- | src/mono_print.sml | 1 |
5 files changed, 98 insertions, 28 deletions
diff --git a/src/cjr.sml b/src/cjr.sml index 363fa762..8e8e6cab 100644 --- a/src/cjr.sml +++ b/src/cjr.sml @@ -58,6 +58,7 @@ datatype decl' = 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 diff --git a/src/cjr_env.sml b/src/cjr_env.sml index bad365a5..a44359db 100644 --- a/src/cjr_env.sml +++ b/src/cjr_env.sml @@ -125,6 +125,13 @@ fun declBinds env (d, loc) = 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 diff --git a/src/cjr_print.sml b/src/cjr_print.sml index 991315e5..68184acd 100644 --- a/src/cjr_print.sml +++ b/src/cjr_print.sml @@ -83,10 +83,21 @@ fun p_exp' par env (e, _) = 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 @@ fun p_exp' par env (e, _) = 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 @@ fun p_decl env ((d, _) : decl) = 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 "{", - newline, - box[string "return(", - p_exp env' e, - 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, - string "}"] + p_list_sep newline (p_fun env) vis, + newline] end fun unurlify (t, loc) = diff --git a/src/cjrize.sml b/src/cjrize.sml index 5f2f69c0..cb2557f6 100644 --- a/src/cjrize.sml +++ b/src/cjrize.sml @@ -195,7 +195,36 @@ fun cifyDecl ((d, loc), sm) = 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 diff --git a/src/mono_print.sml b/src/mono_print.sml index a4fda230..6f9c1b66 100644 --- a/src/mono_print.sml +++ b/src/mono_print.sml @@ -183,6 +183,7 @@ fun p_decl env (dAll as (d, _) : decl) = p_enamed env n, space, string "as", + space, string s, p_list_sep (string "") (fn t => box [space, string "(", |