vm-ext: phase B — extension registry module
sx_vm_extension.ml: handler type, extensible extension_state variant, EXTENSION first-class module signature. sx_vm_extensions.ml: register / dispatch / id_of_name / state_of_extension. install_dispatch () runs at module init, swapping Phase A's stub for the real registry. Rejects out-of-range opcode IDs (must be 200-247), duplicate IDs, duplicate names, and duplicate extension names. Tests: 9 new foundation cases — lookup hits/misses, end-to-end VM dispatch including opcode composition, all four rejection paths. +9 pass vs Phase A baseline, no regressions across 11 conformance suites.
This commit is contained in:
@@ -67,6 +67,14 @@ let rec deep_equal a b =
|
||||
| NativeFn _, NativeFn _ -> a == b
|
||||
| _ -> false
|
||||
|
||||
(* ====================================================================== *)
|
||||
(* Test extensions for the VM extension registry suite (Phase B) *)
|
||||
(* ====================================================================== *)
|
||||
|
||||
(* Extend the extensible variant from sx_vm_extension.ml so the test
|
||||
extensions below can carry their own private state. *)
|
||||
type Sx_vm_extension.extension_state += TestRegState of int ref
|
||||
|
||||
(* ====================================================================== *)
|
||||
(* Build evaluator environment with test platform functions *)
|
||||
(* ====================================================================== *)
|
||||
@@ -1323,7 +1331,145 @@ let run_foundation_tests () =
|
||||
Printf.printf " PASS: opcode 199 stays in core (catch-all)\n"
|
||||
| exn ->
|
||||
incr fail_count;
|
||||
Printf.printf " FAIL: opcode 199 — unexpected: %s\n" (Printexc.to_string exn))
|
||||
Printf.printf " FAIL: opcode 199 — unexpected: %s\n" (Printexc.to_string exn));
|
||||
|
||||
Printf.printf "\nSuite: vm-extension-registry\n";
|
||||
(* Sx_vm_extensions self-installs its dispatcher at module init. Reset
|
||||
the registry so prior loaded extensions don't interfere with this
|
||||
test. *)
|
||||
Sx_vm_extensions._reset_for_tests ();
|
||||
let module TestExt : Sx_vm_extension.EXTENSION = struct
|
||||
let name = "test_reg"
|
||||
let init () = TestRegState (ref 0)
|
||||
let opcodes _st = [
|
||||
(210, "test_reg.OP_PUSH_42", (fun vm _frame ->
|
||||
Sx_vm.push vm (Sx_types.Integer 42)));
|
||||
(211, "test_reg.OP_DOUBLE_TOS", (fun vm _frame ->
|
||||
let v = Sx_vm.pop vm in
|
||||
match v with
|
||||
| Sx_types.Integer n -> Sx_vm.push vm (Sx_types.Integer (n * 2))
|
||||
| _ -> failwith "OP_DOUBLE_TOS: not an integer"));
|
||||
]
|
||||
end in
|
||||
Sx_vm_extensions.register (module TestExt);
|
||||
|
||||
(match Sx_vm_extensions.id_of_name "test_reg.OP_PUSH_42" with
|
||||
| Some 210 ->
|
||||
incr pass_count;
|
||||
Printf.printf " PASS: id_of_name resolves opcode\n"
|
||||
| other ->
|
||||
incr fail_count;
|
||||
Printf.printf " FAIL: id_of_name: got %s\n"
|
||||
(match other with Some n -> string_of_int n | None -> "None"));
|
||||
|
||||
(match Sx_vm_extensions.id_of_name "nonexistent.OP" with
|
||||
| None ->
|
||||
incr pass_count;
|
||||
Printf.printf " PASS: id_of_name returns None for unknown\n"
|
||||
| Some _ ->
|
||||
incr fail_count;
|
||||
Printf.printf " FAIL: id_of_name should return None for unknown\n");
|
||||
|
||||
(match Sx_vm_extensions.state_of_extension "test_reg" with
|
||||
| Some (TestRegState _) ->
|
||||
incr pass_count;
|
||||
Printf.printf " PASS: state_of_extension returns extension state\n"
|
||||
| _ ->
|
||||
incr fail_count;
|
||||
Printf.printf " FAIL: state_of_extension lookup\n");
|
||||
|
||||
(match Sx_vm_extensions.state_of_extension "nonexistent" with
|
||||
| None ->
|
||||
incr pass_count;
|
||||
Printf.printf " PASS: state_of_extension None for unknown\n"
|
||||
| Some _ ->
|
||||
incr fail_count;
|
||||
Printf.printf " FAIL: state_of_extension should be None\n");
|
||||
|
||||
(* End-to-end dispatch through the VM. Bytecode runs OP_PUSH_42 then
|
||||
OP_RETURN (50); execute_module pops the result. *)
|
||||
let make_bc_seq bytes = ({
|
||||
vc_arity = 0; vc_rest_arity = -1; vc_locals = 0;
|
||||
vc_bytecode = bytes; vc_constants = [||];
|
||||
vc_bytecode_list = None; vc_constants_list = None;
|
||||
} : Sx_types.vm_code) in
|
||||
(let globals = Hashtbl.create 1 in
|
||||
try
|
||||
match Sx_vm.execute_module (make_bc_seq [| 210; 50 |]) globals with
|
||||
| Integer 42 ->
|
||||
incr pass_count;
|
||||
Printf.printf " PASS: dispatch routes opcode 210 -> push 42\n"
|
||||
| other ->
|
||||
incr fail_count;
|
||||
Printf.printf " FAIL: dispatch opcode 210: got %s\n"
|
||||
(Sx_types.inspect other)
|
||||
with exn ->
|
||||
incr fail_count;
|
||||
Printf.printf " FAIL: dispatch opcode 210 raised: %s\n"
|
||||
(Printexc.to_string exn));
|
||||
|
||||
(* Compose two extension opcodes: PUSH_42 then DOUBLE_TOS then RETURN.
|
||||
Verifies that successive extension dispatches share VM state. *)
|
||||
(let globals = Hashtbl.create 1 in
|
||||
try
|
||||
match Sx_vm.execute_module (make_bc_seq [| 210; 211; 50 |]) globals with
|
||||
| Integer 84 ->
|
||||
incr pass_count;
|
||||
Printf.printf " PASS: extension opcodes compose (42 -> 84)\n"
|
||||
| other ->
|
||||
incr fail_count;
|
||||
Printf.printf " FAIL: composed opcodes: got %s\n"
|
||||
(Sx_types.inspect other)
|
||||
with exn ->
|
||||
incr fail_count;
|
||||
Printf.printf " FAIL: composed opcodes raised: %s\n"
|
||||
(Printexc.to_string exn));
|
||||
|
||||
(* Duplicate opcode-id detection. *)
|
||||
let module DupExt : Sx_vm_extension.EXTENSION = struct
|
||||
let name = "dup_check"
|
||||
let init () = TestRegState (ref 0)
|
||||
let opcodes _st = [
|
||||
(210, "dup_check.OP_X", (fun _vm _frame -> ()));
|
||||
]
|
||||
end in
|
||||
(try
|
||||
Sx_vm_extensions.register (module DupExt);
|
||||
incr fail_count;
|
||||
Printf.printf " FAIL: duplicate opcode id should have raised\n"
|
||||
with Failure _ ->
|
||||
incr pass_count;
|
||||
Printf.printf " PASS: duplicate opcode id rejected\n");
|
||||
|
||||
(* Out-of-range opcode-id detection. *)
|
||||
let module OutExt : Sx_vm_extension.EXTENSION = struct
|
||||
let name = "out_of_range"
|
||||
let init () = TestRegState (ref 0)
|
||||
let opcodes _st = [
|
||||
(300, "out_of_range.OP_X", (fun _vm _frame -> ()));
|
||||
]
|
||||
end in
|
||||
(try
|
||||
Sx_vm_extensions.register (module OutExt);
|
||||
incr fail_count;
|
||||
Printf.printf " FAIL: out-of-range opcode should have raised\n"
|
||||
with Failure _ ->
|
||||
incr pass_count;
|
||||
Printf.printf " PASS: out-of-range opcode rejected\n");
|
||||
|
||||
(* Duplicate extension-name detection. *)
|
||||
let module SameNameExt : Sx_vm_extension.EXTENSION = struct
|
||||
let name = "test_reg" (* same as TestExt above *)
|
||||
let init () = TestRegState (ref 0)
|
||||
let opcodes _st = []
|
||||
end in
|
||||
(try
|
||||
Sx_vm_extensions.register (module SameNameExt);
|
||||
incr fail_count;
|
||||
Printf.printf " FAIL: duplicate extension name should have raised\n"
|
||||
with Failure _ ->
|
||||
incr pass_count;
|
||||
Printf.printf " PASS: duplicate extension name rejected\n")
|
||||
|
||||
|
||||
(* ====================================================================== *)
|
||||
|
||||
Reference in New Issue
Block a user