# HG changeset patch
# User Adam Chlipala <adamc@hcoop.net>
# Date 1245189164 14400
# Node ID 1c2f335297b714f7e2fe737c8e3c3e35f558c246
# Parent  e571fb150a9ffa1e4a1d6efd354263d33bbb797e
Fix a variable capture bug in nested JavaScript; some more list stuff

diff -r e571fb150a9f -r 1c2f335297b7 lib/ur/list.ur
--- a/lib/ur/list.ur	Tue Jun 16 14:38:01 2009 -0400
+++ b/lib/ur/list.ur	Tue Jun 16 17:52:44 2009 -0400
@@ -31,17 +31,17 @@
         foldl'
     end
 
-fun foldlPartial [a] [b] f =
+fun foldlAbort [a] [b] f =
     let
-        fun foldlPartial' acc ls =
+        fun foldlAbort' acc ls =
             case ls of
                 [] => Some acc
               | x :: ls =>
                 case f x acc of
                     None => None
-                  | Some acc' => foldlPartial' acc' ls
+                  | Some acc' => foldlAbort' acc' ls
     in
-        foldlPartial'
+        foldlAbort'
     end
 
 val rev = fn [a] =>
@@ -54,6 +54,19 @@
                  rev' []
              end
 
+fun foldlMapAbort [a] [b] [c] f =
+    let
+        fun foldlMapAbort' ls' acc ls =
+            case ls of
+                [] => Some (rev ls', acc)
+              | x :: ls =>
+                case f x acc of
+                    None => None
+                  | Some (x', acc') => foldlMapAbort' (x' :: ls') acc' ls
+    in
+        foldlMapAbort' []
+    end
+
 val revAppend = fn [a] =>
                    let
                        fun ra (ls : list a) acc =
diff -r e571fb150a9f -r 1c2f335297b7 lib/ur/list.urs
--- a/lib/ur/list.urs	Tue Jun 16 14:38:01 2009 -0400
+++ b/lib/ur/list.urs	Tue Jun 16 17:52:44 2009 -0400
@@ -4,7 +4,9 @@
 val eq : a ::: Type -> eq a -> eq (t a)
 
 val foldl : a ::: Type -> b ::: Type -> (a -> b -> b) -> b -> t a -> b
-val foldlPartial : a ::: Type -> b ::: Type -> (a -> b -> option b) -> b -> t a -> option b
+val foldlAbort : a ::: Type -> b ::: Type -> (a -> b -> option b) -> b -> t a -> option b
+val foldlMapAbort : a ::: Type -> b ::: Type -> c ::: Type
+                    -> (a -> b -> option (c * b)) -> b -> t a -> option (t c * b)
 
 val rev : a ::: Type -> t a -> t a
 
diff -r e571fb150a9f -r 1c2f335297b7 lib/ur/listPair.ur
--- a/lib/ur/listPair.ur	Tue Jun 16 14:38:01 2009 -0400
+++ b/lib/ur/listPair.ur	Tue Jun 16 17:52:44 2009 -0400
@@ -1,15 +1,15 @@
-fun foldlPartial [a] [b] [c] f =
+fun foldlAbort [a] [b] [c] f =
     let
-        fun foldlPartial' acc ls1 ls2 =
+        fun foldlAbort' acc ls1 ls2 =
             case (ls1, ls2) of
                 ([], []) => Some acc
               | (x1 :: ls1, x2 :: ls2) =>
                 (case f x1 x2 acc of
                      None => None
-                   | Some acc' => foldlPartial' acc' ls1 ls2)
+                   | Some acc' => foldlAbort' acc' ls1 ls2)
               | _ => None
     in
-        foldlPartial'
+        foldlAbort'
     end
 
 fun mapX [a] [b] [ctx ::: {Unit}] f =
diff -r e571fb150a9f -r 1c2f335297b7 lib/ur/listPair.urs
--- a/lib/ur/listPair.urs	Tue Jun 16 14:38:01 2009 -0400
+++ b/lib/ur/listPair.urs	Tue Jun 16 17:52:44 2009 -0400
@@ -1,5 +1,5 @@
-val foldlPartial : a ::: Type -> b ::: Type -> c ::: Type
-                   -> (a -> b -> c -> option c) -> c -> list a -> list b -> option c
+val foldlAbort : a ::: Type -> b ::: Type -> c ::: Type
+                 -> (a -> b -> c -> option c) -> c -> list a -> list b -> option c
 
 val mapX : a ::: Type -> b ::: Type -> ctx ::: {Unit}
            -> (a -> b -> xml ctx [] []) -> list a -> list b -> xml ctx [] []
diff -r e571fb150a9f -r 1c2f335297b7 src/elab_err.sml
--- a/src/elab_err.sml	Tue Jun 16 14:38:01 2009 -0400
+++ b/src/elab_err.sml	Tue Jun 16 17:52:44 2009 -0400
@@ -218,7 +218,7 @@
                                               ("Type", p_con env c)]) co)
       | Unresolvable (loc, c) =>
         (ErrorMsg.errorAt loc "Can't resolve type class instance";
-         eprefaces' [("Class constraint", p_con env c),
+         eprefaces' [("Class constraint", p_con env c)(*,
                      ("Class database", p_list (fn (c, rules) =>
                                                    box [P.p_con env c,
                                                         PD.string ":",
@@ -228,7 +228,7 @@
                                                                         PD.string ":",
                                                                         space,
                                                                         P.p_con env c]) rules])
-                                        (E.listClasses env))])
+                                        (E.listClasses env))*)])
       | IllegalRec (x, e) =>
         (ErrorMsg.errorAt (#2 e) "Illegal 'val rec' righthand side (must be a function abstraction)";
          eprefaces' [("Variable", PD.string x),
diff -r e571fb150a9f -r 1c2f335297b7 src/jscomp.sml
--- a/src/jscomp.sml	Tue Jun 16 14:38:01 2009 -0400
+++ b/src/jscomp.sml	Tue Jun 16 17:52:44 2009 -0400
@@ -980,12 +980,18 @@
                              jsE inner (e, st))
                           | EJavaScript (_, e) =>
                             let
+                                val locals = List.tabulate
+                                                 (varDepth e,
+                                               fn i => str ("var _" ^ Int.toString (len + inner + i) ^ ";"))
+
                                 val (e, st) = jsE inner (e, st)
                             in
                                 foundJavaScript := true;
-                                (strcat [str "cs(function(){return ",
-                                         compact inner e,
-                                         str "})"],
+                                (strcat (str "cs(function(){"
+                                         :: locals
+                                         @ [str "return ",
+                                            compact inner e,
+                                            str "})"]),
                                  st)
                             end