Fix #829

compiler/lib/generate.ml

@@ -1349,6 +1349,36 @@ and compile_block st queue (pc : Addr.t) frontier interm =
             try Var.Map.find x m with Not_found -> x
           in
           let handler = compile_block st [] pc2 inner_frontier new_interm in
+          if debug () then Format.eprintf "}@]@ ";
+          Addr.Set.iter (decr_preds st) grey;
+          let after, exn_escape =
+            if not (Addr.Set.is_empty grey')
+            then
+              let pc = Addr.Set.choose grey' in
+              let exn_escape =
+                let x' = Var.fork x in
+                let found = ref false in
+                let map_var y =
+                  if Code.Var.equal x y
+                  then (
+                    found := true;
+                    x')
+                  else y
+                in
+                let subst_block pc blocks =
+                  Addr.Map.add pc (Subst.block map_var (Addr.Map.find pc blocks)) blocks
+                in
+                let blocks =
+                  Code.traverse Code.fold_children subst_block pc st.blocks st.blocks
+                in
+                if !found then st.blocks <- blocks;
+                if !found then Some x' else None
+              in
+              if Addr.Set.mem pc frontier
+              then [], exn_escape
+              else compile_block st [] pc frontier interm, exn_escape
+            else [], None
+          in
           let handler =
             if st.ctx.Ctx.live.(Var.idx x) > 0 && Config.Flag.excwrap ()
             then
@@ -1367,20 +1397,17 @@ and compile_block st queue (pc : Addr.t) frontier interm =
               :: handler
             else handler
           in
-          if debug () then Format.eprintf "}@]@ ";
-          Addr.Set.iter (decr_preds st) grey;
+          let handler =
+            match exn_escape with
+            | Some x' ->
+                handler @ [J.Variable_statement [J.V x', Some (EVar (J.V x), J.N)], J.N]
+            | None -> handler
+          in
           flush_all
             queue
             (( J.Try_statement (body, Some (J.V x, handler), None)
              , source_location st.ctx pc )
-            ::
-            (if not (Addr.Set.is_empty grey')
-            then
-              let pc = Addr.Set.choose grey' in
-              if Addr.Set.mem pc frontier
-              then []
-              else compile_block st [] pc frontier interm
-            else []))
+            :: after)
       | _ ->
           let new_frontier, new_interm = colapse_frontier st new_frontier interm in
           assert (Addr.Set.cardinal new_frontier <= 1);

compiler/lib/js_assign.ml

@@ -361,8 +361,11 @@ let program' (module Strategy : Strategy) p =
   mapper#block [];
   if S.cardinal mapper#get_free <> 0
   then
-    failwith_ "Some variables escaped (#%d)" (S.cardinal mapper#get_free)
-    (* S.iter(fun s -> (Format.eprintf "%s@." (Var.to_string s))) coloring#get_free *);
+    if true
+    then failwith_ "Some variables escaped (#%d)" (S.cardinal mapper#get_free)
+    else (
+      Format.eprintf "Some variables escaped (#%d)" (S.cardinal mapper#get_free);
+      S.iter (fun s -> Format.eprintf "%s@." (Var.to_string s)) mapper#get_free);
   let names = Strategy.allocate_variables state ~count:mapper#state.Js_traverse.count in
   (* if debug () then output_debug_information state coloring#state.Js_traverse.count; *)
   let color = function

compiler/lib/subst.mli

@@ -28,6 +28,8 @@ val instr : (Var.t -> Var.t) -> instr -> instr
 
 val instrs : (Var.t -> Var.t) -> instr list -> instr list
 
+val block : (Var.t -> Var.t) -> block -> block
+
 val last : (Var.t -> Var.t) -> last -> last
 
 val cont : (Var.t -> Var.t) -> int -> program -> program

compiler/tests/array_access.ml

@@ -39,11 +39,11 @@ let%expect_test "array_set" =
     |> parse_js
   in
   let program = compile array_set in
-  print_fun_decl program "some_name";
+  print_fun_decl program (Some "some_name");
   [%expect
     {|
     function some_name(a,n){runtime.caml_check_bound(a,n)[1 + n] = n;return 1} |}]
 
 let%expect_test "array_set" =
   compile_and_run array_set;
-  [%expect {||}]
+  [%expect {| |}]

compiler/tests/eliminate_exception_handler.ml

@@ -57,5 +57,5 @@ try raise Not_found with
              true)
                    |}
   in
-  print_fun_decl program "some_name";
+  print_fun_decl program (Some "some_name");
   [%expect {| function some_name(param){try {throw Stdlib[8]}catch(_a_){return 0}} |}]

compiler/tests/exceptions.ml

@@ -0,0 +1,58 @@
+(* Js_of_ocaml compiler
+ * http://www.ocsigen.org/js_of_ocaml/
+ * Copyright (C) 2019 Hugo Heuzard
+ *
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU Lesser General Public License as published by
+ * the Free Software Foundation, with linking exception;
+ * either version 2.1 of the License, or (at your option) any later version.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ * GNU Lesser General Public License for more details.
+ *
+ * You should have received a copy of the GNU Lesser General Public License
+ * along with this program; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+ *)
+open Util
+
+(* https://github.com/ocsigen/js_of_ocaml/issues/829 *)
+
+let%expect_test _ =
+  let compile ~debug s =
+    s
+    |> Filetype.ocaml_text_of_string
+    |> Filetype.write_ocaml
+    |> compile_ocaml_to_cmo ~debug
+    |> compile_cmo_to_javascript ~pretty:true ~sourcemap:debug
+    |> fst
+    |> parse_js
+  in
+  let program ~debug =
+    compile
+      ~debug
+      {|
+let some_name () = raise (try try raise Not_found with x -> x with i -> i)
+let prevent_inline = some_name
+      |}
+  in
+  print_fun_decl (program ~debug:true) None;
+  [%expect
+    {|
+    function some_name(param)
+     {try
+       {try {throw Stdlib[8]}catch(x){x = caml_wrap_exception(x);var i=x}}
+      catch(i$0){i$0 = caml_wrap_exception(i$0);var i=i$0}
+      throw i} |}];
+  print_fun_decl (program ~debug:false) None;
+  [%expect
+    {|
+    function _a_(_b_)
+     {try
+       {try
+         {throw Stdlib[8]}
+        catch(_e_){_e_ = caml_wrap_exception(_e_);var _c_=_e_}}
+      catch(_d_){_d_ = caml_wrap_exception(_d_);throw _d_}
+      throw _c_} |}]

compiler/tests/lazy.ml

@@ -39,7 +39,7 @@ let%expect_test "static eval of string get" =
       let _ = do_the_lazy_rec 8
   |}
   in
-  print_fun_decl program "do_the_lazy_rec";
+  print_fun_decl program (Some "do_the_lazy_rec");
   [%expect
     {|
     function do_the_lazy_rec(n)

compiler/tests/match_with_exn.ml

@@ -77,8 +77,8 @@ let fun2 () =
 
   |}
   in
-  print_fun_decl program "fun1";
-  print_fun_decl program "fun2";
+  print_fun_decl program (Some "fun1");
+  print_fun_decl program (Some "fun2");
   [%expect
     {|
     function fun1(param)

compiler/tests/obj.ml

@@ -44,16 +44,16 @@ let%expect_test "static eval of string get" =
     let my_truncate t i = Obj.truncate (Obj.repr [t]) i
   |}
   in
-  print_fun_decl program "my_is_block";
-  print_fun_decl program "my_is_int";
-  print_fun_decl program "my_tag";
-  print_fun_decl program "my_size";
-  print_fun_decl program "my_field";
-  print_fun_decl program "my_set_field";
-  print_fun_decl program "my_set_tag";
-  print_fun_decl program "my_new_block";
-  print_fun_decl program "my_dup";
-  print_fun_decl program "my_truncate";
+  print_fun_decl program (Some "my_is_block");
+  print_fun_decl program (Some "my_is_int");
+  print_fun_decl program (Some "my_tag");
+  print_fun_decl program (Some "my_size");
+  print_fun_decl program (Some "my_field");
+  print_fun_decl program (Some "my_set_field");
+  print_fun_decl program (Some "my_set_tag");
+  print_fun_decl program (Some "my_new_block");
+  print_fun_decl program (Some "my_dup");
+  print_fun_decl program (Some "my_truncate");
   [%expect
     {|
     function my_is_block(x){return caml_call1(Stdlib_obj[1],x)}

compiler/tests/util/util.ml

@@ -187,13 +187,19 @@ let compile_bc_to_javascript ?flags ?(pretty = true) ?(sourcemap = true) file =
 let compile_cmo_to_javascript ?(pretty = true) ?(sourcemap = true) file =
   Filetype.path_of_cmo_file file |> compile_to_javascript ~pretty ~sourcemap
 
-let compile_ocaml_to_cmo file =
+let compile_ocaml_to_cmo ?(debug = true) file =
   let file = Filetype.path_of_ocaml_file file in
   let out_file = swap_extention file ~ext:"cmo" in
   let (stdout : string) =
     exec_to_string_exn
       ~env:[]
-      ~cmd:(Format.sprintf "%s -c -g %s -o %s" ocamlc file out_file)
+      ~cmd:
+        (Format.sprintf
+           "%s -c %s %s -o %s"
+           ocamlc
+           (if debug then "-g" else "")
+           file
+           out_file)
   in
   print_string stdout;
   Filetype.cmo_file_of_path out_file
@@ -262,10 +268,15 @@ class find_function_declaration r n =
 
     method! source s =
       (match s with
-      | Function_declaration ((Jsoo.Javascript.S {name; _}, _, _, _) as fd) when name = n
-        ->
-          r := fd :: !r
-      | Function_declaration _ | Statement _ -> ());
+      | Function_declaration fd ->
+          let record =
+            match fd, n with
+            | _, None -> true
+            | (Jsoo.Javascript.S {name; _}, _, _, _), Some n -> name = n
+            | _ -> false
+          in
+          if record then r := fd :: !r
+      | Statement _ -> ());
       super#source s
   end
 

compiler/tests/util/util.mli

@@ -23,7 +23,7 @@ module Filetype : Filetype_intf.S
 
 val parse_js : Filetype.js_file -> Javascript.program
 
-val compile_ocaml_to_cmo : Filetype.ocaml_file -> Filetype.cmo_file
+val compile_ocaml_to_cmo : ?debug:bool -> Filetype.ocaml_file -> Filetype.cmo_file
 
 val compile_ocaml_to_bc : Filetype.ocaml_file -> Filetype.bc_file
 
@@ -48,6 +48,6 @@ val expression_to_string : ?compact:bool -> Javascript.expression -> string
 
 val print_var_decl : Javascript.program -> string -> unit
 
-val print_fun_decl : Javascript.program -> string -> unit
+val print_fun_decl : Javascript.program -> string option -> unit
 
 val compile_and_run : ?flags:string list -> string -> unit