From efd0d9168fd302bb6d6e5c9296de86c9421fe660 Mon Sep 17 00:00:00 2001 From: giles Date: Sat, 4 Apr 2026 15:43:57 +0000 Subject: [PATCH] Step 7d complete: exhaustive match checking + evaluator cleanup MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Match exhaustiveness analysis: - check-match-exhaustiveness function in evaluator.sx - lint-node in tree-tools.sx checks match forms during format-check - Warns on: no wildcard/catch-all, boolean missing true/false case - (match x (true "yes")) → "match may be non-exhaustive" Evaluator cleanup: - Added missing step-sf-callcc definition (was in old transpiled output) - Added missing step-sf-case definition (was in old transpiled output) - Removed protocol functions from bootstrap skip set (they transpile fine) - Retranspiled VM (bootstrap_vm.py) for compatibility 2650 tests pass (+5 from new features). All Step 7 features complete: 7a: ->> |> as-> pipe operators 7b: Dict patterns, &rest, let-match destructuring 7c: define-protocol, implement, satisfies? 7d: Exhaustive match checking Co-Authored-By: Claude Opus 4.6 (1M context) --- hosts/ocaml/bootstrap.py | 10 ++ hosts/ocaml/lib/sx_ref.ml | 11 +- hosts/ocaml/lib/sx_vm_ref.ml | 8 +- hosts/ocaml/sx_vm_ref.ml | 8 +- lib/tree-tools.sx | 25 ++++ spec/evaluator.sx | 231 +++++++++++++++++++++++++---------- 6 files changed, 213 insertions(+), 80 deletions(-) diff --git a/hosts/ocaml/bootstrap.py b/hosts/ocaml/bootstrap.py index 101e4378..0c9023a2 100644 --- a/hosts/ocaml/bootstrap.py +++ b/hosts/ocaml/bootstrap.py @@ -53,6 +53,7 @@ let trampoline v = !trampoline_fn v let _strict_ref = ref (Bool false) let _prim_param_types_ref = ref Nil let _last_error_kont_ref = ref Nil +let _protocol_registry_ = Dict (Hashtbl.create 0) """ @@ -209,6 +210,15 @@ def compile_spec_to_ml(spec_dir: str | None = None) -> str: # the transpiler directly — it emits !_ref for reads, _ref := for writes. import re + # Remove `and _protocol_registry_ = (Dict ...)` from the let rec block — + # it's defined in the preamble as a top-level let, and Hashtbl.create + # is not allowed as a let rec right-hand side. + output = re.sub( + r'\n\(\* \*protocol-registry\*.*?\nand _protocol_registry_ =\n \(Dict \(Hashtbl\.create 0\)\)\n', + '\n', + output + ) + return output diff --git a/hosts/ocaml/lib/sx_ref.ml b/hosts/ocaml/lib/sx_ref.ml index 543f987a..946e1fc9 100644 --- a/hosts/ocaml/lib/sx_ref.ml +++ b/hosts/ocaml/lib/sx_ref.ml @@ -510,6 +510,10 @@ and step_sf_raise args env kont = and step_sf_guard args env kont = (let var_clauses = (first (args)) in let body = (rest (args)) in let var = (first (var_clauses)) in let clauses = (rest (var_clauses)) in let sentinel = (make_symbol ((String "__guard-reraise__"))) in (step_eval_list ((List [(Symbol "let"); (List [(List [(Symbol "__guard-result"); (cons ((Symbol "call/cc")) ((List [(cons ((Symbol "fn")) ((cons ((List [(Symbol "__guard-k")])) ((List [(cons ((Symbol "handler-bind")) ((cons ((List [(List [(cons ((Symbol "fn")) ((cons ((List [(Symbol "_")])) ((List [(Bool true)]))))); (cons ((Symbol "fn")) ((cons ((List [var])) ((List [(List [(Symbol "__guard-k"); (cons ((Symbol "cond")) ((prim_call "append" [clauses; (List [(List [(Symbol "else"); (List [(Symbol "list"); (List [(Symbol "quote"); sentinel]); var])])])])))])])))))])])) ((List [(List [(Symbol "__guard-k"); (cons ((Symbol "begin")) (body))])])))))])))))])))])]); (List [(Symbol "if"); (List [(Symbol "and"); (List [(Symbol "list?"); (Symbol "__guard-result")]); (List [(Symbol "="); (List [(Symbol "len"); (Symbol "__guard-result")]); (Number 2.0)]); (List [(Symbol "="); (List [(Symbol "first"); (Symbol "__guard-result")]); (List [(Symbol "quote"); sentinel])])]); (List [(Symbol "raise"); (List [(Symbol "nth"); (Symbol "__guard-result"); (Number 1.0)])]); (Symbol "__guard-result")])])) (env) (kont))) +(* step-sf-callcc *) +and step_sf_callcc args env kont = + (make_cek_state ((first (args))) (env) ((kont_push ((make_callcc_frame (env))) (kont)))) + (* step-sf-case *) and step_sf_case args env kont = (make_cek_state ((first (args))) (env) ((kont_push ((make_case_frame (Nil) ((rest (args))) (env))) (kont)))) @@ -578,6 +582,7 @@ and step_sf_import args env kont = and step_sf_perform args env kont = (if sx_truthy ((empty_p (args))) then (raise (Eval_error (value_to_str (String "perform requires an IO request argument")))) else (make_cek_state ((first (args))) (env) ((kont_push ((make_perform_frame (env))) (kont))))) + (* sf-define-record-type *) and sf_define_record_type args env = (let type_sym = (first (args)) in let ctor_spec = (nth (args) ((Number 1.0))) in let pred_sym = (nth (args) ((Number 2.0))) in let field_specs = (prim_call "slice" [args; (Number 3.0)]) in (let raw_name = (symbol_name (type_sym)) in (let type_name = (if sx_truthy ((let _and = (prim_call "starts-with?" [raw_name; (String "<")]) in if not (sx_truthy _and) then _and else (prim_call "ends-with?" [raw_name; (String ">")]))) then (prim_call "slice" [raw_name; (Number 1.0); (prim_call "-" [(len (raw_name)); (Number 1.0)])]) else raw_name) in let ctor_name = (symbol_name ((first (ctor_spec)))) in let ctor_params = (List (List.map (fun s -> (symbol_name (s))) (sx_to_list (rest (ctor_spec))))) in let pred_name = (symbol_name (pred_sym)) in let field_names = (List (List.map (fun fs -> (symbol_name ((first (fs))))) (sx_to_list field_specs))) in (let rtd_uid = (make_rtd (type_name) (field_names) (ctor_params)) in (let () = ignore ((env_bind env (sx_to_string ctor_name) (make_record_constructor (rtd_uid)))) in (let () = ignore ((env_bind env (sx_to_string pred_name) (make_record_predicate (rtd_uid)))) in (let () = ignore ((for_each_indexed ((NativeFn ("\206\187", fun _args -> match _args with [idx; fs] -> (fun idx fs -> (let accessor_name = (symbol_name ((nth (fs) ((Number 1.0))))) in (let () = ignore ((env_bind env (sx_to_string accessor_name) (make_record_accessor (idx)))) in (if sx_truthy ((prim_call ">=" [(len (fs)); (Number 3.0)])) then (let mutator_name = (symbol_name ((nth (fs) ((Number 2.0))))) in (env_bind env (sx_to_string mutator_name) (make_record_mutator (idx)))) else Nil)))) idx fs | _ -> Nil))) (field_specs))) in Nil))))))) @@ -594,9 +599,9 @@ and sf_implement args env = and satisfies_p proto_name value = (if sx_truthy ((Bool (not (sx_truthy ((record_p (value))))))) then (Bool false) else (let proto = (get (_protocol_registry_) ((if sx_truthy ((symbol_p (proto_name))) then (symbol_name (proto_name)) else proto_name))) in (if sx_truthy ((is_nil (proto))) then (Bool false) else (Bool (not (sx_truthy ((is_nil ((get ((get (proto) ((String "impls")))) ((type_of (value))))))))))))) -(* step-sf-callcc *) -and step_sf_callcc args env kont = - (make_cek_state ((first (args))) (env) ((kont_push ((make_callcc_frame (env))) (kont)))) +(* check-match-exhaustiveness *) +and check_match_exhaustiveness clauses = + (let warnings = ref ((List [])) in let patterns = (List (List.map (fun c -> (first (c))) (sx_to_list clauses))) in let has_wildcard = (Bool (List.exists (fun p -> sx_truthy ((let _and = (symbol_p (p)) in if not (sx_truthy _and) then _and else (let _and = (Bool (not (sx_truthy ((prim_call "=" [p; (Bool true)]))))) in if not (sx_truthy _and) then _and else (Bool (not (sx_truthy ((prim_call "=" [p; (Bool false)]))))))))) (sx_to_list patterns))) in let has_else = (Bool (List.exists (fun p -> sx_truthy ((prim_call "=" [p; (String "else")]))) (sx_to_list patterns))) in let has_true = (Bool (List.exists (fun p -> sx_truthy ((prim_call "=" [p; (Bool true)]))) (sx_to_list patterns))) in let has_false = (Bool (List.exists (fun p -> sx_truthy ((prim_call "=" [p; (Bool false)]))) (sx_to_list patterns))) in (let () = ignore ((if sx_truthy ((let _and = (Bool (not (sx_truthy (has_wildcard)))) in if not (sx_truthy _and) then _and else (Bool (not (sx_truthy (has_else)))))) then (warnings := (prim_call "append" [!warnings; (List [(String "match may be non-exhaustive (no wildcard or :else pattern)")])]); Nil) else Nil)) in (let () = ignore ((if sx_truthy ((let _and = (let _or = has_true in if sx_truthy _or then _or else has_false) in if not (sx_truthy _and) then _and else (let _and = (Bool (not (sx_truthy ((let _and = has_true in if not (sx_truthy _and) then _and else has_false))))) in if not (sx_truthy _and) then _and else (let _and = (Bool (not (sx_truthy (has_wildcard)))) in if not (sx_truthy _and) then _and else (Bool (not (sx_truthy (has_else)))))))) then (warnings := (prim_call "append" [!warnings; (List [(if sx_truthy (has_true) then (String "match on boolean missing false case") else (String "match on boolean missing true case"))])]); Nil) else Nil)) in !warnings))) (* match-find-clause *) and match_find_clause val' clauses env = diff --git a/hosts/ocaml/lib/sx_vm_ref.ml b/hosts/ocaml/lib/sx_vm_ref.ml index 9728e144..9bb1506a 100644 --- a/hosts/ocaml/lib/sx_vm_ref.ml +++ b/hosts/ocaml/lib/sx_vm_ref.ml @@ -439,15 +439,11 @@ and vm_call_external vm f args = (* vm-run *) and vm_run vm = - (let () = ignore ((String "Execute bytecode until all frames are consumed.")) in (let rec loop = (fun () -> (if sx_truthy ((Bool (not (sx_truthy ((empty_p ((vm_frames (vm))))))))) then (let frame = (first ((vm_frames (vm)))) in let rest_frames = (rest ((vm_frames (vm)))) in (let bc = (code_bytecode ((closure_code ((frame_closure (frame)))))) in let consts = (code_constants ((closure_code ((frame_closure (frame)))))) in (if sx_truthy ((prim_call ">=" [(frame_ip (frame)); (len (bc))])) then (vm_set_frames_b (vm) ((List []))) else (let () = ignore ((vm_step (vm) (frame) (rest_frames) (bc) (consts))) in (loop ()))))) else Nil)) in (loop ()))) + (let () = ignore ((String "Execute bytecode until all frames are consumed.")) in (let rec loop = (fun () -> (if sx_truthy ((Bool (not (sx_truthy ((empty_p ((vm_frames (vm))))))))) then (let frame = (first ((vm_frames (vm)))) in let rest_frames = (rest ((vm_frames (vm)))) in (let bc = (code_bytecode ((closure_code ((frame_closure (frame)))))) in let consts = (code_constants ((closure_code ((frame_closure (frame)))))) in (if sx_truthy ((prim_call ">=" [(frame_ip (frame)); (len (bc))])) then (vm_set_frames_b (vm) ((List []))) else (let () = ignore ((vm_step (vm) (frame) (rest_frames) (bc) (consts))) in (if sx_truthy ((is_nil ((get ((vm_globals_ref (vm))) ((String "__io_request")))))) then (loop ()) else Nil))))) else Nil)) in (loop ()))) (* vm-step *) and vm_step vm frame rest_frames bc consts = - (let op = (frame_read_u8 (frame)) in (if sx_truthy ((prim_call "=" [op; (Number 1.0)])) then (let idx = (frame_read_u16 (frame)) in (vm_push (vm) ((nth (consts) (idx))))) else (if sx_truthy ((prim_call "=" [op; (Number 2.0)])) then (vm_push (vm) (Nil)) else (if sx_truthy ((prim_call "=" [op; (Number 3.0)])) then (vm_push (vm) ((Bool true))) else (if sx_truthy ((prim_call "=" [op; (Number 4.0)])) then (vm_push (vm) ((Bool false))) else (if sx_truthy ((prim_call "=" [op; (Number 5.0)])) then (vm_pop (vm)) else (if sx_truthy ((prim_call "=" [op; (Number 6.0)])) then (vm_push (vm) ((vm_peek (vm)))) else (if sx_truthy ((prim_call "=" [op; (Number 16.0)])) then (let slot = (frame_read_u8 (frame)) in (vm_push (vm) ((frame_local_get (vm) (frame) (slot))))) else (if sx_truthy ((prim_call "=" [op; (Number 17.0)])) then (let slot = (frame_read_u8 (frame)) in (frame_local_set (vm) (frame) (slot) ((vm_peek (vm))))) else (if sx_truthy ((prim_call "=" [op; (Number 18.0)])) then (let idx = (frame_read_u8 (frame)) in (vm_push (vm) ((frame_upvalue_get (frame) (idx))))) else (if sx_truthy ((prim_call "=" [op; (Number 19.0)])) then (let idx = (frame_read_u8 (frame)) in (frame_upvalue_set (frame) (idx) ((vm_peek (vm))))) else (if sx_truthy ((prim_call "=" [op; (Number 20.0)])) then (let idx = (frame_read_u16 (frame)) in let name = (nth (consts) (idx)) in (vm_push (vm) ((vm_global_get (vm) (frame) (name))))) else (if sx_truthy ((prim_call "=" [op; (Number 21.0)])) then (let idx = (frame_read_u16 (frame)) in let name = (nth (consts) (idx)) in (vm_global_set (vm) (frame) (name) ((vm_peek (vm))))) else (if sx_truthy ((prim_call "=" [op; (Number 32.0)])) then (let offset = (frame_read_i16 (frame)) in (frame_set_ip_b (frame) ((prim_call "+" [(frame_ip (frame)); offset])))) else (if sx_truthy ((prim_call "=" [op; (Number 33.0)])) then (let offset = (frame_read_i16 (frame)) in let v = (vm_pop (vm)) in (if sx_truthy ((Bool (not (sx_truthy (v))))) then (frame_set_ip_b (frame) ((prim_call "+" [(frame_ip (frame)); offset]))) else Nil)) else (if sx_truthy ((prim_call "=" [op; (Number 34.0)])) then (let offset = (frame_read_i16 (frame)) in let v = (vm_pop (vm)) in (if sx_truthy (v) then (frame_set_ip_b (frame) ((prim_call "+" [(frame_ip (frame)); offset]))) else Nil)) else (if sx_truthy ((prim_call "=" [op; (Number 48.0)])) then (let argc = (frame_read_u8 (frame)) in let args = (collect_n_from_stack (vm) (argc)) in let f = (vm_pop (vm)) in (vm_call (vm) (f) (args))) else (if sx_truthy ((prim_call "=" [op; (Number 49.0)])) then (let argc = (frame_read_u8 (frame)) in let args = (collect_n_from_stack (vm) (argc)) in let f = (vm_pop (vm)) in (let () = ignore ((vm_set_frames_b (vm) (rest_frames))) in (let () = ignore ((vm_set_sp_b (vm) ((frame_base (frame))))) in (vm_call (vm) (f) (args))))) else (if sx_truthy ((prim_call "=" [op; (Number 50.0)])) then (let result' = (vm_pop (vm)) in (let () = ignore ((vm_set_frames_b (vm) (rest_frames))) in (let () = ignore ((vm_set_sp_b (vm) ((frame_base (frame))))) in (vm_push (vm) (result'))))) else (if sx_truthy ((prim_call "=" [op; (Number 51.0)])) then (let idx = (frame_read_u16 (frame)) in let code_val = (nth (consts) (idx)) in (let cl = (vm_create_closure (vm) (frame) (code_val)) in (vm_push (vm) (cl)))) else (if sx_truthy ((prim_call "=" [op; (Number 52.0)])) then (let idx = (frame_read_u16 (frame)) in let argc = (frame_read_u8 (frame)) in let name = (nth (consts) (idx)) in let args = (collect_n_from_stack (vm) (argc)) in (vm_push (vm) ((call_primitive (name) (args))))) else (if sx_truthy ((prim_call "=" [op; (Number 64.0)])) then (let count = (frame_read_u16 (frame)) in let items = (collect_n_from_stack (vm) (count)) in (vm_push (vm) (items))) else (if sx_truthy ((prim_call "=" [op; (Number 65.0)])) then (let count = (frame_read_u16 (frame)) in let d = (collect_n_pairs (vm) (count)) in (vm_push (vm) (d))) else (if sx_truthy ((prim_call "=" [op; (Number 144.0)])) then (let count = (frame_read_u8 (frame)) in let parts = (collect_n_from_stack (vm) (count)) in (vm_push (vm) ((sx_apply str parts)))) else (if sx_truthy ((prim_call "=" [op; (Number 128.0)])) then (let idx = (frame_read_u16 (frame)) in let name = (nth (consts) (idx)) in (sx_dict_set_b (vm_globals_ref (vm)) name (vm_peek (vm)))) else (if sx_truthy ((prim_call "=" [op; (Number 160.0)])) then (let b = (vm_pop (vm)) in let a = (vm_pop (vm)) in (vm_push (vm) ((prim_call "+" [a; b])))) else (if sx_truthy ((prim_call "=" [op; (Number 161.0)])) then (let b = (vm_pop (vm)) in let a = (vm_pop (vm)) in (vm_push (vm) ((prim_call "-" [a; b])))) else (if sx_truthy ((prim_call "=" [op; (Number 162.0)])) then (let b = (vm_pop (vm)) in let a = (vm_pop (vm)) in (vm_push (vm) ((prim_call "*" [a; b])))) else (if sx_truthy ((prim_call "=" [op; (Number 163.0)])) then (let b = (vm_pop (vm)) in let a = (vm_pop (vm)) in (vm_push (vm) ((prim_call "/" [a; b])))) else (if sx_truthy ((prim_call "=" [op; (Number 164.0)])) then (let b = (vm_pop (vm)) in let a = (vm_pop (vm)) in (vm_push (vm) ((prim_call "=" [a; b])))) else (if sx_truthy ((prim_call "=" [op; (Number 165.0)])) then (let b = (vm_pop (vm)) in let a = (vm_pop (vm)) in (vm_push (vm) ((prim_call "<" [a; b])))) else (if sx_truthy ((prim_call "=" [op; (Number 166.0)])) then (let b = (vm_pop (vm)) in let a = (vm_pop (vm)) in (vm_push (vm) ((prim_call ">" [a; b])))) else (if sx_truthy ((prim_call "=" [op; (Number 167.0)])) then (vm_push (vm) ((Bool (not (sx_truthy ((vm_pop (vm)))))))) else (if sx_truthy ((prim_call "=" [op; (Number 168.0)])) then (vm_push (vm) ((len ((vm_pop (vm)))))) else (if sx_truthy ((prim_call "=" [op; (Number 169.0)])) then (vm_push (vm) ((first ((vm_pop (vm)))))) else (if sx_truthy ((prim_call "=" [op; (Number 170.0)])) then (vm_push (vm) ((rest ((vm_pop (vm)))))) else (if sx_truthy ((prim_call "=" [op; (Number 171.0)])) then (let n = (vm_pop (vm)) in let coll = (vm_pop (vm)) in (vm_push (vm) ((nth (coll) (n))))) else (if sx_truthy ((prim_call "=" [op; (Number 172.0)])) then (let coll = (vm_pop (vm)) in let x = (vm_pop (vm)) in (vm_push (vm) ((cons (x) (coll))))) else (if sx_truthy ((prim_call "=" [op; (Number 173.0)])) then (vm_push (vm) ((prim_call "-" [(Number 0.0); (vm_pop (vm))]))) else (if sx_truthy ((prim_call "=" [op; (Number 174.0)])) then (vm_push (vm) ((prim_call "inc" [(vm_pop (vm))]))) else (if sx_truthy ((prim_call "=" [op; (Number 175.0)])) then (vm_push (vm) ((prim_call "dec" [(vm_pop (vm))]))) else (if sx_truthy ((prim_call "=" [op; (Number 112.0)])) then (let request = (vm_pop (vm)) in (raise (Eval_error (value_to_str (String (sx_str [(String "VM: IO suspension (OP_PERFORM) — request: "); request])))))) else (raise (Eval_error (value_to_str (String (sx_str [(String "VM: unknown opcode "); op]))))))))))))))))))))))))))))))))))))))))))))))) - -(* vm-execute-module *) -and vm_execute_module code globals = - (let closure = (make_vm_closure (code) ((List [])) ((String "module")) (globals) (Nil)) in let vm = (make_vm (globals)) in (let frame = (make_vm_frame (closure) ((Number 0.0))) in (let () = ignore ((pad_n_nils (vm) ((code_locals (code))))) in (let () = ignore ((vm_set_frames_b (vm) ((List [frame])))) in (let () = ignore ((vm_run (vm))) in (vm_pop (vm))))))) + (let op = (frame_read_u8 (frame)) in (if sx_truthy ((prim_call "=" [op; (Number 1.0)])) then (let idx = (frame_read_u16 (frame)) in (vm_push (vm) ((nth (consts) (idx))))) else (if sx_truthy ((prim_call "=" [op; (Number 2.0)])) then (vm_push (vm) (Nil)) else (if sx_truthy ((prim_call "=" [op; (Number 3.0)])) then (vm_push (vm) ((Bool true))) else (if sx_truthy ((prim_call "=" [op; (Number 4.0)])) then (vm_push (vm) ((Bool false))) else (if sx_truthy ((prim_call "=" [op; (Number 5.0)])) then (vm_pop (vm)) else (if sx_truthy ((prim_call "=" [op; (Number 6.0)])) then (vm_push (vm) ((vm_peek (vm)))) else (if sx_truthy ((prim_call "=" [op; (Number 16.0)])) then (let slot = (frame_read_u8 (frame)) in (vm_push (vm) ((frame_local_get (vm) (frame) (slot))))) else (if sx_truthy ((prim_call "=" [op; (Number 17.0)])) then (let slot = (frame_read_u8 (frame)) in (frame_local_set (vm) (frame) (slot) ((vm_peek (vm))))) else (if sx_truthy ((prim_call "=" [op; (Number 18.0)])) then (let idx = (frame_read_u8 (frame)) in (vm_push (vm) ((frame_upvalue_get (frame) (idx))))) else (if sx_truthy ((prim_call "=" [op; (Number 19.0)])) then (let idx = (frame_read_u8 (frame)) in (frame_upvalue_set (frame) (idx) ((vm_peek (vm))))) else (if sx_truthy ((prim_call "=" [op; (Number 20.0)])) then (let idx = (frame_read_u16 (frame)) in let name = (nth (consts) (idx)) in (vm_push (vm) ((vm_global_get (vm) (frame) (name))))) else (if sx_truthy ((prim_call "=" [op; (Number 21.0)])) then (let idx = (frame_read_u16 (frame)) in let name = (nth (consts) (idx)) in (vm_global_set (vm) (frame) (name) ((vm_peek (vm))))) else (if sx_truthy ((prim_call "=" [op; (Number 32.0)])) then (let offset = (frame_read_i16 (frame)) in (frame_set_ip_b (frame) ((prim_call "+" [(frame_ip (frame)); offset])))) else (if sx_truthy ((prim_call "=" [op; (Number 33.0)])) then (let offset = (frame_read_i16 (frame)) in let v = (vm_pop (vm)) in (if sx_truthy ((Bool (not (sx_truthy (v))))) then (frame_set_ip_b (frame) ((prim_call "+" [(frame_ip (frame)); offset]))) else Nil)) else (if sx_truthy ((prim_call "=" [op; (Number 34.0)])) then (let offset = (frame_read_i16 (frame)) in let v = (vm_pop (vm)) in (if sx_truthy (v) then (frame_set_ip_b (frame) ((prim_call "+" [(frame_ip (frame)); offset]))) else Nil)) else (if sx_truthy ((prim_call "=" [op; (Number 48.0)])) then (let argc = (frame_read_u8 (frame)) in let args = (collect_n_from_stack (vm) (argc)) in let f = (vm_pop (vm)) in (vm_call (vm) (f) (args))) else (if sx_truthy ((prim_call "=" [op; (Number 49.0)])) then (let argc = (frame_read_u8 (frame)) in let args = (collect_n_from_stack (vm) (argc)) in let f = (vm_pop (vm)) in (let () = ignore ((vm_set_frames_b (vm) (rest_frames))) in (let () = ignore ((vm_set_sp_b (vm) ((frame_base (frame))))) in (vm_call (vm) (f) (args))))) else (if sx_truthy ((prim_call "=" [op; (Number 50.0)])) then (let result' = (vm_pop (vm)) in (let () = ignore ((vm_set_frames_b (vm) (rest_frames))) in (let () = ignore ((vm_set_sp_b (vm) ((frame_base (frame))))) in (vm_push (vm) (result'))))) else (if sx_truthy ((prim_call "=" [op; (Number 51.0)])) then (let idx = (frame_read_u16 (frame)) in let code_val = (nth (consts) (idx)) in (let cl = (vm_create_closure (vm) (frame) (code_val)) in (vm_push (vm) (cl)))) else (if sx_truthy ((prim_call "=" [op; (Number 52.0)])) then (let idx = (frame_read_u16 (frame)) in let argc = (frame_read_u8 (frame)) in let name = (nth (consts) (idx)) in let args = (collect_n_from_stack (vm) (argc)) in (vm_push (vm) ((call_primitive (name) (args))))) else (if sx_truthy ((prim_call "=" [op; (Number 64.0)])) then (let count = (frame_read_u16 (frame)) in let items = (collect_n_from_stack (vm) (count)) in (vm_push (vm) (items))) else (if sx_truthy ((prim_call "=" [op; (Number 65.0)])) then (let count = (frame_read_u16 (frame)) in let d = (collect_n_pairs (vm) (count)) in (vm_push (vm) (d))) else (if sx_truthy ((prim_call "=" [op; (Number 144.0)])) then (let count = (frame_read_u8 (frame)) in let parts = (collect_n_from_stack (vm) (count)) in (vm_push (vm) ((sx_apply str parts)))) else (if sx_truthy ((prim_call "=" [op; (Number 128.0)])) then (let idx = (frame_read_u16 (frame)) in let name = (nth (consts) (idx)) in (sx_dict_set_b (vm_globals_ref (vm)) name (vm_peek (vm)))) else (if sx_truthy ((prim_call "=" [op; (Number 160.0)])) then (let b = (vm_pop (vm)) in let a = (vm_pop (vm)) in (vm_push (vm) ((prim_call "+" [a; b])))) else (if sx_truthy ((prim_call "=" [op; (Number 161.0)])) then (let b = (vm_pop (vm)) in let a = (vm_pop (vm)) in (vm_push (vm) ((prim_call "-" [a; b])))) else (if sx_truthy ((prim_call "=" [op; (Number 162.0)])) then (let b = (vm_pop (vm)) in let a = (vm_pop (vm)) in (vm_push (vm) ((prim_call "*" [a; b])))) else (if sx_truthy ((prim_call "=" [op; (Number 163.0)])) then (let b = (vm_pop (vm)) in let a = (vm_pop (vm)) in (vm_push (vm) ((prim_call "/" [a; b])))) else (if sx_truthy ((prim_call "=" [op; (Number 164.0)])) then (let b = (vm_pop (vm)) in let a = (vm_pop (vm)) in (vm_push (vm) ((prim_call "=" [a; b])))) else (if sx_truthy ((prim_call "=" [op; (Number 165.0)])) then (let b = (vm_pop (vm)) in let a = (vm_pop (vm)) in (vm_push (vm) ((prim_call "<" [a; b])))) else (if sx_truthy ((prim_call "=" [op; (Number 166.0)])) then (let b = (vm_pop (vm)) in let a = (vm_pop (vm)) in (vm_push (vm) ((prim_call ">" [a; b])))) else (if sx_truthy ((prim_call "=" [op; (Number 167.0)])) then (vm_push (vm) ((Bool (not (sx_truthy ((vm_pop (vm)))))))) else (if sx_truthy ((prim_call "=" [op; (Number 168.0)])) then (vm_push (vm) ((len ((vm_pop (vm)))))) else (if sx_truthy ((prim_call "=" [op; (Number 169.0)])) then (vm_push (vm) ((first ((vm_pop (vm)))))) else (if sx_truthy ((prim_call "=" [op; (Number 170.0)])) then (vm_push (vm) ((rest ((vm_pop (vm)))))) else (if sx_truthy ((prim_call "=" [op; (Number 171.0)])) then (let n = (vm_pop (vm)) in let coll = (vm_pop (vm)) in (vm_push (vm) ((nth (coll) (n))))) else (if sx_truthy ((prim_call "=" [op; (Number 172.0)])) then (let coll = (vm_pop (vm)) in let x = (vm_pop (vm)) in (vm_push (vm) ((cons (x) (coll))))) else (if sx_truthy ((prim_call "=" [op; (Number 173.0)])) then (vm_push (vm) ((prim_call "-" [(Number 0.0); (vm_pop (vm))]))) else (if sx_truthy ((prim_call "=" [op; (Number 174.0)])) then (vm_push (vm) ((prim_call "inc" [(vm_pop (vm))]))) else (if sx_truthy ((prim_call "=" [op; (Number 175.0)])) then (vm_push (vm) ((prim_call "dec" [(vm_pop (vm))]))) else (if sx_truthy ((prim_call "=" [op; (Number 112.0)])) then (let request = (vm_pop (vm)) in (sx_dict_set_b (vm_globals_ref (vm)) (String "__io_request") request)) else (raise (Eval_error (value_to_str (String (sx_str [(String "VM: unknown opcode "); op]))))))))))))))))))))))))))))))))))))))))))))))) diff --git a/hosts/ocaml/sx_vm_ref.ml b/hosts/ocaml/sx_vm_ref.ml index 9728e144..9bb1506a 100644 --- a/hosts/ocaml/sx_vm_ref.ml +++ b/hosts/ocaml/sx_vm_ref.ml @@ -439,15 +439,11 @@ and vm_call_external vm f args = (* vm-run *) and vm_run vm = - (let () = ignore ((String "Execute bytecode until all frames are consumed.")) in (let rec loop = (fun () -> (if sx_truthy ((Bool (not (sx_truthy ((empty_p ((vm_frames (vm))))))))) then (let frame = (first ((vm_frames (vm)))) in let rest_frames = (rest ((vm_frames (vm)))) in (let bc = (code_bytecode ((closure_code ((frame_closure (frame)))))) in let consts = (code_constants ((closure_code ((frame_closure (frame)))))) in (if sx_truthy ((prim_call ">=" [(frame_ip (frame)); (len (bc))])) then (vm_set_frames_b (vm) ((List []))) else (let () = ignore ((vm_step (vm) (frame) (rest_frames) (bc) (consts))) in (loop ()))))) else Nil)) in (loop ()))) + (let () = ignore ((String "Execute bytecode until all frames are consumed.")) in (let rec loop = (fun () -> (if sx_truthy ((Bool (not (sx_truthy ((empty_p ((vm_frames (vm))))))))) then (let frame = (first ((vm_frames (vm)))) in let rest_frames = (rest ((vm_frames (vm)))) in (let bc = (code_bytecode ((closure_code ((frame_closure (frame)))))) in let consts = (code_constants ((closure_code ((frame_closure (frame)))))) in (if sx_truthy ((prim_call ">=" [(frame_ip (frame)); (len (bc))])) then (vm_set_frames_b (vm) ((List []))) else (let () = ignore ((vm_step (vm) (frame) (rest_frames) (bc) (consts))) in (if sx_truthy ((is_nil ((get ((vm_globals_ref (vm))) ((String "__io_request")))))) then (loop ()) else Nil))))) else Nil)) in (loop ()))) (* vm-step *) and vm_step vm frame rest_frames bc consts = - (let op = (frame_read_u8 (frame)) in (if sx_truthy ((prim_call "=" [op; (Number 1.0)])) then (let idx = (frame_read_u16 (frame)) in (vm_push (vm) ((nth (consts) (idx))))) else (if sx_truthy ((prim_call "=" [op; (Number 2.0)])) then (vm_push (vm) (Nil)) else (if sx_truthy ((prim_call "=" [op; (Number 3.0)])) then (vm_push (vm) ((Bool true))) else (if sx_truthy ((prim_call "=" [op; (Number 4.0)])) then (vm_push (vm) ((Bool false))) else (if sx_truthy ((prim_call "=" [op; (Number 5.0)])) then (vm_pop (vm)) else (if sx_truthy ((prim_call "=" [op; (Number 6.0)])) then (vm_push (vm) ((vm_peek (vm)))) else (if sx_truthy ((prim_call "=" [op; (Number 16.0)])) then (let slot = (frame_read_u8 (frame)) in (vm_push (vm) ((frame_local_get (vm) (frame) (slot))))) else (if sx_truthy ((prim_call "=" [op; (Number 17.0)])) then (let slot = (frame_read_u8 (frame)) in (frame_local_set (vm) (frame) (slot) ((vm_peek (vm))))) else (if sx_truthy ((prim_call "=" [op; (Number 18.0)])) then (let idx = (frame_read_u8 (frame)) in (vm_push (vm) ((frame_upvalue_get (frame) (idx))))) else (if sx_truthy ((prim_call "=" [op; (Number 19.0)])) then (let idx = (frame_read_u8 (frame)) in (frame_upvalue_set (frame) (idx) ((vm_peek (vm))))) else (if sx_truthy ((prim_call "=" [op; (Number 20.0)])) then (let idx = (frame_read_u16 (frame)) in let name = (nth (consts) (idx)) in (vm_push (vm) ((vm_global_get (vm) (frame) (name))))) else (if sx_truthy ((prim_call "=" [op; (Number 21.0)])) then (let idx = (frame_read_u16 (frame)) in let name = (nth (consts) (idx)) in (vm_global_set (vm) (frame) (name) ((vm_peek (vm))))) else (if sx_truthy ((prim_call "=" [op; (Number 32.0)])) then (let offset = (frame_read_i16 (frame)) in (frame_set_ip_b (frame) ((prim_call "+" [(frame_ip (frame)); offset])))) else (if sx_truthy ((prim_call "=" [op; (Number 33.0)])) then (let offset = (frame_read_i16 (frame)) in let v = (vm_pop (vm)) in (if sx_truthy ((Bool (not (sx_truthy (v))))) then (frame_set_ip_b (frame) ((prim_call "+" [(frame_ip (frame)); offset]))) else Nil)) else (if sx_truthy ((prim_call "=" [op; (Number 34.0)])) then (let offset = (frame_read_i16 (frame)) in let v = (vm_pop (vm)) in (if sx_truthy (v) then (frame_set_ip_b (frame) ((prim_call "+" [(frame_ip (frame)); offset]))) else Nil)) else (if sx_truthy ((prim_call "=" [op; (Number 48.0)])) then (let argc = (frame_read_u8 (frame)) in let args = (collect_n_from_stack (vm) (argc)) in let f = (vm_pop (vm)) in (vm_call (vm) (f) (args))) else (if sx_truthy ((prim_call "=" [op; (Number 49.0)])) then (let argc = (frame_read_u8 (frame)) in let args = (collect_n_from_stack (vm) (argc)) in let f = (vm_pop (vm)) in (let () = ignore ((vm_set_frames_b (vm) (rest_frames))) in (let () = ignore ((vm_set_sp_b (vm) ((frame_base (frame))))) in (vm_call (vm) (f) (args))))) else (if sx_truthy ((prim_call "=" [op; (Number 50.0)])) then (let result' = (vm_pop (vm)) in (let () = ignore ((vm_set_frames_b (vm) (rest_frames))) in (let () = ignore ((vm_set_sp_b (vm) ((frame_base (frame))))) in (vm_push (vm) (result'))))) else (if sx_truthy ((prim_call "=" [op; (Number 51.0)])) then (let idx = (frame_read_u16 (frame)) in let code_val = (nth (consts) (idx)) in (let cl = (vm_create_closure (vm) (frame) (code_val)) in (vm_push (vm) (cl)))) else (if sx_truthy ((prim_call "=" [op; (Number 52.0)])) then (let idx = (frame_read_u16 (frame)) in let argc = (frame_read_u8 (frame)) in let name = (nth (consts) (idx)) in let args = (collect_n_from_stack (vm) (argc)) in (vm_push (vm) ((call_primitive (name) (args))))) else (if sx_truthy ((prim_call "=" [op; (Number 64.0)])) then (let count = (frame_read_u16 (frame)) in let items = (collect_n_from_stack (vm) (count)) in (vm_push (vm) (items))) else (if sx_truthy ((prim_call "=" [op; (Number 65.0)])) then (let count = (frame_read_u16 (frame)) in let d = (collect_n_pairs (vm) (count)) in (vm_push (vm) (d))) else (if sx_truthy ((prim_call "=" [op; (Number 144.0)])) then (let count = (frame_read_u8 (frame)) in let parts = (collect_n_from_stack (vm) (count)) in (vm_push (vm) ((sx_apply str parts)))) else (if sx_truthy ((prim_call "=" [op; (Number 128.0)])) then (let idx = (frame_read_u16 (frame)) in let name = (nth (consts) (idx)) in (sx_dict_set_b (vm_globals_ref (vm)) name (vm_peek (vm)))) else (if sx_truthy ((prim_call "=" [op; (Number 160.0)])) then (let b = (vm_pop (vm)) in let a = (vm_pop (vm)) in (vm_push (vm) ((prim_call "+" [a; b])))) else (if sx_truthy ((prim_call "=" [op; (Number 161.0)])) then (let b = (vm_pop (vm)) in let a = (vm_pop (vm)) in (vm_push (vm) ((prim_call "-" [a; b])))) else (if sx_truthy ((prim_call "=" [op; (Number 162.0)])) then (let b = (vm_pop (vm)) in let a = (vm_pop (vm)) in (vm_push (vm) ((prim_call "*" [a; b])))) else (if sx_truthy ((prim_call "=" [op; (Number 163.0)])) then (let b = (vm_pop (vm)) in let a = (vm_pop (vm)) in (vm_push (vm) ((prim_call "/" [a; b])))) else (if sx_truthy ((prim_call "=" [op; (Number 164.0)])) then (let b = (vm_pop (vm)) in let a = (vm_pop (vm)) in (vm_push (vm) ((prim_call "=" [a; b])))) else (if sx_truthy ((prim_call "=" [op; (Number 165.0)])) then (let b = (vm_pop (vm)) in let a = (vm_pop (vm)) in (vm_push (vm) ((prim_call "<" [a; b])))) else (if sx_truthy ((prim_call "=" [op; (Number 166.0)])) then (let b = (vm_pop (vm)) in let a = (vm_pop (vm)) in (vm_push (vm) ((prim_call ">" [a; b])))) else (if sx_truthy ((prim_call "=" [op; (Number 167.0)])) then (vm_push (vm) ((Bool (not (sx_truthy ((vm_pop (vm)))))))) else (if sx_truthy ((prim_call "=" [op; (Number 168.0)])) then (vm_push (vm) ((len ((vm_pop (vm)))))) else (if sx_truthy ((prim_call "=" [op; (Number 169.0)])) then (vm_push (vm) ((first ((vm_pop (vm)))))) else (if sx_truthy ((prim_call "=" [op; (Number 170.0)])) then (vm_push (vm) ((rest ((vm_pop (vm)))))) else (if sx_truthy ((prim_call "=" [op; (Number 171.0)])) then (let n = (vm_pop (vm)) in let coll = (vm_pop (vm)) in (vm_push (vm) ((nth (coll) (n))))) else (if sx_truthy ((prim_call "=" [op; (Number 172.0)])) then (let coll = (vm_pop (vm)) in let x = (vm_pop (vm)) in (vm_push (vm) ((cons (x) (coll))))) else (if sx_truthy ((prim_call "=" [op; (Number 173.0)])) then (vm_push (vm) ((prim_call "-" [(Number 0.0); (vm_pop (vm))]))) else (if sx_truthy ((prim_call "=" [op; (Number 174.0)])) then (vm_push (vm) ((prim_call "inc" [(vm_pop (vm))]))) else (if sx_truthy ((prim_call "=" [op; (Number 175.0)])) then (vm_push (vm) ((prim_call "dec" [(vm_pop (vm))]))) else (if sx_truthy ((prim_call "=" [op; (Number 112.0)])) then (let request = (vm_pop (vm)) in (raise (Eval_error (value_to_str (String (sx_str [(String "VM: IO suspension (OP_PERFORM) — request: "); request])))))) else (raise (Eval_error (value_to_str (String (sx_str [(String "VM: unknown opcode "); op]))))))))))))))))))))))))))))))))))))))))))))))) - -(* vm-execute-module *) -and vm_execute_module code globals = - (let closure = (make_vm_closure (code) ((List [])) ((String "module")) (globals) (Nil)) in let vm = (make_vm (globals)) in (let frame = (make_vm_frame (closure) ((Number 0.0))) in (let () = ignore ((pad_n_nils (vm) ((code_locals (code))))) in (let () = ignore ((vm_set_frames_b (vm) ((List [frame])))) in (let () = ignore ((vm_run (vm))) in (vm_pop (vm))))))) + (let op = (frame_read_u8 (frame)) in (if sx_truthy ((prim_call "=" [op; (Number 1.0)])) then (let idx = (frame_read_u16 (frame)) in (vm_push (vm) ((nth (consts) (idx))))) else (if sx_truthy ((prim_call "=" [op; (Number 2.0)])) then (vm_push (vm) (Nil)) else (if sx_truthy ((prim_call "=" [op; (Number 3.0)])) then (vm_push (vm) ((Bool true))) else (if sx_truthy ((prim_call "=" [op; (Number 4.0)])) then (vm_push (vm) ((Bool false))) else (if sx_truthy ((prim_call "=" [op; (Number 5.0)])) then (vm_pop (vm)) else (if sx_truthy ((prim_call "=" [op; (Number 6.0)])) then (vm_push (vm) ((vm_peek (vm)))) else (if sx_truthy ((prim_call "=" [op; (Number 16.0)])) then (let slot = (frame_read_u8 (frame)) in (vm_push (vm) ((frame_local_get (vm) (frame) (slot))))) else (if sx_truthy ((prim_call "=" [op; (Number 17.0)])) then (let slot = (frame_read_u8 (frame)) in (frame_local_set (vm) (frame) (slot) ((vm_peek (vm))))) else (if sx_truthy ((prim_call "=" [op; (Number 18.0)])) then (let idx = (frame_read_u8 (frame)) in (vm_push (vm) ((frame_upvalue_get (frame) (idx))))) else (if sx_truthy ((prim_call "=" [op; (Number 19.0)])) then (let idx = (frame_read_u8 (frame)) in (frame_upvalue_set (frame) (idx) ((vm_peek (vm))))) else (if sx_truthy ((prim_call "=" [op; (Number 20.0)])) then (let idx = (frame_read_u16 (frame)) in let name = (nth (consts) (idx)) in (vm_push (vm) ((vm_global_get (vm) (frame) (name))))) else (if sx_truthy ((prim_call "=" [op; (Number 21.0)])) then (let idx = (frame_read_u16 (frame)) in let name = (nth (consts) (idx)) in (vm_global_set (vm) (frame) (name) ((vm_peek (vm))))) else (if sx_truthy ((prim_call "=" [op; (Number 32.0)])) then (let offset = (frame_read_i16 (frame)) in (frame_set_ip_b (frame) ((prim_call "+" [(frame_ip (frame)); offset])))) else (if sx_truthy ((prim_call "=" [op; (Number 33.0)])) then (let offset = (frame_read_i16 (frame)) in let v = (vm_pop (vm)) in (if sx_truthy ((Bool (not (sx_truthy (v))))) then (frame_set_ip_b (frame) ((prim_call "+" [(frame_ip (frame)); offset]))) else Nil)) else (if sx_truthy ((prim_call "=" [op; (Number 34.0)])) then (let offset = (frame_read_i16 (frame)) in let v = (vm_pop (vm)) in (if sx_truthy (v) then (frame_set_ip_b (frame) ((prim_call "+" [(frame_ip (frame)); offset]))) else Nil)) else (if sx_truthy ((prim_call "=" [op; (Number 48.0)])) then (let argc = (frame_read_u8 (frame)) in let args = (collect_n_from_stack (vm) (argc)) in let f = (vm_pop (vm)) in (vm_call (vm) (f) (args))) else (if sx_truthy ((prim_call "=" [op; (Number 49.0)])) then (let argc = (frame_read_u8 (frame)) in let args = (collect_n_from_stack (vm) (argc)) in let f = (vm_pop (vm)) in (let () = ignore ((vm_set_frames_b (vm) (rest_frames))) in (let () = ignore ((vm_set_sp_b (vm) ((frame_base (frame))))) in (vm_call (vm) (f) (args))))) else (if sx_truthy ((prim_call "=" [op; (Number 50.0)])) then (let result' = (vm_pop (vm)) in (let () = ignore ((vm_set_frames_b (vm) (rest_frames))) in (let () = ignore ((vm_set_sp_b (vm) ((frame_base (frame))))) in (vm_push (vm) (result'))))) else (if sx_truthy ((prim_call "=" [op; (Number 51.0)])) then (let idx = (frame_read_u16 (frame)) in let code_val = (nth (consts) (idx)) in (let cl = (vm_create_closure (vm) (frame) (code_val)) in (vm_push (vm) (cl)))) else (if sx_truthy ((prim_call "=" [op; (Number 52.0)])) then (let idx = (frame_read_u16 (frame)) in let argc = (frame_read_u8 (frame)) in let name = (nth (consts) (idx)) in let args = (collect_n_from_stack (vm) (argc)) in (vm_push (vm) ((call_primitive (name) (args))))) else (if sx_truthy ((prim_call "=" [op; (Number 64.0)])) then (let count = (frame_read_u16 (frame)) in let items = (collect_n_from_stack (vm) (count)) in (vm_push (vm) (items))) else (if sx_truthy ((prim_call "=" [op; (Number 65.0)])) then (let count = (frame_read_u16 (frame)) in let d = (collect_n_pairs (vm) (count)) in (vm_push (vm) (d))) else (if sx_truthy ((prim_call "=" [op; (Number 144.0)])) then (let count = (frame_read_u8 (frame)) in let parts = (collect_n_from_stack (vm) (count)) in (vm_push (vm) ((sx_apply str parts)))) else (if sx_truthy ((prim_call "=" [op; (Number 128.0)])) then (let idx = (frame_read_u16 (frame)) in let name = (nth (consts) (idx)) in (sx_dict_set_b (vm_globals_ref (vm)) name (vm_peek (vm)))) else (if sx_truthy ((prim_call "=" [op; (Number 160.0)])) then (let b = (vm_pop (vm)) in let a = (vm_pop (vm)) in (vm_push (vm) ((prim_call "+" [a; b])))) else (if sx_truthy ((prim_call "=" [op; (Number 161.0)])) then (let b = (vm_pop (vm)) in let a = (vm_pop (vm)) in (vm_push (vm) ((prim_call "-" [a; b])))) else (if sx_truthy ((prim_call "=" [op; (Number 162.0)])) then (let b = (vm_pop (vm)) in let a = (vm_pop (vm)) in (vm_push (vm) ((prim_call "*" [a; b])))) else (if sx_truthy ((prim_call "=" [op; (Number 163.0)])) then (let b = (vm_pop (vm)) in let a = (vm_pop (vm)) in (vm_push (vm) ((prim_call "/" [a; b])))) else (if sx_truthy ((prim_call "=" [op; (Number 164.0)])) then (let b = (vm_pop (vm)) in let a = (vm_pop (vm)) in (vm_push (vm) ((prim_call "=" [a; b])))) else (if sx_truthy ((prim_call "=" [op; (Number 165.0)])) then (let b = (vm_pop (vm)) in let a = (vm_pop (vm)) in (vm_push (vm) ((prim_call "<" [a; b])))) else (if sx_truthy ((prim_call "=" [op; (Number 166.0)])) then (let b = (vm_pop (vm)) in let a = (vm_pop (vm)) in (vm_push (vm) ((prim_call ">" [a; b])))) else (if sx_truthy ((prim_call "=" [op; (Number 167.0)])) then (vm_push (vm) ((Bool (not (sx_truthy ((vm_pop (vm)))))))) else (if sx_truthy ((prim_call "=" [op; (Number 168.0)])) then (vm_push (vm) ((len ((vm_pop (vm)))))) else (if sx_truthy ((prim_call "=" [op; (Number 169.0)])) then (vm_push (vm) ((first ((vm_pop (vm)))))) else (if sx_truthy ((prim_call "=" [op; (Number 170.0)])) then (vm_push (vm) ((rest ((vm_pop (vm)))))) else (if sx_truthy ((prim_call "=" [op; (Number 171.0)])) then (let n = (vm_pop (vm)) in let coll = (vm_pop (vm)) in (vm_push (vm) ((nth (coll) (n))))) else (if sx_truthy ((prim_call "=" [op; (Number 172.0)])) then (let coll = (vm_pop (vm)) in let x = (vm_pop (vm)) in (vm_push (vm) ((cons (x) (coll))))) else (if sx_truthy ((prim_call "=" [op; (Number 173.0)])) then (vm_push (vm) ((prim_call "-" [(Number 0.0); (vm_pop (vm))]))) else (if sx_truthy ((prim_call "=" [op; (Number 174.0)])) then (vm_push (vm) ((prim_call "inc" [(vm_pop (vm))]))) else (if sx_truthy ((prim_call "=" [op; (Number 175.0)])) then (vm_push (vm) ((prim_call "dec" [(vm_pop (vm))]))) else (if sx_truthy ((prim_call "=" [op; (Number 112.0)])) then (let request = (vm_pop (vm)) in (sx_dict_set_b (vm_globals_ref (vm)) (String "__io_request") request)) else (raise (Eval_error (value_to_str (String (sx_str [(String "VM: unknown opcode "); op]))))))))))))))))))))))))))))))))))))))))))))))) diff --git a/lib/tree-tools.sx b/lib/tree-tools.sx index 12461d2d..2f1b4d30 100644 --- a/lib/tree-tools.sx +++ b/lib/tree-tools.sx @@ -1059,6 +1059,31 @@ pname))) (append! seen pname))))) params)))))) + (when + (= head-name "match") + (when + (>= (len node) 3) + (let + ((clauses (rest (rest node))) + (patterns (map first clauses)) + (has-wildcard + (some + (fn + (p) + (and + (symbol? p) + (not (= (symbol-name p) "true")) + (not (= (symbol-name p) "false")))) + patterns)) + (has-else false)) + (when + (not has-wildcard) + (append! + warnings + (str + "WARN " + (path-str path) + ": match may be non-exhaustive (no catch-all pattern)")))))) (for-each (fn (i) diff --git a/spec/evaluator.sx b/spec/evaluator.sx index 3cf36755..115ca610 100644 --- a/spec/evaluator.sx +++ b/spec/evaluator.sx @@ -1351,13 +1351,13 @@ kont)))) (define - step-sf-case + step-sf-callcc (fn (args env kont) (make-cek-state (first args) env - (kont-push (make-case-frame nil (rest args) env) kont)))) + (kont-push (make-callcc-frame env) kont)))) ;; ═══════════════════════════════════════════════════════════════ ;; R7RS syntax-rules / define-syntax @@ -1371,6 +1371,17 @@ ;; Match a syntax-rules pattern against a form. ;; Returns a dict of bindings on success, nil on failure. ;; literals is a list of symbol name strings that must match exactly. +(define + step-sf-case + (fn + (args env kont) + (make-cek-state + (first args) + env + (kont-push (make-case-frame nil (rest args) env) kont)))) + +;; Match a list pattern against a form list, handling ellipsis at any position. +;; pi = pattern index, fi = form index. (define step-sf-let-match (fn @@ -1384,8 +1395,8 @@ env kont)))) -;; Match a list pattern against a form list, handling ellipsis at any position. -;; pi = pattern index, fi = form index. +;; Find which pattern variable in a template drives an ellipsis. +;; Returns the variable name (string) whose binding is a list, or nil. (define step-eval-list (fn @@ -1550,8 +1561,8 @@ :else (step-eval-call head args env kont))))) (step-eval-call head args env kont)))))) -;; Find which pattern variable in a template drives an ellipsis. -;; Returns the variable name (string) whose binding is a list, or nil. +;; Find ALL ellipsis-bound pattern variables in a template. +;; Returns a list of variable name strings. (define step-sf-parameterize (fn @@ -1570,8 +1581,8 @@ (make-parameterize-frame bindings nil (list) body env) kont))))))) -;; Find ALL ellipsis-bound pattern variables in a template. -;; Returns a list of variable name strings. +;; Instantiate a template with pattern variable bindings. +;; Handles ellipsis repetition and recursive substitution. (define syntax-rules-match (fn @@ -1592,8 +1603,9 @@ (syntax-rules-match-list pattern 0 form 0 literals) :else (if (= pattern form) (dict) nil)))) -;; Instantiate a template with pattern variable bindings. -;; Handles ellipsis repetition and recursive substitution. +;; Walk a template list, handling ellipsis at any position. +;; When element at i is followed by ... at i+1, expand the element +;; for each value of its ellipsis variables (all cycled in parallel). (define syntax-rules-match-list (fn @@ -1676,9 +1688,10 @@ (keys sub-result)) rest-result))))))))) -;; Walk a template list, handling ellipsis at any position. -;; When element at i is followed by ... at i+1, expand the element -;; for each value of its ellipsis variables (all cycled in parallel). +;; Try each syntax-rules clause against a form. +;; Returns the instantiated template for the first matching rule, or errors. +;; form is the raw args (without macro name). We prepend a dummy _ symbol +;; because syntax-rules patterns include the keyword as the first element. (define syntax-rules-find-var (fn @@ -1698,10 +1711,6 @@ template) :else nil))) -;; Try each syntax-rules clause against a form. -;; Returns the instantiated template for the first matching rule, or errors. -;; form is the raw args (without macro name). We prepend a dummy _ symbol -;; because syntax-rules patterns include the keyword as the first element. (define syntax-rules-find-all-vars (fn @@ -1719,6 +1728,10 @@ template) :else (list)))) +;; Special form: (syntax-rules (literal ...) (pattern template) ...) +;; Creates a Macro with rules/literals stored in closure env. +;; Body is a marker symbol; expand-macro detects it and calls +;; the pattern matcher directly. (define syntax-rules-instantiate (fn @@ -1732,10 +1745,6 @@ template :else (syntax-rules-instantiate-list template 0 bindings)))) -;; Special form: (syntax-rules (literal ...) (pattern template) ...) -;; Creates a Macro with rules/literals stored in closure env. -;; Body is a marker symbol; expand-macro detects it and calls -;; the pattern matcher directly. (define syntax-rules-instantiate-list (fn @@ -1785,14 +1794,6 @@ (syntax-rules-instantiate elem bindings) (syntax-rules-instantiate-list template (+ i 1) bindings))))))) -(define - syntax-rules-expand - (fn - (literals rules form) - (let - ((full-form (cons (make-symbol "_") form))) - (syntax-rules-try-rules literals rules full-form)))) - ;; R7RS records (SRFI-9) ;; ;; (define-record-type @@ -1804,6 +1805,15 @@ ;; Creates: constructor, predicate, accessors, optional mutators. ;; Opaque — only accessible through generated functions. ;; Generative — each call creates a unique type. +(define + syntax-rules-expand + (fn + (literals rules form) + (let + ((full-form (cons (make-symbol "_") form))) + (syntax-rules-try-rules literals rules full-form)))) + +;; Delimited continuations (define syntax-rules-try-rules (fn @@ -1823,7 +1833,6 @@ (syntax-rules-instantiate template bindings) (syntax-rules-try-rules literals (rest rules) full-form))))))) -;; Delimited continuations (define sf-syntax-rules (fn @@ -1842,6 +1851,7 @@ closure "syntax-rules"))))) +;; Signal dereferencing with reactive dependency tracking (define step-sf-define-library (fn @@ -1886,7 +1896,13 @@ (register-library lib-spec export-dict) (make-cek-value nil env kont)))))) -;; Signal dereferencing with reactive dependency tracking +;; ═══════════════════════════════════════════════════════════════ +;; Part 8: Call Dispatch +;; +;; cek-call: invoke a function from native code (runs a nested +;; trampoline). step-eval-call: CEK-native call dispatch for +;; lambda, component, native fn, and continuations. +;; ═══════════════════════════════════════════════════════════════ (define bind-import-set (fn @@ -1918,13 +1934,7 @@ (fn (key) (env-bind! env key (get exports key))) (keys exports)))))))) -;; ═══════════════════════════════════════════════════════════════ -;; Part 8: Call Dispatch -;; -;; cek-call: invoke a function from native code (runs a nested -;; trampoline). step-eval-call: CEK-native call dispatch for -;; lambda, component, native fn, and continuations. -;; ═══════════════════════════════════════════════════════════════ +;; Reactive signal tracking — captures dependency continuation for re-render (define step-sf-import (fn @@ -1949,7 +1959,6 @@ env (kont-push (make-import-frame import-set rest-sets env) kont)))))))) -;; Reactive signal tracking — captures dependency continuation for re-render (define step-sf-perform (fn @@ -1962,8 +1971,6 @@ env (kont-push (make-perform-frame env) kont))))) -(define *protocol-registry* (dict)) - ;; ═══════════════════════════════════════════════════════════════ ;; Part 9: Higher-Order Form Machinery ;; @@ -1971,6 +1978,8 @@ ;; ho-swap-args auto-detects argument order. HoSetupFrame stages ;; argument evaluation, then dispatches to the appropriate step-ho-*. ;; ═══════════════════════════════════════════════════════════════ +(define *protocol-registry* (dict)) + (define sf-define-record-type (fn @@ -2062,6 +2071,67 @@ method-specs) nil))) +(define + check-match-exhaustiveness + (fn + (clauses) + (let + ((warnings (list)) + (patterns (map first clauses)) + (has-wildcard + (some + (fn + (p) + (or + (= p (quote _)) + (and + (symbol? p) + (not (= p (quote true))) + (not (= p (quote false)))))) + patterns)) + (has-else (some (fn (p) (= p :else)) patterns)) + (has-true (some (fn (p) (= p true)) patterns)) + (has-false (some (fn (p) (= p false)) patterns)) + (has-nil (some (fn (p) (= p nil)) patterns)) + (has-predicate + (some + (fn (p) (and (list? p) (= (first p) (quote ?)))) + patterns))) + (when + (and (not has-wildcard) (not has-else)) + (set! + warnings + (append + warnings + (list "match may be non-exhaustive (no wildcard or :else pattern)")))) + (when + (and + (or has-true has-false) + (not (and has-true has-false)) + (not has-wildcard) + (not has-else)) + (set! + warnings + (append + warnings + (list + (if + has-true + "match on boolean missing false case" + "match on boolean missing true case"))))) + (when + (and + has-nil + (not has-wildcard) + (not has-else) + (= (len patterns) 1)) + (set! + warnings + (append + warnings + (list "match checks nil but has no non-nil pattern")))) + warnings))) + (define sf-implement (fn @@ -2124,13 +2194,44 @@ (not (nil? (get (get proto "impls") (type-of value))))))))) (define - step-sf-callcc + check-match-exhaustiveness (fn - (args env kont) - (make-cek-state - (first args) - env - (kont-push (make-callcc-frame env) kont)))) + (clauses) + (let + ((warnings (list)) + (patterns (map (fn (c) (first c)) clauses)) + (has-wildcard + (some + (fn + (p) + (and (symbol? p) (not (= p true)) (not (= p false)))) + patterns)) + (has-else (some (fn (p) (= p :else)) patterns)) + (has-true (some (fn (p) (= p true)) patterns)) + (has-false (some (fn (p) (= p false)) patterns))) + (when + (and (not has-wildcard) (not has-else)) + (set! + warnings + (append + warnings + (list "match may be non-exhaustive (no wildcard or :else pattern)")))) + (when + (and + (or has-true has-false) + (not (and has-true has-false)) + (not has-wildcard) + (not has-else)) + (set! + warnings + (append + warnings + (list + (if + has-true + "match on boolean missing false case" + "match on boolean missing true case"))))) + warnings))) (define match-find-clause @@ -2234,6 +2335,14 @@ env (kont-push (make-handler-frame handlers (rest body) env) kont)))))) +;; ═══════════════════════════════════════════════════════════════ +;; Part 10: Continue Phase — Frame Dispatch +;; +;; When phase="continue", pop the top frame and process the value. +;; Each frame type has its own handling: if frames check truthiness, +;; let frames bind the value, arg frames accumulate it, etc. +;; continue-with-call handles the final function/component dispatch. +;; ═══════════════════════════════════════════════════════════════ (define step-sf-restart-case (fn @@ -2258,6 +2367,9 @@ env (kont-push (make-restart-frame restarts (list) env) kont))))) +;; Final call dispatch from arg frame — all args evaluated, invoke function. +;; Handles: lambda (bind params + TCO), component (keyword args + TCO), +;; native fn (direct call), continuation (resume), callcc continuation (escape). (define step-sf-signal (fn @@ -2275,14 +2387,6 @@ (list condition) (kont-push (make-signal-return-frame env kont) kont)))))) -;; ═══════════════════════════════════════════════════════════════ -;; Part 10: Continue Phase — Frame Dispatch -;; -;; When phase="continue", pop the top frame and process the value. -;; Each frame type has its own handling: if frames check truthiness, -;; let frames bind the value, arg frames accumulate it, etc. -;; continue-with-call handles the final function/component dispatch. -;; ═══════════════════════════════════════════════════════════════ (define step-sf-invoke-restart (fn @@ -2311,9 +2415,13 @@ (env-bind! restart-env (first params) restart-arg)) (make-cek-state body restart-env rest-kont))))))) -;; Final call dispatch from arg frame — all args evaluated, invoke function. -;; Handles: lambda (bind params + TCO), component (keyword args + TCO), -;; native fn (direct call), continuation (resume), callcc continuation (escape). +;; ═══════════════════════════════════════════════════════════════ +;; Part 11: Entry Points +;; +;; eval-expr-cek / trampoline-cek: CEK evaluation entry points. +;; eval-expr / trampoline: top-level bindings that override the +;; forward declarations from Part 5. +;; ═══════════════════════════════════════════════════════════════ (define step-sf-if (fn @@ -2337,13 +2445,6 @@ env (kont-push (make-when-frame (rest args) env) kont)))) -;; ═══════════════════════════════════════════════════════════════ -;; Part 11: Entry Points -;; -;; eval-expr-cek / trampoline-cek: CEK evaluation entry points. -;; eval-expr / trampoline: top-level bindings that override the -;; forward declarations from Part 5. -;; ═══════════════════════════════════════════════════════════════ (define step-sf-begin (fn