diff --git a/hosts/ocaml/bin/run_tests.ml b/hosts/ocaml/bin/run_tests.ml index 6b7a5460..537c076a 100644 --- a/hosts/ocaml/bin/run_tests.ml +++ b/hosts/ocaml/bin/run_tests.ml @@ -1668,14 +1668,94 @@ let run_foundation_tests () = Printf.printf " FAIL: OP_BIF_LENGTH raised: %s\n" (Printexc.to_string exn)); - (* A still-stubbed opcode (231 = erlang.OP_BIF_HD) raises the + (* More real handlers (Phase 10b batch): build a list/tuple constant + and exercise HD/TL/TUPLE_SIZE/IS_* end-to-end through the VM. *) + (let mk_dict kvs = + let h = Hashtbl.create 4 in + List.iter (fun (k, v) -> Hashtbl.replace h k v) kvs; + Sx_types.Dict h in + let er_nil = mk_dict [("tag", Sx_types.String "nil")] in + let er_cons hd tl = mk_dict [("tag", Sx_types.String "cons"); + ("head", hd); ("tail", tl)] in + let er_tuple es = mk_dict [("tag", Sx_types.String "tuple"); + ("elements", Sx_types.List es)] in + let er_atom nm = mk_dict [("tag", Sx_types.String "atom"); + ("name", Sx_types.String nm)] in + let lst3 = er_cons (Sx_types.Integer 7) + (er_cons (Sx_types.Integer 8) + (er_cons (Sx_types.Integer 9) er_nil)) in + let tup3 = er_tuple [Sx_types.Integer 1; Sx_types.Integer 2; + Sx_types.Integer 3] in + let run consts bc = + let code = ({ + vc_arity = 0; vc_rest_arity = -1; vc_locals = 0; + vc_bytecode = bc; vc_constants = consts; + vc_bytecode_list = None; vc_constants_list = None; + } : Sx_types.vm_code) in + Sx_vm.execute_module code (Hashtbl.create 1) in + let nm = function + | Sx_types.Dict d -> + (match Hashtbl.find_opt d "name" with + | Some (Sx_types.String s) -> s | _ -> "?") + | _ -> "?" in + let check label want got = + if got = want then begin + incr pass_count; + Printf.printf " PASS: %s\n" label + end else begin + incr fail_count; + Printf.printf " FAIL: %s: got %s\n" label (Sx_types.inspect got) + end in + (* HD [7,8,9] -> 7 *) + check "OP_BIF_HD [7,8,9] -> 7" (Sx_types.Integer 7) + (run [| lst3 |] [| 1;0;0; 231; 50 |]); + (* TL [7,8,9] -> [8,9], check its HD = 8 *) + check "OP_BIF_TL then HD -> 8" (Sx_types.Integer 8) + (run [| lst3 |] [| 1;0;0; 232; 231; 50 |]); + (* TUPLE_SIZE {1,2,3} -> 3 *) + check "OP_BIF_TUPLE_SIZE {1,2,3} -> 3" (Sx_types.Integer 3) + (run [| tup3 |] [| 1;0;0; 234; 50 |]); + (* IS_INTEGER 42 -> true ; IS_INTEGER [..] -> false *) + (match run [| Sx_types.Integer 42 |] [| 1;0;0; 236; 50 |] with + | v when nm v = "true" -> + incr pass_count; Printf.printf " PASS: OP_BIF_IS_INTEGER 42 -> true\n" + | v -> incr fail_count; + Printf.printf " FAIL: IS_INTEGER 42: got %s\n" (Sx_types.inspect v)); + (match run [| lst3 |] [| 1;0;0; 236; 50 |] with + | v when nm v = "false" -> + incr pass_count; Printf.printf " PASS: OP_BIF_IS_INTEGER list -> false\n" + | v -> incr fail_count; + Printf.printf " FAIL: IS_INTEGER list: got %s\n" (Sx_types.inspect v)); + (* IS_ATOM atom -> true ; IS_LIST nil -> true ; IS_TUPLE tuple -> true *) + (match run [| er_atom "ok" |] [| 1;0;0; 237; 50 |] with + | v when nm v = "true" -> + incr pass_count; Printf.printf " PASS: OP_BIF_IS_ATOM ok -> true\n" + | v -> incr fail_count; + Printf.printf " FAIL: IS_ATOM: got %s\n" (Sx_types.inspect v)); + (match run [| er_nil |] [| 1;0;0; 238; 50 |] with + | v when nm v = "true" -> + incr pass_count; Printf.printf " PASS: OP_BIF_IS_LIST nil -> true\n" + | v -> incr fail_count; + Printf.printf " FAIL: IS_LIST nil: got %s\n" (Sx_types.inspect v)); + (match run [| tup3 |] [| 1;0;0; 239; 50 |] with + | v when nm v = "true" -> + incr pass_count; Printf.printf " PASS: OP_BIF_IS_TUPLE {..} -> true\n" + | v -> incr fail_count; + Printf.printf " FAIL: IS_TUPLE: got %s\n" (Sx_types.inspect v)); + (match run [| tup3 |] [| 1;0;0; 238; 50 |] with + | v when nm v = "false" -> + incr pass_count; Printf.printf " PASS: OP_BIF_IS_LIST tuple -> false\n" + | v -> incr fail_count; + Printf.printf " FAIL: IS_LIST tuple: got %s\n" (Sx_types.inspect v))); + + (* A still-stubbed opcode (233 = erlang.OP_BIF_ELEMENT) raises the not-wired Eval_error — confirms the honest-failure path remains for opcodes whose real handlers haven't landed. *) (let globals = Hashtbl.create 1 in try - ignore (Sx_vm.execute_module (make_bc_seq [| 231; 50 |]) globals); + ignore (Sx_vm.execute_module (make_bc_seq [| 233; 50 |]) globals); incr fail_count; - Printf.printf " FAIL: erlang.OP_BIF_HD dispatch should have raised\n" + Printf.printf " FAIL: erlang.OP_BIF_ELEMENT dispatch should have raised\n" with | Sx_types.Eval_error msg when (let needle = "not yet wired" in diff --git a/hosts/ocaml/lib/extensions/erlang_ext.ml b/hosts/ocaml/lib/extensions/erlang_ext.ml index 0ac74fd7..22f78f13 100644 --- a/hosts/ocaml/lib/extensions/erlang_ext.ml +++ b/hosts/ocaml/lib/extensions/erlang_ext.ml @@ -99,6 +99,84 @@ module M : Sx_vm_extension.EXTENSION = struct in Sx_vm.push vm (Integer (walk 0 v)))) in + (* Phase 10b — simple hot-BIF handlers. Erlang bool is the atom + {"tag"->"atom"; "name"->"true"|"false"}; mk_atom builds it. *) + let mk_atom nm = + let h = Hashtbl.create 2 in + Hashtbl.replace h "tag" (String "atom"); + Hashtbl.replace h "name" (String nm); + Dict h + in + let er_bool b = mk_atom (if b then "true" else "false") in + let is_tag v t = match v with + | Dict d -> er_tag d = t + | _ -> false + in + let op_bif_hd = + (231, "erlang.OP_BIF_HD", + (fun (vm : Sx_vm.vm) _f -> + bump (); + match Sx_vm.pop vm with + | Dict d when er_tag d = "cons" -> + (match Hashtbl.find_opt d "head" with + | Some h -> Sx_vm.push vm h + | None -> raise (Eval_error "erlang.OP_BIF_HD: cons without :head")) + | _ -> raise (Eval_error "erlang.OP_BIF_HD: not a cons"))) + in + let op_bif_tl = + (232, "erlang.OP_BIF_TL", + (fun (vm : Sx_vm.vm) _f -> + bump (); + match Sx_vm.pop vm with + | Dict d when er_tag d = "cons" -> + (match Hashtbl.find_opt d "tail" with + | Some t -> Sx_vm.push vm t + | None -> raise (Eval_error "erlang.OP_BIF_TL: cons without :tail")) + | _ -> raise (Eval_error "erlang.OP_BIF_TL: not a cons"))) + in + let op_bif_tuple_size = + (234, "erlang.OP_BIF_TUPLE_SIZE", + (fun (vm : Sx_vm.vm) _f -> + bump (); + match Sx_vm.pop vm with + | Dict d when er_tag d = "tuple" -> + let n = match Hashtbl.find_opt d "elements" with + | Some (List es) -> List.length es + | Some (ListRef r) -> List.length !r + | _ -> raise (Eval_error + "erlang.OP_BIF_TUPLE_SIZE: tuple without :elements") + in + Sx_vm.push vm (Integer n) + | _ -> raise (Eval_error "erlang.OP_BIF_TUPLE_SIZE: not a tuple"))) + in + let op_bif_is_integer = + (236, "erlang.OP_BIF_IS_INTEGER", + (fun (vm : Sx_vm.vm) _f -> + bump (); + let v = Sx_vm.pop vm in + Sx_vm.push vm (er_bool (match v with Integer _ -> true | _ -> false)))) + in + let op_bif_is_atom = + (237, "erlang.OP_BIF_IS_ATOM", + (fun (vm : Sx_vm.vm) _f -> + bump (); + let v = Sx_vm.pop vm in + Sx_vm.push vm (er_bool (is_tag v "atom")))) + in + let op_bif_is_list = + (238, "erlang.OP_BIF_IS_LIST", + (fun (vm : Sx_vm.vm) _f -> + bump (); + let v = Sx_vm.pop vm in + Sx_vm.push vm (er_bool (is_tag v "cons" || is_tag v "nil")))) + in + let op_bif_is_tuple = + (239, "erlang.OP_BIF_IS_TUPLE", + (fun (vm : Sx_vm.vm) _f -> + bump (); + let v = Sx_vm.pop vm in + Sx_vm.push vm (er_bool (is_tag v "tuple")))) + in [ op 222 "erlang.OP_PATTERN_TUPLE"; op 223 "erlang.OP_PATTERN_LIST"; @@ -109,15 +187,15 @@ module M : Sx_vm_extension.EXTENSION = struct op 228 "erlang.OP_SPAWN"; op 229 "erlang.OP_SEND"; op_bif_length; - op 231 "erlang.OP_BIF_HD"; - op 232 "erlang.OP_BIF_TL"; + op_bif_hd; + op_bif_tl; op 233 "erlang.OP_BIF_ELEMENT"; - op 234 "erlang.OP_BIF_TUPLE_SIZE"; + op_bif_tuple_size; op 235 "erlang.OP_BIF_LISTS_REVERSE"; - op 236 "erlang.OP_BIF_IS_INTEGER"; - op 237 "erlang.OP_BIF_IS_ATOM"; - op 238 "erlang.OP_BIF_IS_LIST"; - op 239 "erlang.OP_BIF_IS_TUPLE"; + op_bif_is_integer; + op_bif_is_atom; + op_bif_is_list; + op_bif_is_tuple; ] end