summaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/cjr.sml1
-rw-r--r--src/cjr_env.sml7
-rw-r--r--src/cjr_print.sml86
-rw-r--r--src/cjrize.sml31
-rw-r--r--src/mono_print.sml1
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 "(",