diff options
| -rw-r--r-- | src/cjrize.sml | 1 | ||||
| -rw-r--r-- | src/core_env.sml | 2 | ||||
| -rw-r--r-- | src/mono.sml | 1 | ||||
| -rw-r--r-- | src/mono_env.sml | 1 | ||||
| -rw-r--r-- | src/mono_print.sml | 52 | ||||
| -rw-r--r-- | src/mono_util.sml | 23 | ||||
| -rw-r--r-- | src/tag.sml | 23 |
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 |