summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorGravatar Adam Chlipala <adamc@hcoop.net>2008-07-17 10:38:03 -0400
committerGravatar Adam Chlipala <adamc@hcoop.net>2008-07-17 10:38:03 -0400
commit462c9d472ebe1a585e3bddb103a3f7cf1cdc64e5 (patch)
treec57ef255d292387fa8cff95182d164437f64b3e5
parente3313edc92a73932ff57b1c803fe7e408283406f (diff)
Tagging (non-mutual) 'val rec'
-rw-r--r--src/cjrize.sml1
-rw-r--r--src/core_env.sml2
-rw-r--r--src/mono.sml1
-rw-r--r--src/mono_env.sml1
-rw-r--r--src/mono_print.sml52
-rw-r--r--src/mono_util.sml23
-rw-r--r--src/tag.sml23
7 files changed, 70 insertions, 33 deletions
diff --git a/src/cjrize.sml b/src/cjrize.sml
index dcbfbce3..5f2f69c0 100644
--- a/src/cjrize.sml
+++ b/src/cjrize.sml
@@ -195,6 +195,7 @@ fun cifyDecl ((d, loc), sm) =
in
(SOME (d, loc), NONE, sm)
end
+ | L.DValRec _ => raise Fail "Cjrize DValRec"
| L.DExport (s, n, ts) =>
let
val (ts, sm) = ListUtil.foldlMap cifyTyp sm ts
diff --git a/src/core_env.sml b/src/core_env.sml
index 5c59d9a2..c92690bf 100644
--- a/src/core_env.sml
+++ b/src/core_env.sml
@@ -123,7 +123,7 @@ fun declBinds env (d, _) =
case d of
DCon (x, n, k, c) => pushCNamed env x n k (SOME c)
| DVal (x, n, t, e, s) => pushENamed env x n t (SOME e) s
- | DValRec vis => foldl (fn ((x, n, t, e, s), env) => pushENamed env x n t (SOME e) s) env vis
+ | DValRec vis => foldl (fn ((x, n, t, e, s), env) => pushENamed env x n t NONE s) env vis
| DExport _ => env
end
diff --git a/src/mono.sml b/src/mono.sml
index a1ce85c3..22a5a8e0 100644
--- a/src/mono.sml
+++ b/src/mono.sml
@@ -61,6 +61,7 @@ withtype exp = exp' located
datatype decl' =
DVal of string * int * typ * exp * string
+ | DValRec of (string * int * typ * exp * string) list
| DExport of string * int * typ list
withtype decl = decl' located
diff --git a/src/mono_env.sml b/src/mono_env.sml
index 9af80d23..0134b471 100644
--- a/src/mono_env.sml
+++ b/src/mono_env.sml
@@ -84,6 +84,7 @@ fun lookupENamed (env : env) n =
fun declBinds env (d, _) =
case d of
DVal (x, n, t, e, s) => pushENamed env x n t (SOME e) s
+ | DValRec vis => foldl (fn ((x, n, t, e, s), env) => pushENamed env x n t NONE s) env vis
| DExport _ => env
end
diff --git a/src/mono_print.sml b/src/mono_print.sml
index 67369b1f..a4fda230 100644
--- a/src/mono_print.sml
+++ b/src/mono_print.sml
@@ -138,32 +138,44 @@ fun p_exp' par env (e, _) =
and p_exp env = p_exp' false env
-fun p_decl env ((d, _) : decl) =
+fun p_vali env (x, n, t, e, s) =
+ let
+ val xp = if !debug then
+ box [string x,
+ string "__",
+ string (Int.toString n)]
+ else
+ string x
+ in
+ box [xp,
+ space,
+ string "as",
+ space,
+ string s,
+ space,
+ string ":",
+ space,
+ p_typ env t,
+ space,
+ string "=",
+ space,
+ p_exp env e]
+ end
+
+fun p_decl env (dAll as (d, _) : decl) =
case d of
- DVal (x, n, t, e, s) =>
+ DVal vi => box [string "val",
+ space,
+ p_vali env vi]
+ | DValRec vis =>
let
- val xp = if !debug then
- box [string x,
- string "__",
- string (Int.toString n)]
- else
- string x
+ val env = E.declBinds env dAll
in
box [string "val",
space,
- xp,
- space,
- string "as",
- space,
- string s,
- space,
- string ":",
- space,
- p_typ env t,
- space,
- string "=",
+ string "rec",
space,
- p_exp env e]
+ p_list_sep (box [newline, string "and", space]) (p_vali env) vis]
end
| DExport (s, n, ts) => box [string "export",
diff --git a/src/mono_util.sml b/src/mono_util.sml
index bb4e20b2..99393b10 100644
--- a/src/mono_util.sml
+++ b/src/mono_util.sml
@@ -258,16 +258,25 @@ fun mapfoldB {typ = fc, exp = fe, decl = fd, bind} =
and mfd' ctx (dAll as (d, loc)) =
case d of
- DVal (x, n, t, e, s) =>
- S.bind2 (mft t,
- fn t' =>
- S.map2 (mfe ctx e,
- fn e' =>
- (DVal (x, n, t', e', s), loc)))
+ DVal vi =>
+ S.map2 (mfvi ctx vi,
+ fn vi' =>
+ (DVal vi', loc))
+ | DValRec vis =>
+ S.map2 (ListUtil.mapfold (mfvi ctx) vis,
+ fn vis' =>
+ (DValRec vis', loc))
| DExport (s, n, ts) =>
S.map2 (ListUtil.mapfold mft ts,
fn ts' =>
(DExport (s, n, ts'), loc))
+
+ and mfvi ctx (x, n, t, e, s) =
+ S.bind2 (mft t,
+ fn t' =>
+ S.map2 (mfe ctx e,
+ fn e' =>
+ (x, n, t', e', s)))
in
mfd
end
@@ -305,6 +314,8 @@ fun mapfoldB (all as {bind, ...}) =
val ctx' =
case #1 d' of
DVal (x, n, t, e, s) => bind (ctx, NamedE (x, n, t, SOME e, s))
+ | DValRec vis => foldl (fn ((x, n, t, e, s), ctx) =>
+ bind (ctx, NamedE (x, n, t, SOME e, s))) ctx vis
| DExport _ => ctx
in
S.map2 (mff ctx' ds',
diff --git a/src/tag.sml b/src/tag.sml
index 301e0977..1a7e93ca 100644
--- a/src/tag.sml
+++ b/src/tag.sml
@@ -147,16 +147,21 @@ fun tag file =
end
| _ =>
let
+ val env' = E.declBinds env d
+ val env'' = case d' of
+ DValRec _ => env'
+ | _ => env
+
val (d, (count, tags, byTag, newTags)) =
U.Decl.foldMap {kind = kind,
con = con,
- exp = exp env,
+ exp = exp env'',
decl = decl}
(count, tags, byTag, []) d
- val env = E.declBinds env d
+ val env = env'
- val newDs = ListUtil.mapConcat
+ val newDs = map
(fn (f, cn) =>
let
fun unravel (all as (t, _)) =
@@ -202,11 +207,17 @@ fun tag file =
(abs, t)
end
in
- [(DVal ("wrap_" ^ fnam, cn, t, abs, tag), loc),
- (DExport cn, loc)]
+ (("wrap_" ^ fnam, cn, t, abs, tag),
+ (DExport cn, loc))
end) newTags
+
+ val (newVals, newExports) = ListPair.unzip newDs
+
+ val ds = case d of
+ (DValRec vis, _) => [(DValRec (vis @ newVals), loc)]
+ | _ => map (fn vi => (DVal vi, loc)) newVals @ [d]
in
- (newDs @ [d], (env, count, tags, byTag))
+ (ds @ newExports, (env, count, tags, byTag))
end
val (file, _) = ListUtil.foldlMapConcat doDecl (CoreEnv.empty, count+1, IM.empty, SM.empty) file