Fix compilation of unknown.

Author: cristianoc

jscomp/core/js_exp_make.ml

@@ -783,7 +783,9 @@ let rec is_a_literal_case ~(literal_cases : Lambda.literal list) ~block_cases (e
     (* We don't know the type of unknown, so we need to express:
        this is not one of the literals *)
     (match literal_cases with
-      | [] -> { expression_desc = Bool true; comment=None}
+      | [] ->
+        (* this should not happen *)
+        assert false
       | l1 :: others ->
         let is_literal_1 = is_literal_case l1 in
         Ext_list.fold_right others is_literal_1 (fun literal_n acc ->
@@ -797,7 +799,7 @@ let rec is_a_literal_case ~(literal_cases : Lambda.literal list) ~block_cases (e
     bin And (is_block_case c1) (is_a_literal_case ~literal_cases ~block_cases:rest e)
   | [] -> assert false
 
-let is_tag ?(has_null_undefined_other=(false, false, false)) (e : t) : t =
+let is_int_tag ?(has_null_undefined_other=(false, false, false)) (e : t) : t =
   let (has_null, has_undefined, has_other) = has_null_undefined_other in
   if has_null && (has_undefined = false) && (has_other = false) then (* null *)
     { expression_desc = Bin (EqEqEq, e, nil); comment=None }

jscomp/core/js_exp_make.mli

@@ -202,7 +202,7 @@ val neq_null_undefined_boolean : ?comment:string -> t -> t -> t
 
 val is_type_number : ?comment:string -> t -> t
 
-val is_tag : ?has_null_undefined_other:(bool * bool * bool) -> t -> t
+val is_int_tag : ?has_null_undefined_other:(bool * bool * bool) -> t -> t
 
 val is_a_literal_case : literal_cases:Lambda.literal list -> block_cases:Lambda.block_type list -> t -> t
 

jscomp/core/lam_compile.ml

@@ -172,7 +172,7 @@ let get_literal_cases (sw_names : Lambda.switch_names option) =
   | Some { consts  } ->
     Ext_array.iter consts (function
     | {literal = Some literal} -> res := literal :: !res
-    | {literal = None} -> ()
+    | {name; literal = None} -> res := String name :: !res
     )
   );
   !res
@@ -691,14 +691,14 @@ and compile_switch (switch_arg : Lam.t) (sw : Lam.lambda_switch)
         else
           (* [e] will be used twice  *)
           let dispatch e =
-            let is_tag =
+            let is_a_literal_case =
               if block_cases <> []
-              then E.is_a_literal_case ~literal_cases:(get_literal_cases sw_names) ~block_cases e
+              then
+                E.is_a_literal_case ~literal_cases:(get_literal_cases sw_names) ~block_cases e
               else
-               E.is_tag ~has_null_undefined_other:(has_null_undefined_other sw_names) e in
-            S.if_ is_tag
+               E.is_int_tag ~has_null_undefined_other:(has_null_undefined_other sw_names) e in
+            S.if_ is_a_literal_case
               (compile_cases cxt e sw_consts sw_num_default get_const_name)
-              (* default still needed, could simplified*)
               ~else_:
                 (compile_cases ~untagged cxt (if untagged then e else E.tag ~name:tag_name e) sw_blocks sw_blocks_default
                    get_block_name)

jscomp/ml/matching.ml

@@ -1329,11 +1329,10 @@ let make_constr_matching p def ctx = function
     [] -> fatal_error "Matching.make_constr_matching"
   | ((arg, _mut) :: argl) ->
       let cstr = pat_as_constr p in
+      let untagged =
+        Ext_list.exists cstr.cstr_attributes (function ({txt}, _) -> txt = "unboxed") in
       let newargs =
-        if cstr.cstr_inlined <> None ||
-          Ext_list.exists cstr.cstr_attributes (function
-            | ({txt="unboxed"}, _) -> true
-            | _ -> false) then
+        if cstr.cstr_inlined <> None || (untagged && cstr.cstr_args <> []) then
           (arg, Alias) :: argl
         else match cstr.cstr_tag with
         | Cstr_block _ when

jscomp/test/UntaggedVariants.js

@@ -92,11 +92,15 @@ var TwoObjects = {
 };
 
 function classify$2(x) {
-  if (x === "A") {
-    return "a";
-  } else {
-    return "b";
+  if (x === "A" || x === "B") {
+    if (x === "A") {
+      return "a";
+    } else {
+      return "b";
+    }
   }
+  console.log(x);
+  return "Unknown";
 }
 
 var Unknown = {
@@ -211,6 +215,26 @@ var Json = {
   classify: classify$6
 };
 
+function check(s, y) {
+  if (s === "B") {
+    return 42;
+  }
+  var x = s[0];
+  if (x === "B") {
+    return 42;
+  }
+  var tmp = s[1];
+  if (tmp === "B" && x !== y) {
+    return 41;
+  } else {
+    return 42;
+  }
+}
+
+var TrickyNested = {
+  check: check
+};
+
 var i = 42;
 
 var i2 = 42.5;
@@ -244,4 +268,5 @@ exports.MultipleBlocks = MultipleBlocks;
 exports.OnlyBlocks = OnlyBlocks;
 exports.WithArray = WithArray;
 exports.Json = Json;
+exports.TrickyNested = TrickyNested;
 /* l2 Not a pure module */

jscomp/test/UntaggedVariants.res

@@ -183,3 +183,16 @@ let classify  (x : t) : tagged_t =
     JSONObject (Obj.magic x)  
  */
 }
+
+module TrickyNested = {
+  @unboxed
+  type rec t =
+    | A((t, t))
+    | B
+
+  let check = (s, y) =>
+    switch s {
+    | A((A(x), B)) if x !== y => 41
+    | _ => 42
+    }
+}

jscomp/test/variantsMatching.js

@@ -278,7 +278,7 @@ function isWhyNot(x) {
 }
 
 function plus$3(x, y) {
-  if (x === null || x === undefined) {
+  if (x === undefined || x === null || x === "WhyNotAnotherOne") {
     switch (x) {
       case null :
       case undefined :
@@ -287,13 +287,13 @@ function plus$3(x, y) {
           break;
 
     }
-  } else if (!(y === null || y === undefined)) {
+  } else if (!(y === undefined || y === null || y === "WhyNotAnotherOne")) {
     return {
             x: x.x + y.x,
             y: x.y + y.y
           };
   }
-  if (!(y === null || y === undefined)) {
+  if (!(y === undefined || y === null || y === "WhyNotAnotherOne")) {
     return "WhyNotAnotherOne";
   }
   switch (y) {
@@ -307,7 +307,7 @@ function plus$3(x, y) {
 }
 
 function kind$1(x) {
-  if (!(x === null || x === undefined)) {
+  if (!(x === undefined || x === null || x === "WhyNotAnotherOne")) {
     return "present";
   }
   switch (x) {