Add test for pattern matching exceptions.

Author: cristianoc

jscomp/test/variant.js

@@ -1,7 +1,10 @@
 'use strict';
 
 var Block = require("../../lib/js/block.js");
+var Curry = require("../../lib/js/curry.js");
 var Caml_obj = require("../../lib/js/caml_obj.js");
+var Caml_exceptions = require("../../lib/js/caml_exceptions.js");
+var Caml_js_exceptions = require("../../lib/js/caml_js_exceptions.js");
 var Caml_builtin_exceptions = require("../../lib/js/caml_builtin_exceptions.js");
 
 function foo(param) {
@@ -100,6 +103,39 @@ function rollback_path(subst, p) {
   }
 }
 
+var EA1 = Caml_exceptions.create("Variant.EA1");
+
+var EA2 = Caml_exceptions.create("Variant.EA2");
+
+var EB = Caml_exceptions.create("Variant.EB");
+
+var EC = Caml_exceptions.create("Variant.EC");
+
+var ED = Caml_exceptions.create("Variant.ED");
+
+function fooExn(f) {
+  try {
+    return Curry._1(f, /* () */0);
+  }
+  catch (raw_exn){
+    var exn = Caml_js_exceptions.internalToOCamlException(raw_exn);
+    if (exn === EA1) {
+      return 1;
+    } else if (exn === EA2) {
+      return 2;
+    } else if (exn[0] === EB) {
+      return exn[1];
+    } else if (exn[0] === EC) {
+      return exn[1] + exn[2] | 0;
+    } else if (exn[0] === ED) {
+      var match = exn[1];
+      return match[0] + match[1] | 0;
+    } else {
+      throw exn;
+    }
+  }
+}
+
 var a1 = /* A1 */0;
 
 var a2 = /* A2 */1;
@@ -129,4 +165,10 @@ exports.Path = Path;
 exports.Make = Make;
 exports.M = M;
 exports.rollback_path = rollback_path;
+exports.EA1 = EA1;
+exports.EA2 = EA2;
+exports.EB = EB;
+exports.EC = EC;
+exports.ED = ED;
+exports.fooExn = fooExn;
 /* No side effect */

jscomp/test/variant.ml

@@ -55,3 +55,17 @@ let rollback_path subst p =
     match p with
       Pident _ | Papply _ -> "Pident | Papply"
     | Pdot _ -> "Pdot"
+
+
+ exception EA1
+ exception EA2
+ exception EB of int
+ exception EC of int * int
+ exception ED of pair
+
+let fooExn f = try f () with
+| EA1 -> 1
+| EA2 -> 2
+| EB n -> n
+| EC (n,m) -> n+m
+| ED (n,m) -> n+m

lib/4.02.3/unstable/js_compiler.ml

@@ -89177,7 +89177,7 @@ let make_clusters ({cases=cases ; actions=actions} as s) n_clusters k sw_names =
     end ;
     if i > 0 then zyva (i-1) (ir-1) in
 
-  zyva (len-1) (n_clusters-1);
+  zyva (len-1) (n_clusters-1) ;
   let acts = Array.make !index (fun _ -> assert false) in
   Hashtbl.iter (fun _ (i,act) -> acts.(i) <- act) t ;
   {cases = r ; actions = acts}
@@ -92414,12 +92414,13 @@ and do_compile_matching repr partial ctx arg pmh = match pmh with
             | _ -> assert false)
         | {type_kind = Type_abstract; type_manifest = None} ->
           (* Format.eprintf "XXX Type_abstract@."; *)
-          Some {consts=[||]; blocks=[||]}
+          assert false
         | {type_kind = Type_record _} ->
           (* Format.eprintf "XXX Type_record@."; *)
-          Some {consts=[||]; blocks=[||]}
+          assert false
         | {type_kind = Type_open } ->
-          (* Format.eprintf "XXX Type_open@."; *)
+          (* Exceptions *)
+          (* Format.eprintf "XXX Type_open %s.@." cstr.cstr_name; *)
           Some {consts=[||]; blocks=[||]} in
 
       let names = match (Btype.repr pat.pat_type).desc with

lib/4.02.3/whole_compiler.ml

@@ -76697,7 +76697,7 @@ let make_clusters ({cases=cases ; actions=actions} as s) n_clusters k sw_names =
     end ;
     if i > 0 then zyva (i-1) (ir-1) in
 
-  zyva (len-1) (n_clusters-1);
+  zyva (len-1) (n_clusters-1) ;
   let acts = Array.make !index (fun _ -> assert false) in
   Hashtbl.iter (fun _ (i,act) -> acts.(i) <- act) t ;
   {cases = r ; actions = acts}
@@ -79934,12 +79934,13 @@ and do_compile_matching repr partial ctx arg pmh = match pmh with
             | _ -> assert false)
         | {type_kind = Type_abstract; type_manifest = None} ->
           (* Format.eprintf "XXX Type_abstract@."; *)
-          Some {consts=[||]; blocks=[||]}
+          assert false
         | {type_kind = Type_record _} ->
           (* Format.eprintf "XXX Type_record@."; *)
-          Some {consts=[||]; blocks=[||]}
+          assert false
         | {type_kind = Type_open } ->
-          (* Format.eprintf "XXX Type_open@."; *)
+          (* Exceptions *)
+          (* Format.eprintf "XXX Type_open %s.@." cstr.cstr_name; *)
           Some {consts=[||]; blocks=[||]} in
 
       let names = match (Btype.repr pat.pat_type).desc with