coop/rose-ash
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Step 7d complete: exhaustive match checking + evaluator cleanup

Browse Source 
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) <noreply@anthropic.com>
This commit is contained in:
giles
2026-04-04 15:43:57 +00:00
parent 653be79c8d
commit efd0d9168f
6 changed files with 213 additions and 80 deletions
Download Patch File Download Diff File Expand all files Collapse all files

10
hosts/ocaml/bootstrap.py
View File

@@ -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

11
hosts/ocaml/lib/sx_ref.ml
View File

@@ -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 =

8
hosts/ocaml/lib/sx_vm_ref.ml
View File

File diff suppressed because one or more lines are too long

8
hosts/ocaml/sx_vm_ref.ml
View File

File diff suppressed because one or more lines are too long

25
lib/tree-tools.sx
View File

@@ -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)

231
spec/evaluator.sx
View File

@@ -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 <point>
@@ -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