diff --git a/hosts/ocaml/bin/run_tests.ml b/hosts/ocaml/bin/run_tests.ml index b08eadd5..4995b507 100644 --- a/hosts/ocaml/bin/run_tests.ml +++ b/hosts/ocaml/bin/run_tests.ml @@ -1469,7 +1469,56 @@ let run_foundation_tests () = Printf.printf " FAIL: duplicate extension name should have raised\n" with Failure _ -> incr pass_count; - Printf.printf " PASS: duplicate extension name rejected\n") + Printf.printf " PASS: duplicate extension name rejected\n"); + + Printf.printf "\nSuite: extension-opcode-id primitive\n"; + let prim = Hashtbl.find Sx_primitives.primitives "extension-opcode-id" in + + (* Known opcode (registered by TestExt above). *) + (match prim [String "test_reg.OP_PUSH_42"] with + | Integer 210 -> + incr pass_count; + Printf.printf " PASS: primitive returns Integer for registered opcode\n" + | other -> + incr fail_count; + Printf.printf " FAIL: registered opcode lookup: got %s\n" + (Sx_types.inspect other)); + + (* Unknown opcode → Nil. *) + (match prim [String "nonexistent.OP_X"] with + | Nil -> + incr pass_count; + Printf.printf " PASS: primitive returns nil for unknown opcode\n" + | other -> + incr fail_count; + Printf.printf " FAIL: unknown opcode lookup: got %s\n" + (Sx_types.inspect other)); + + (* Symbol arg also accepted (compilers may pass quoted symbols). *) + (match prim [Symbol "test_reg.OP_DOUBLE_TOS"] with + | Integer 211 -> + incr pass_count; + Printf.printf " PASS: primitive accepts Symbol args\n" + | other -> + incr fail_count; + Printf.printf " FAIL: symbol arg: got %s\n" (Sx_types.inspect other)); + + (* Wrong arity / type raises Eval_error. *) + (try + let _ = prim [] in + incr fail_count; + Printf.printf " FAIL: zero args should have raised\n" + with Sx_types.Eval_error _ -> + incr pass_count; + Printf.printf " PASS: zero args rejected\n"); + + (try + let _ = prim [Integer 42] in + incr fail_count; + Printf.printf " FAIL: integer arg should have raised\n" + with Sx_types.Eval_error _ -> + incr pass_count; + Printf.printf " PASS: integer arg rejected\n") (* ====================================================================== *) diff --git a/hosts/ocaml/lib/sx_vm_extensions.ml b/hosts/ocaml/lib/sx_vm_extensions.ml index 8e1dd288..e301b57c 100644 --- a/hosts/ocaml/lib/sx_vm_extensions.ml +++ b/hosts/ocaml/lib/sx_vm_extensions.ml @@ -87,3 +87,22 @@ let install_dispatch () = Sx_vm.extension_dispatch_ref := dispatch let () = install_dispatch () + +(** Compiler-side opcode lookup: register the [extension-opcode-id] + primitive. Compilers ([lib/compiler.sx]) call this to emit + extension opcodes by name. Returns [Integer id] when registered, + [Nil] otherwise — so missing extensions degrade to a fallback + rather than failure. *) +let () = + Sx_primitives.register "extension-opcode-id" (fun args -> + match args with + | [Sx_types.String name] -> + (match id_of_name name with + | Some id -> Sx_types.Integer id + | None -> Sx_types.Nil) + | [Sx_types.Symbol name] -> + (match id_of_name name with + | Some id -> Sx_types.Integer id + | None -> Sx_types.Nil) + | _ -> raise (Sx_types.Eval_error + "extension-opcode-id: expected one string or symbol"))