Mercurial > urweb

changeset 126:76a4d69719d8

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Tagging (non-mutual) 'val rec'
author Adam Chlipala <adamc@hcoop.net>
date Thu, 17 Jul 2008 10:38:03 -0400
parents fd98dd10dce7
children 4eb68ed31145
files src/cjrize.sml src/core_env.sml src/mono.sml src/mono_env.sml src/mono_print.sml src/mono_util.sml src/tag.sml
diffstat 7 files changed, 70 insertions(+), 33 deletions(-) [+]
line wrap: on
line diff
--- a/src/cjrize.sml	Thu Jul 17 10:23:04 2008 -0400
+++ b/src/cjrize.sml	Thu Jul 17 10:38:03 2008 -0400
@@ -195,6 +195,7 @@
         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
--- a/src/core_env.sml	Thu Jul 17 10:23:04 2008 -0400
+++ b/src/core_env.sml	Thu Jul 17 10:38:03 2008 -0400
@@ -123,7 +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
+      | DValRec vis => foldl (fn ((x, n, t, e, s), env) => pushENamed env x n t NONE s) env vis
       | DExport _ => env
 
 end
--- a/src/mono.sml	Thu Jul 17 10:23:04 2008 -0400
+++ b/src/mono.sml	Thu Jul 17 10:38:03 2008 -0400
@@ -61,6 +61,7 @@
 
 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
--- a/src/mono_env.sml	Thu Jul 17 10:23:04 2008 -0400
+++ b/src/mono_env.sml	Thu Jul 17 10:38:03 2008 -0400
@@ -84,6 +84,7 @@
 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
--- a/src/mono_print.sml	Thu Jul 17 10:23:04 2008 -0400
+++ b/src/mono_print.sml	Thu Jul 17 10:38:03 2008 -0400
@@ -138,32 +138,44 @@
 
 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,
+                 string "rec",
                  space,
-                 string "as",
-                 space,
-                 string s,
-                 space,
-                 string ":",
-                 space,
-                 p_typ env t,
-                 space,
-                 string "=",
-                 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",
--- a/src/mono_util.sml	Thu Jul 17 10:23:04 2008 -0400
+++ b/src/mono_util.sml	Thu Jul 17 10:38:03 2008 -0400
@@ -258,16 +258,25 @@
 
         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 @@
                                 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',
--- a/src/tag.sml	Thu Jul 17 10:23:04 2008 -0400
+++ b/src/tag.sml	Thu Jul 17 10:38:03 2008 -0400
@@ -147,16 +147,21 @@
                 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 @@
                                                         (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