diff --git a/lib/codegen_deno.ml b/lib/codegen_deno.ml index 4678f0b5..2a289331 100644 --- a/lib/codegen_deno.ml +++ b/lib/codegen_deno.ml @@ -1256,7 +1256,30 @@ and gen_pattern_test scrut pat = match pat with | PatWildcard _ | PatVar _ -> "true" | PatLit lit -> scrut ^ " === " ^ gen_literal lit - | PatCon (id, _) -> scrut ^ ".tag === " ^ Printf.sprintf "%S" id.name + (* Descend into the sub-patterns. This used to be [PatCon (id, _)], testing + only the OUTERMOST tag and discarding the arguments -- so [Some(Circle(n))] + and [Some(Square(n))] emitted the SAME guard, the second arm was + unreachable, and the first arm's body ran for both. It type-checked; only + the emitted JavaScript was wrong, which is the worst place for it to be. + + The paths mirror gen_pattern_bindings below, which was already descending + correctly -- that asymmetry is why the bug was invisible: bindings landed + on the right values, so the output looked plausible. *) + | PatCon (id, args) -> + let tag_test = scrut ^ ".tag === " ^ Printf.sprintf "%S" id.name in + let sub_tests = + match args with + | [] -> [] + | [single] -> [gen_pattern_test (scrut ^ ".value") single] + | many -> + List.mapi (fun i p -> + gen_pattern_test + (scrut ^ ".values[" ^ string_of_int i ^ "]") p) many + in + (* A variable or wildcard sub-pattern tests "true"; dropping those keeps + the guard readable rather than "tag === X && true && true". *) + let meaningful = List.filter (fun s -> s <> "true") sub_tests in + String.concat " && " (tag_test :: meaningful) | PatTuple pats -> let conds = List.mapi (fun i p -> gen_pattern_test (scrut ^ "[" ^ string_of_int i ^ "]") p) pats in diff --git a/lib/js_codegen.ml b/lib/js_codegen.ml index adb80a67..e80c0bf2 100644 --- a/lib/js_codegen.ml +++ b/lib/js_codegen.ml @@ -376,9 +376,24 @@ and gen_pattern_test scrut pat = match pat with | PatWildcard _ | PatVar _ -> "true" | PatLit lit -> scrut ^ " === " ^ gen_literal lit - | PatCon (id, _) -> - (* Tagged-union variant: { tag: "Some", value: ... } *) - scrut ^ ".tag === " ^ Printf.sprintf "%S" id.name + (* Tagged-union variant: { tag: "Some", value: ... } + Sub-patterns MUST be tested too. This used to discard [args], so + [Some(Circle(n))] and [Some(Square(n))] produced the same guard and the + second arm was unreachable -- the first arm's body ran for both. Paths + mirror gen_pattern_bindings: .value for arity 1, .values[i] otherwise. *) + | PatCon (id, args) -> + let tag_test = scrut ^ ".tag === " ^ Printf.sprintf "%S" id.name in + let sub_tests = + match args with + | [] -> [] + | [single] -> [gen_pattern_test (scrut ^ ".value") single] + | many -> + List.mapi (fun i p -> + gen_pattern_test + (scrut ^ ".values[" ^ string_of_int i ^ "]") p) many + in + String.concat " && " + (tag_test :: List.filter (fun s -> s <> "true") sub_tests) | PatTuple pats -> let conds = List.mapi (fun i p -> gen_pattern_test (scrut ^ "[" ^ string_of_int i ^ "]") p diff --git a/lib/lua_codegen.ml b/lib/lua_codegen.ml index 3533c59e..8e7e165d 100644 --- a/lib/lua_codegen.ml +++ b/lib/lua_codegen.ml @@ -99,7 +99,23 @@ and gen_pattern_test scrut pat = match pat with | PatWildcard _ | PatVar _ -> "true" | PatLit lit -> Printf.sprintf "%s == %s" scrut (gen_lit lit) - | PatCon (id, _) -> Printf.sprintf "%s.tag == %S" scrut id.name + (* Sub-patterns must be tested, not discarded -- see codegen_deno.ml. Paths + mirror gen_pattern_bindings below: .value for arity 1, .values[i] else. + Lua indexes from 1, and the bindings walker uses the same expression, so + the two stay in step. *) + | PatCon (id, args) -> + let tag_test = Printf.sprintf "%s.tag == %S" scrut id.name in + let sub_tests = + match args with + | [] -> [] + | [single] -> [gen_pattern_test (scrut ^ ".value") single] + | many -> + List.mapi (fun i p -> + gen_pattern_test + (Printf.sprintf "%s.values[%d]" scrut i) p) many + in + String.concat " and " + (tag_test :: List.filter (fun s -> s <> "true") sub_tests) | PatTuple _ -> "true" (* arity match by structure, not tag *) | PatRecord _ -> "true" | PatAs (_, p) -> gen_pattern_test scrut p diff --git a/test/test_stdlib_aot.ml b/test/test_stdlib_aot.ml index de7a381f..fc90b2fa 100644 --- a/test/test_stdlib_aot.ml +++ b/test/test_stdlib_aot.ml @@ -340,9 +340,77 @@ let tuple_pattern_tests = [ Alcotest.test_case "nested (literal/var) tuple patterns -> Wasm" `Quick test_nested_tuple_patterns_wasm ] +(* ---- Nested CONSTRUCTOR patterns must be discriminated (#731) ------------- + + Regression guard. gen_pattern_test discarded PatCon's sub-patterns, so arms + differing only in a NESTED constructor emitted IDENTICAL guards: + + if (__scrut.tag === "Some") <- Some(Circle(n)) + if (__scrut.tag === "Some") <- Some(Square(n)) unreachable + + Every arm after the first was dead and the first arm's body ran for all of + them. It type-checked; only the emitted code was wrong, so nothing in the + compiler caught it -- and neither did this file, which had a nested-TUPLE + pattern test but none for nested CONSTRUCTORS on the JS-family backends. + + Verified to fail without the fix: reverting the PatCon arm in + codegen_deno.ml turns exactly this test red. *) +let nested_ctor_src = {| +module nestedctor; +use prelude::{ Option, Some, None }; + +pub type Shape = Circle(Int) | Square(Int) + +pub fn describe(s: Option) -> Int { + match s { + Some(Circle(n)) => n, + Some(Square(n)) => n + 1000, + None => -1, + } +} +|} + +let check_nested_ctor_guards (backend : string) (js : string) = + (* The inner constructor must appear in a GUARD, not merely in a binding -- + bindings were already descending correctly, which is what made the bug + invisible. *) + Alcotest.(check bool) + (backend ^ ": guard discriminates the inner Circle") + true (count_substr "tag === \"Circle\"" js > 0 + || count_substr "tag == \"Circle\"" js > 0); + Alcotest.(check bool) + (backend ^ ": guard discriminates the inner Square") + true (count_substr "tag === \"Square\"" js > 0 + || count_substr "tag == \"Square\"" js > 0) + +let test_deno_nested_ctor_guards () = + match Parse_driver.parse_string ~file:"" nested_ctor_src with + | exception e -> + Alcotest.failf "nested-ctor parse raised: %s" (Printexc.to_string e) + | prog -> + (match pipeline_to_deno prog with + | Error m -> Alcotest.failf "deno codegen failed: %s" m + | Ok js -> check_nested_ctor_guards "Deno-ESM" js) + +let test_js_nested_ctor_guards () = + match Parse_driver.parse_string ~file:"" nested_ctor_src with + | exception e -> + Alcotest.failf "nested-ctor parse raised: %s" (Printexc.to_string e) + | prog -> + (match pipeline_to_js prog with + | Error m -> Alcotest.failf "js codegen failed: %s" m + | Ok js -> check_nested_ctor_guards "JS" js) + +let nested_ctor_tests = + [ Alcotest.test_case "nested constructor patterns are discriminated (Deno)" + `Quick test_deno_nested_ctor_guards; + Alcotest.test_case "nested constructor patterns are discriminated (JS)" + `Quick test_js_nested_ctor_guards ] + let tests = [ ("STAGE-A AOT smoke (#136)", aot_smoke_tests); ("STAGE-A multi-module integration (#137)", integration_tests); ("cross-module constructor linking, Wasm (#138)", xmod_constructor_tests); ("Deno-ESM / JS no duplicate Option/Result constructor", dup_ctor_tests); - ("Wasm nested tuple patterns", tuple_pattern_tests) ] + ("Wasm nested tuple patterns", tuple_pattern_tests); + ("Nested constructor patterns discriminated (#731)", nested_ctor_tests) ]