diff --git a/changes/untagged-default-arm.fix.md b/changes/untagged-default-arm.fix.md new file mode 100644 index 0000000000..d0f84fcff6 --- /dev/null +++ b/changes/untagged-default-arm.fix.md @@ -0,0 +1 @@ +- Fix untagged variant switches with a default arm matching class instances in the object case and literals in a payload case of their kind. diff --git a/compiler/core/lam_compile.ml b/compiler/core/lam_compile.ml index 05fbf7762b..22cc6b68ac 100644 --- a/compiler/core/lam_compile.ml +++ b/compiler/core/lam_compile.ml @@ -780,10 +780,34 @@ let compile output_prefix = | NonComplete, NonComplete -> true | _ -> false in + (* A literal handled by the default would otherwise pass the + check of a payload arm of its kind *) + let a_literal_reaches_an_arm () = + let arm_types = + Ext_list.filter_map sw_blocks (fun (key, _) -> + match tag_of_switch_key key with + | Some {tag_type = Some (Payload_shape block_type)} -> + Some block_type + | Some _ | None -> None) + in + Ext_list.exists literal_cases + (fun (literal : Variant_runtime.literal_tag) -> + Ext_list.exists arm_types + (fun (block_type : Variant_runtime.block_type) -> + match (literal, block_type) with + | String _, StringType + | (Int _ | Float _), (IntType | FloatType) + | BigInt _, BigintType + | Bool _, BooleanType + | _, UnknownType -> + true + | _, _ -> false)) + in if untagged && List.length sw_consts = 0 && eq_default sw_num_default sw_blocks_default + && not (a_literal_reaches_an_arm ()) then let has_null_case = List.mem Variant_runtime.Null literal_cases in compile_cases ~untagged ~cxt @@ -864,26 +888,25 @@ let compile output_prefix = | _ -> false) typeof_clauses in - let clauses_have_array_case = - List.exists - (function - | Variant_runtime.Payload_shape (InstanceType Array), _ -> true - | _ -> false) - not_typeof_clauses - in - let type_has_array_case = - List.exists - (function - | Variant_runtime.InstanceType Array -> true - | _ -> false) - block_cases - in - (* When there's an ObjectType typeof case, null and arrays can - incorrectly match it (typeof null === typeof [] === "object"). - Guard against them when they should fall through to default. *) + (* When there's an ObjectType typeof case, null, arrays and class + instances can incorrectly match it (typeof null === typeof [] === + "object"). Guard against them when they should fall through to + default: null, and the instance cases without an arm of their own. *) let needs_null_guard = has_object_typeof && has_null_case in - let needs_array_guard = - has_object_typeof && type_has_array_case && not clauses_have_array_case + let unmatched_instances = + if not has_object_typeof then [] + else + Ext_list.filter_map block_cases (function + | Variant_runtime.InstanceType instance + when not + (List.exists + (function + | Variant_runtime.Payload_shape (InstanceType i), _ -> + i = instance + | _ -> false) + not_typeof_clauses) -> + Some instance + | _ -> None) in let rec build_if_chain remaining_clauses = match remaining_clauses with @@ -898,12 +921,16 @@ let compile output_prefix = let typeof_switch () = S.string_switch ?default ?declaration (E.typeof e) typeof_clauses in + let guards = + (if needs_null_guard then [E.is_null e] else []) + @ List.map + (fun instance -> E.emit_check (IsInstanceOf (instance, Expr e))) + unmatched_instances + in let guard = - match (needs_null_guard, needs_array_guard) with - | true, true -> Some (E.or_ (E.is_null e) (E.is_array e)) - | true, false -> Some (E.is_null e) - | false, true -> Some (E.is_array e) - | false, false -> None + match guards with + | [] -> None + | first :: rest -> Some (List.fold_left E.or_ first rest) in match (guard, default) with | Some guard, Some default_body -> diff --git a/compiler/ml/UntaggedVariants.md b/compiler/ml/UntaggedVariants.md index a3e21a8352..daaad8e6f4 100644 --- a/compiler/ml/UntaggedVariants.md +++ b/compiler/ml/UntaggedVariants.md @@ -192,7 +192,10 @@ constructor: The "is a literal case" test is the smaller of two equivalent expressions: the disjunction of `x === literal` over the literal cases, or the conjunction of the negated payload checks (with a payload check replaced by the literal -disjunction where a literal overlaps it). +disjunction where a literal overlaps it). A `switch` whose arms name no +literal case still tests the literals first when one of them would pass the +check of a payload arm, such as `@as("lit")` beside a `string` arm, so that +it reaches the default arm. - Implementation: `lam_compile.ml:compile_switch`, `ast_untagged_variants.ml:Dynamic_checks.is_a_literal_case`. @@ -227,12 +230,13 @@ number, integral or not. ### 9. `null` and arrays are not objects -`typeof null` and `typeof []` are `"object"`. The object case never receives -`null` when the variant has an `@as(null)` case, and never receives an array -when the variant has an array or tuple case: the two-arm form adds the checks -of rule 8, and the `switch (typeof x)` form is preceded by -`x === null` / `Array.isArray(x)` guards that send those values to the default -arm when their own arm is absent. +`typeof null` and `typeof []` are `"object"`, and so is the `typeof` of a +class instance. The object case never receives `null` when the variant has an +`@as(null)` case, and never receives a value of another instance case (array, +tuple or class): the two-arm form adds the checks of rule 8, and the +`switch (typeof x)` form is preceded by `x === null`, `Array.isArray(x)` and +`x instanceof C` guards that send those values to the default arm when their +own arm is absent. | Declaration | `switch` arms | Value | Arm | | --- | --- | --- | --- | @@ -241,9 +245,10 @@ arm when their own arm is absent. | | `GObject(_)`, `_` | `[]`, `null` | `_` | - Implementation: `lam_compile.ml:compile_untagged_cases` (`needs_null_guard`, - `needs_array_guard`), `Dynamic_checks.add_runtime_type_check`. -- Tests: `spec_test` rule 9; `UntaggedVariants.res` (`ObjectAndNull`, `Json`). -- Shaped by #6219, #7303, #8253, #8255, #8279. + `unmatched_instances`), `Dynamic_checks.add_runtime_type_check`. +- Tests: `spec_test` rule 9; `UntaggedVariants.res` (`ObjectAndNull`, `Json`); + `tests/tests/src/untagged_default_arm_test.res`. +- Shaped by #6219, #7303, #8253, #8255, #8279, #8995. ### 10. Values outside every case diff --git a/tests/tests/src/untagged_default_arm_test.mjs b/tests/tests/src/untagged_default_arm_test.mjs new file mode 100644 index 0000000000..49ddffd59e --- /dev/null +++ b/tests/tests/src/untagged_default_arm_test.mjs @@ -0,0 +1,63 @@ +// Generated by ReScript, PLEASE EDIT WITH CARE + +import * as Mocha from "mocha"; +import * as Test_utils from "./test_utils.mjs"; + +function id(x) { + return x; +} + +function objectOrString(value) { + if (value instanceof RegExp || value instanceof Date) { + return "other"; + } + switch (typeof value) { + case "object" : + return "O"; + case "string" : + return "S"; + default: + return "other"; + } +} + +function textOrRecord(value) { + if (value === "lit") { + return "other"; + } + switch (typeof value) { + case "string" : + return "text"; + case "object" : + return "record"; + default: + return "other"; + } +} + +Mocha.describe("Untagged_default_arm_test", () => { + Mocha.test("an instance handled by the default is not an object case", () => { + Test_utils.eq("File \"untagged_default_arm_test.res\", line 31, characters 7-14", "other", objectOrString(id(new Date()))); + Test_utils.eq("File \"untagged_default_arm_test.res\", line 32, characters 7-14", "other", objectOrString(id(/a/))); + Test_utils.eq("File \"untagged_default_arm_test.res\", line 33, characters 7-14", "O", objectOrString(id({ + x: 1 + }))); + Test_utils.eq("File \"untagged_default_arm_test.res\", line 34, characters 7-14", "S", objectOrString(id("s"))); + Test_utils.eq("File \"untagged_default_arm_test.res\", line 35, characters 7-14", "other", objectOrString(id(1))); + }); + Mocha.test("a literal handled by the default is not a string case", () => { + Test_utils.eq("File \"untagged_default_arm_test.res\", line 39, characters 7-14", "other", textOrRecord(id("lit"))); + Test_utils.eq("File \"untagged_default_arm_test.res\", line 40, characters 7-14", "text", textOrRecord(id("lit2"))); + Test_utils.eq("File \"untagged_default_arm_test.res\", line 41, characters 7-14", "record", textOrRecord(id({ + x: 1 + }))); + Test_utils.eq("File \"untagged_default_arm_test.res\", line 42, characters 7-14", "other", textOrRecord(id(1))); + }); +}); + +export { + id, + objectOrString, + textOrRecord, +} +/* Not a pure module */ diff --git a/tests/tests/src/untagged_default_arm_test.res b/tests/tests/src/untagged_default_arm_test.res new file mode 100644 index 0000000000..dce3172e6a --- /dev/null +++ b/tests/tests/src/untagged_default_arm_test.res @@ -0,0 +1,44 @@ +open Mocha +open Test_utils + +@inline(never) let id = x => x + +// A switch with a default arm keeps the cases it does not name out of the +// arms it names (#8995) +@unboxed +type instances = D(Date.t) | R(RegExp.t) | O({x: int}) | S(string) | I(int) | F(int => int) + +let objectOrString = value => + switch value { + | O(_) => "O" + | S(_) => "S" + | _ => "other" + } + +@unboxed +type literals = + | @as("lit") Lit | Text(string) | Count(int) | Flag(bool) | Rec({x: int}) | Fn(int => int) + +let textOrRecord = value => + switch value { + | Text(_) => "text" + | Rec(_) => "record" + | _ => "other" + } + +describe(__MODULE__, () => { + test("an instance handled by the default is not an object case", () => { + eq(__LOC__, "other", objectOrString(id(D(Date.make())))) + eq(__LOC__, "other", objectOrString(id(R(/a/)))) + eq(__LOC__, "O", objectOrString(id(O({x: 1})))) + eq(__LOC__, "S", objectOrString(id(S("s")))) + eq(__LOC__, "other", objectOrString(id(I(1)))) + }) + + test("a literal handled by the default is not a string case", () => { + eq(__LOC__, "other", textOrRecord(id(Lit))) + eq(__LOC__, "text", textOrRecord(id(Text("lit2")))) + eq(__LOC__, "record", textOrRecord(id(Rec({x: 1})))) + eq(__LOC__, "other", textOrRecord(id(Count(1)))) + }) +})