Mercurial > urweb
changeset 125:fd98dd10dce7
Corifying (non-mutual) 'val rec'
| author | Adam Chlipala <adamc@hcoop.net> |
|---|---|
| date | Thu, 17 Jul 2008 10:23:04 -0400 |
| parents | 541282b81454 |
| children | 76a4d69719d8 |
| files | src/core.sml src/core_env.sml src/core_print.sml src/core_util.sml src/corify.sml src/monoize.sml src/shake.sml src/tag.sml |
| diffstat | 8 files changed, 75 insertions(+), 28 deletions(-) [+] |
line wrap: on
line diff
--- a/src/core.sml Thu Jul 17 10:13:18 2008 -0400 +++ b/src/core.sml Thu Jul 17 10:23:04 2008 -0400 @@ -83,6 +83,7 @@ datatype decl' = DCon of string * int * kind * con | DVal of string * int * con * exp * string + | DValRec of (string * int * con * exp * string) list | DExport of int withtype decl = decl' located
--- a/src/core_env.sml Thu Jul 17 10:13:18 2008 -0400 +++ b/src/core_env.sml Thu Jul 17 10:23:04 2008 -0400 @@ -123,6 +123,7 @@ 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 | DExport _ => env end
--- a/src/core_print.sml Thu Jul 17 10:13:18 2008 -0400 +++ b/src/core_print.sml Thu Jul 17 10:23:04 2008 -0400 @@ -240,7 +240,31 @@ 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_con env t, + space, + string "=", + space, + p_exp env e] + end + +fun p_decl env (dAll as (d, _) : decl) = case d of DCon (x, n, k, c) => let @@ -263,30 +287,18 @@ space, p_con env c] end - | 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, + string "rec", space, - string "as", - space, - string s, - space, - string ":", - space, - p_con env t, - space, - string "=", - space, - p_exp env e] + p_list_sep (box [newline, string "and", space]) (p_vali env) vis] end | DExport n => box [string "export", space,
--- a/src/core_util.sml Thu Jul 17 10:13:18 2008 -0400 +++ b/src/core_util.sml Thu Jul 17 10:23:04 2008 -0400 @@ -380,13 +380,22 @@ S.map2 (mfc ctx c, fn c' => (DCon (x, n, k', c'), loc))) - | DVal (x, n, t, e, s) => - S.bind2 (mfc ctx 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.return2 dAll + + and mfvi ctx (x, n, t, e, s) = + S.bind2 (mfc ctx t, + fn t' => + S.map2 (mfe ctx e, + fn e' => + (x, n, t', e', s))) in mfd end @@ -435,6 +444,9 @@ case #1 d' of DCon (x, n, k, c) => bind (ctx, NamedC (x, n, k, SOME c)) | 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',
--- a/src/corify.sml Thu Jul 17 10:13:18 2008 -0400 +++ b/src/corify.sml Thu Jul 17 10:23:04 2008 -0400 @@ -384,8 +384,24 @@ in ([(L'.DVal (x, n, corifyCon st t, corifyExp st e, s), loc)], st) end - | L.DValRec _ => raise Fail "Explify DValRec" - + | L.DValRec vis => + let + val (vis, st) = ListUtil.foldlMap + (fn ((x, n, t, e), st) => + let + val (st, n) = St.bindVal st x n + val s = + if String.isPrefix "wrap_" x then + String.extract (x, 5, NONE) + else + x + in + ((x, n, corifyCon st t, corifyExp st e, s), st) + end) + st vis + in + ([(L'.DValRec vis, loc)], st) + end | L.DSgn _ => ([], st) | L.DStr (x, n, _, (L.StrFun (_, na, _, _, str), _)) =>
--- a/src/monoize.sml Thu Jul 17 10:13:18 2008 -0400 +++ b/src/monoize.sml Thu Jul 17 10:23:04 2008 -0400 @@ -248,6 +248,7 @@ L.DCon _ => NONE | L.DVal (x, n, t, e, s) => SOME (Env.pushENamed env x n t (SOME e) s, (L'.DVal (x, n, monoType env t, monoExp env e, s), loc)) + | L.DValRec _ => raise Fail "Monoize DValRec" | L.DExport n => let val (_, t, _, s) = Env.lookupENamed env n
--- a/src/shake.sml Thu Jul 17 10:13:18 2008 -0400 +++ b/src/shake.sml Thu Jul 17 10:23:04 2008 -0400 @@ -49,6 +49,8 @@ val (cdef, edef) = foldl (fn ((DCon (_, n, _, c), _), (cdef, edef)) => (IM.insert (cdef, n, c), edef) | ((DVal (_, n, t, e, _), _), (cdef, edef)) => (cdef, IM.insert (edef, n, (t, e))) + | ((DValRec vis, _), (cdef, edef)) => + (cdef, foldl (fn ((_, n, t, e, _), edef) => IM.insert (edef, n, (t, e))) edef vis) | ((DExport _, _), acc) => acc) (IM.empty, IM.empty) file @@ -99,6 +101,7 @@ in List.filter (fn (DCon (_, n, _, _), _) => IS.member (#con s, n) | (DVal (_, n, _, _, _), _) => IS.member (#exp s, n) + | (DValRec vis, _) => List.exists (fn (_, n, _, _, _) => IS.member (#exp s, n)) vis | (DExport _, _) => true) file end
--- a/src/tag.sml Thu Jul 17 10:13:18 2008 -0400 +++ b/src/tag.sml Thu Jul 17 10:23:04 2008 -0400 @@ -132,6 +132,7 @@ case d of DCon (_, n, _, _) => Int.max (n, count) | DVal (_, n, _, _, _) => Int.max (n, count) + | DValRec vis => foldl (fn ((_, n, _, _, _), count) => Int.max (n, count)) count vis | DExport _ => count) 0 file fun doDecl (d as (d', loc), (env, count, tags, byTag)) =