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

Step 10c: bind CEK special form + provide-set frame + scope-stack integration

Browse Source 
bind is now a CEK special form that captures its body unevaluated,
establishes a tracking context (*bind-tracking*), and registers
subscribers on provide frames when context reads are tracked.

- bind special form: step-sf-bind, make-bind-frame, bind continue handler
- provide-set frame: provide! evaluates value with kont (fixes peek bug)
- context tracking: step-sf-context appends to *bind-tracking* when active
- scope-stack fallback: provide pushes to scope stack for cek-call contexts
- CekFrame mutation: cf_remaining/cf_results/cf_extra2 now mutable
- Transpiler: subscribers + prev-tracking field mappings, *bind-tracking* in ml-mutable-globals
- Test fixes: string-append → str, restored edge-cases suite

Passing: bind returns initial value, bind with expression, bind with let,
bind no deps is static, bind with conditional deps, provide! updates/multiple/nil,
provide! computed new value, peek read-modify-write, guard inside bind,
bind with string-append, provide! same value does not notify, bind does not
fire on unrelated provide!, bind sees latest value, bind inside provide scope.

Remaining: subscriber re-evaluation on provide! (scope-stack key issue),
batch coalescing (no batch support yet).

Co-Authored-By: Claude Opus 4.6 (1M context) <noreply@anthropic.com>
This commit is contained in:
giles
2026-04-05 09:13:33 +00:00
parent 98fd315f14
commit a965731a33
6 changed files with 300 additions and 225 deletions
Download Patch File Download Diff File Expand all files Collapse all files

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

File diff suppressed because one or more lines are too long

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

@@ -80,6 +80,15 @@ let sx_dict_set_b d k v =
match d, k with
| Dict tbl, String key -> Hashtbl.replace tbl key v; v
| Dict tbl, Keyword key -> Hashtbl.replace tbl key v; v
| CekFrame f, String key ->
(match key with
| "value" | "extra" | "ho-type" | "scheme" | "indexed"
| "phase" | "has-effects" | "match-val" | "current-item"
| "update-fn" | "head-name" -> f.cf_extra <- v; v
| "remaining" -> f.cf_remaining <- v; v
| "subscribers" | "results" | "raw-args" -> f.cf_results <- v; v
| "emitted" | "effect-list" | "first-render" | "extra2" -> f.cf_extra2 <- v; v
| _ -> raise (Eval_error ("dict-set! cek-frame: unknown field " ^ key)))
| VmFrame f, String key ->
(match key with
| "ip" -> f.vf_ip <- val_to_int v; v
@@ -116,6 +125,8 @@ let get_val container key =
| "emitted" -> f.cf_extra2 | "effect-list" -> f.cf_extra2
| "first-render" -> f.cf_extra2 | "file" -> f.cf_env
| "extra" -> f.cf_extra | "extra2" -> f.cf_extra2
| "subscribers" -> f.cf_results
| "prev-tracking" -> f.cf_extra
| _ -> Nil)
| VmFrame f, String k ->
(match k with

6
hosts/ocaml/lib/sx_types.ml
View File

@@ -91,12 +91,12 @@ and cek_frame = {
cf_env : value; (* environment — every frame has this *)
cf_name : value; (* let/define/set/scope: binding name *)
cf_body : value; (* when/let: body expr *)
cf_remaining : value; (* begin/cond/map/etc: remaining exprs *)
mutable cf_remaining : value; (* begin/cond/map/etc: remaining exprs *)
cf_f : value; (* call/map/filter/etc: function *)
cf_args : value; (* call: raw args; arg: evaled args *)
cf_results : value; (* map/filter/dict: accumulated results *)
mutable cf_results : value; (* map/filter/dict: accumulated results; provide: subscribers *)
mutable cf_extra : value; (* extra field: scheme, indexed, value, phase, etc. *)
cf_extra2 : value; (* second extra: emitted, etc. *)
mutable cf_extra2 : value; (* second extra: emitted, etc. *)
}
(** Mutable string-keyed table (SX dicts support [dict-set!]). *)

6
hosts/ocaml/transpiler.sx
View File

@@ -285,7 +285,7 @@
(define
ml-mutable-globals
(list "*strict*" "*prim-param-types*" "*last-error-kont*"))
(list "*strict*" "*prim-param-types*" "*last-error-kont*" "*bind-tracking*"))
(define
ml-is-mutable-global?
@@ -539,6 +539,8 @@
(ef "results")
(some (fn (k) (= k "raw-args")) items)
(ef "raw-args")
(some (fn (k) (= k "subscribers")) items)
(ef "subscribers")
:else "Nil")
"; cf_extra = "
(cond
@@ -562,6 +564,8 @@
(ef "update-fn")
(some (fn (k) (= k "head-name")) items)
(ef "head-name")
(some (fn (k) (= k "prev-tracking")) items)
(ef "prev-tracking")
(some (fn (k) (= k "extra")) items)
(ef "extra")
:else "Nil")

402
spec/evaluator.sx
View File

@@ -108,43 +108,53 @@
(define make-scope-frame (fn (name remaining env) {:env env :type "scope" :remaining remaining :name name}))
(define make-provide-frame (fn (name value remaining env) {:env env :value value :type "provide" :remaining remaining :name name}))
(define make-provide-frame (fn (name value remaining env) {:subscribers (list) :env env :value value :type "provide" :remaining remaining :name name}))
(define make-bind-frame (fn (body env prev-tracking) {:body body :env env :type "bind" :prev-tracking prev-tracking}))
;; Dynamic wind + reactive signals
(define make-provide-set-frame (fn (name env) {:env env :type "provide-set" :name name}))
(define make-scope-acc-frame (fn (name value remaining env) {:env env :value (or value nil) :type "scope-acc" :remaining remaining :emitted (list) :name name}))
;; Dynamic wind + reactive signals
;; Undelimited continuations (call/cc)
(define make-reset-frame (fn (env) {:env env :type "reset"}))
(define make-dict-frame (fn (remaining results env) {:env env :results results :type "dict" :remaining remaining}))
;; Undelimited continuations (call/cc)
;; HO setup: staged argument evaluation for map/filter/etc.
;; Evaluates args one at a time, then dispatches to the correct
;; HO frame (map, filter, reduce) once all args are ready.
(define make-and-frame (fn (remaining env) {:env env :type "and" :remaining remaining}))
(define make-or-frame (fn (remaining env) {:env env :type "or" :remaining remaining}))
;; HO setup: staged argument evaluation for map/filter/etc.
;; Evaluates args one at a time, then dispatches to the correct
;; HO frame (map, filter, reduce) once all args are ready.
(define
make-dynamic-wind-frame
(fn (phase body-thunk after-thunk env) {:env env :phase phase :after-thunk after-thunk :type "dynamic-wind" :body-thunk body-thunk}))
;; Condition system frames (handler-bind, restart-case, signal)
(define
make-reactive-reset-frame
(fn (env update-fn first-render?) {:first-render first-render? :update-fn update-fn :env env :type "reactive-reset"}))
(define make-callcc-frame (fn (env) {:env env :type "callcc"}))
;; Condition system frames (handler-bind, restart-case, signal)
(define make-deref-frame (fn (env) {:env env :type "deref"}))
;; R7RS exception frames (raise, guard)
(define
make-ho-setup-frame
(fn (ho-type remaining-args evaled-args env) {:ho-type ho-type :env env :evaled evaled-args :type "ho-setup" :remaining remaining-args}))
(define make-comp-trace-frame (fn (name file) {:env file :type "comp-trace" :name name}))
;; R7RS exception frames (raise, guard)
;; ═══════════════════════════════════════════════════════════════
;; Part 3: Continuation Stack Operations
;;
;; Searching and manipulating the kont list — finding handlers,
;; restarts, scope accumulators, and capturing delimited slices.
;; ═══════════════════════════════════════════════════════════════
(define
kont-collect-comp-trace
(fn
@@ -161,27 +171,22 @@
(define make-handler-frame (fn (handlers remaining env) {:env env :type "handler" :f handlers :remaining remaining}))
;; ═══════════════════════════════════════════════════════════════
;; Part 3: Continuation Stack Operations
;;
;; Searching and manipulating the kont list — finding handlers,
;; restarts, scope accumulators, and capturing delimited slices.
;; ═══════════════════════════════════════════════════════════════
(define make-restart-frame (fn (restarts remaining env) {:env env :type "restart" :f restarts :remaining remaining}))
(define make-signal-return-frame (fn (env saved-kont) {:env env :type "signal-return" :f saved-kont}))
;; Basic kont operations
(define make-raise-eval-frame (fn (env continuable?) {:scheme continuable? :env env :type "raise-eval"}))
(define make-raise-guard-frame (fn (env saved-kont) {:env env :type "raise-guard" :remaining saved-kont}))
;; Basic kont operations
(define make-perform-frame (fn (env) {:env env :type "perform"}))
(define make-vm-resume-frame (fn (resume-fn env) {:env env :type "vm-resume" :f resume-fn}))
(define make-import-frame (fn (import-set remaining-sets env) {:args import-set :env env :type "import" :remaining remaining-sets}))
;; Capture frames up to a reset boundary — used by shift
(define
make-parameterize-frame
(fn (remaining current-param results body env) {:env env :body body :results results :type "parameterize" :f current-param :remaining remaining}))
@@ -202,7 +207,6 @@
handler-fn
(find-matching-handler (rest handlers) condition)))))))
;; Capture frames up to a reset boundary — used by shift
(define
kont-find-handler
(fn
@@ -255,16 +259,16 @@
(list match frame (rest kont))))
(kont-find-restart (rest kont) name))))))
(define frame-type (fn (f) (get f "type")))
(define kont-push (fn (frame kont) (cons frame kont)))
;; ═══════════════════════════════════════════════════════════════
;; Part 4: Extension Points & Mutable State
;;
;; Custom special forms registry, render hooks, strict mode.
;; Mutable globals use set! — the transpiler emits OCaml refs.
;; ═══════════════════════════════════════════════════════════════
(define frame-type (fn (f) (get f "type")))
(define kont-push (fn (frame kont) (cons frame kont)))
(define kont-top (fn (kont) (first kont)))
(define kont-pop (fn (kont) (rest kont)))
@@ -371,14 +375,6 @@
(scan (rest k) (append captured (list frame))))))))
(scan kont (list))))
(define *custom-special-forms* (dict))
(define
register-special-form!
(fn
((name :as string) handler)
(dict-set! *custom-special-forms* name handler)))
;; ═══════════════════════════════════════════════════════════════
;; Part 5: Evaluation Utilities
;;
@@ -387,15 +383,26 @@
;; defmacro, quasiquote), and macro expansion.
;; ═══════════════════════════════════════════════════════════════
;; Forward declaration — redefined at end of file as CEK entry point
(define *render-check* nil)
(define *custom-special-forms* (dict))
;; Shared param binding for lambda/component calls.
;; Handles &rest collection — used by both call-lambda and continue-with-call.
(define *render-fn* nil)
(define
register-special-form!
(fn
((name :as string) handler)
(dict-set! *custom-special-forms* name handler)))
(define *library-registry* (dict))
(define *render-check* nil)
;; Component calls: parse keyword args, bind params, TCO thunk
(define *render-fn* nil)
(define *bind-tracking* nil)
;; Cond/case helpers
(define *library-registry* (dict))
(define
library-name-key
(fn
@@ -404,11 +411,11 @@
"."
(map (fn (s) (if (symbol? s) (symbol-name s) (str s))) spec))))
;; Special form constructors — build state for CEK evaluation
(define
library-loaded?
(fn (spec) (has-key? *library-registry* (library-name-key spec))))
;; Cond/case helpers
(define
library-exports
(fn
@@ -421,7 +428,6 @@
(spec exports)
(dict-set! *library-registry* (library-name-key spec) {:exports exports})))
;; Special form constructors — build state for CEK evaluation
(define *io-registry* (dict))
(define io-register! (fn (name spec) (dict-set! *io-registry* name spec)))
@@ -432,6 +438,7 @@
(define io-names (fn () (keys *io-registry*)))
;; Quasiquote expansion
(define
step-sf-io
(fn
@@ -458,13 +465,13 @@
(define *strict* false)
;; Quasiquote expansion
(define set-strict! (fn (val) (set! *strict* val)))
(define *prim-param-types* nil)
(define set-prim-param-types! (fn (types) (set! *prim-param-types* types)))
;; Macro expansion — expand then re-evaluate the result
(define
value-matches-type?
(fn
@@ -491,6 +498,14 @@
(slice expected-type 0 (- (string-length expected-type) 1))))
true)))))
;; ═══════════════════════════════════════════════════════════════
;; Part 6: CEK Machine Core
;;
;; cek-run: trampoline loop — steps until terminal.
;; cek-step: single step — dispatches on phase (eval vs continue).
;; step-eval: evaluates control expression, pushes frames.
;; step-continue: pops a frame, processes result.
;; ═══════════════════════════════════════════════════════════════
(define
strict-check-args
(fn
@@ -562,7 +577,6 @@
(define eval-expr (fn (expr (env :as dict)) nil))
;; Macro expansion — expand then re-evaluate the result
(define
bind-lambda-params
(fn
@@ -588,12 +602,10 @@
false))))
;; ═══════════════════════════════════════════════════════════════
;; Part 6: CEK Machine Core
;; Part 7: Special Form Step Functions
;;
;; cek-run: trampoline loop — steps until terminal.
;; cek-step: single step — dispatches on phase (eval vs continue).
;; step-eval: evaluates control expression, pushes frames.
;; step-continue: pops a frame, processes result.
;; Each step-sf-* handles one special form in the eval phase.
;; They push frames and return new CEK states — never recurse.
;; ═══════════════════════════════════════════════════════════════
(define
call-lambda
@@ -621,6 +633,7 @@
(slice params (len args))))
(make-thunk (lambda-body f) local))))
;; R7RS guard: desugars to call/cc + handler-bind with sentinel re-raise
(define
call-component
(fn
@@ -638,6 +651,9 @@
(env-bind! local "children" children))
(make-thunk (component-body comp) local))))
;; List evaluation — dispatches on head: special forms, macros,
;; higher-order forms, or function calls. This is the main
;; expression dispatcher for the CEK machine.
(define
parse-keyword-args
(fn
@@ -669,12 +685,7 @@
raw-args)
(list kwargs children))))
;; ═══════════════════════════════════════════════════════════════
;; Part 7: Special Form Step Functions
;;
;; Each step-sf-* handles one special form in the eval phase.
;; They push frames and return new CEK states — never recurse.
;; ═══════════════════════════════════════════════════════════════
;; call/cc: capture entire kont as undelimited escape continuation
(define
cond-scheme?
(fn
@@ -692,7 +703,6 @@
(= (symbol-name (nth c 1)) "=>")))))
clauses)))
;; R7RS guard: desugars to call/cc + handler-bind with sentinel re-raise
(define
is-else-clause?
(fn
@@ -703,9 +713,6 @@
(= (type-of test) "symbol")
(or (= (symbol-name test) "else") (= (symbol-name test) ":else"))))))
;; List evaluation — dispatches on head: special forms, macros,
;; higher-order forms, or function calls. This is the main
;; expression dispatcher for the CEK machine.
(define
sf-named-let
(fn
@@ -753,7 +760,7 @@
((init-vals (map (fn (e) (trampoline (eval-expr e env))) inits)))
(cek-call loop-fn init-vals))))))
;; call/cc: capture entire kont as undelimited escape continuation
;; Pattern matching (match form)
(define
sf-lambda
(fn
@@ -783,6 +790,7 @@
params-expr)))
(make-lambda param-names body env))))
;; Condition system special forms
(define
sf-defcomp
(fn
@@ -842,7 +850,6 @@
(range 2 end 1))
result)))
;; Pattern matching (match form)
(define
parse-comp-params
(fn
@@ -889,7 +896,6 @@
params-expr)
(list params has-children param-types))))
;; Condition system special forms
(define
sf-defisland
(fn
@@ -1181,6 +1187,7 @@
state
(cek-step-loop (cek-step state)))))
;; Scope/provide/context — structured downward data passing
(define
cek-run
(fn
@@ -1211,7 +1218,6 @@
(step-eval state)
(step-continue state))))
;; Scope/provide/context — structured downward data passing
(define
step-eval
(fn
@@ -1268,6 +1274,18 @@
(step-eval-list expr env kont))
:else (make-cek-value expr env kont)))))
;; ═══════════════════════════════════════════════════════════════
;; R7RS syntax-rules / define-syntax
;;
;; syntax-rules creates a macro transformer via pattern matching.
;; define-syntax binds the transformer as a macro (reuses define).
;; Pattern language: _ (wildcard), literals (exact match),
;; pattern variables (bind), ... (ellipsis/repetition).
;; ═══════════════════════════════════════════════════════════════
;; 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-raise
(fn
@@ -1277,6 +1295,8 @@
env
(kont-push (make-raise-eval-frame env false) kont))))
;; Match a list pattern against a form list, handling ellipsis at any position.
;; pi = pattern index, fi = form index.
(define
step-sf-guard
(fn
@@ -1350,6 +1370,8 @@
env
kont))))
;; Find which pattern variable in a template drives an ellipsis.
;; Returns the variable name (string) whose binding is a list, or nil.
(define
step-sf-callcc
(fn
@@ -1359,18 +1381,8 @@
env
(kont-push (make-callcc-frame env) kont))))
;; ═══════════════════════════════════════════════════════════════
;; R7RS syntax-rules / define-syntax
;;
;; syntax-rules creates a macro transformer via pattern matching.
;; define-syntax binds the transformer as a macro (reuses define).
;; Pattern language: _ (wildcard), literals (exact match),
;; pattern variables (bind), ... (ellipsis/repetition).
;; ═══════════════════════════════════════════════════════════════
;; 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.
;; Find ALL ellipsis-bound pattern variables in a template.
;; Returns a list of variable name strings.
(define
step-sf-case
(fn
@@ -1380,8 +1392,8 @@
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.
;; Instantiate a template with pattern variable bindings.
;; Handles ellipsis repetition and recursive substitution.
(define
step-sf-let-match
(fn
@@ -1395,8 +1407,9 @@
env
kont))))
;; Find which pattern variable in a template drives an ellipsis.
;; Returns the variable name (string) whose binding is a list, or nil.
;; 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
step-eval-list
(fn
@@ -1509,6 +1522,7 @@
("peek" (step-sf-peek args env kont))
("provide!" (step-sf-provide! args env kont))
("context" (step-sf-context args env kont))
("bind" (step-sf-bind args env kont))
("emit!" (step-sf-emit args env kont))
("emitted" (step-sf-emitted args env kont))
("handler-bind" (step-sf-handler-bind args env kont))
@@ -1563,8 +1577,51 @@
:else (step-eval-call head args env kont)))))
(step-eval-call head args env kont))))))
;; Find ALL ellipsis-bound pattern variables in a template.
;; Returns a list of variable name strings.
;; 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
kont-extract-provides
(fn
(kont)
(if
(empty? kont)
(list)
(let
((frame (first kont))
(rest-frames (kont-extract-provides (rest kont))))
(if
(= (frame-type frame) "provide")
(cons {:subscribers (list) :env (get frame "env") :value (get frame "value") :type "provide" :remaining (list) :name (get frame "name")} rest-frames)
rest-frames)))))
(define
fire-provide-subscribers
(fn
(frame kont)
(let
((subs (get frame "subscribers")))
(when
(not (empty? subs))
(for-each (fn (sub) (cek-call sub (list kont))) subs)))))
;; 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
step-sf-bind
(fn
(args env kont)
(let
((body (first args)) (prev *bind-tracking*))
(set! *bind-tracking* (list))
(make-cek-state
body
env
(kont-push (make-bind-frame body env prev) kont)))))
(define
step-sf-parameterize
(fn
@@ -1583,8 +1640,17 @@
(make-parameterize-frame bindings nil (list) body env)
kont)))))))
;; Instantiate a template with pattern variable bindings.
;; Handles ellipsis repetition and recursive substitution.
;; R7RS records (SRFI-9)
;;
;; (define-record-type <point>
;; (make-point x y)
;; point?
;; (x point-x)
;; (y point-y set-point-y!))
;;
;; Creates: constructor, predicate, accessors, optional mutators.
;; Opaque — only accessible through generated functions.
;; Generative — each call creates a unique type.
(define
syntax-rules-match
(fn
@@ -1605,9 +1671,7 @@
(syntax-rules-match-list pattern 0 form 0 literals)
:else (if (= pattern form) (dict) nil))))
;; 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).
;; Delimited continuations
(define
syntax-rules-match-list
(fn
@@ -1690,10 +1754,6 @@
(keys sub-result))
rest-result)))))))))
;; 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
@@ -1713,6 +1773,7 @@
template)
:else nil)))
;; Signal dereferencing with reactive dependency tracking
(define
syntax-rules-find-all-vars
(fn
@@ -1730,10 +1791,13 @@
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.
;; ═══════════════════════════════════════════════════════════════
;; 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
syntax-rules-instantiate
(fn
@@ -1747,6 +1811,7 @@
template
:else (syntax-rules-instantiate-list template 0 bindings))))
;; Reactive signal tracking — captures dependency continuation for re-render
(define
syntax-rules-instantiate-list
(fn
@@ -1796,17 +1861,6 @@
(syntax-rules-instantiate elem bindings)
(syntax-rules-instantiate-list template (+ i 1) bindings)))))))
;; R7RS records (SRFI-9)
;;
;; (define-record-type <point>
;; (make-point x y)
;; point?
;; (x point-x)
;; (y point-y set-point-y!))
;;
;; Creates: constructor, predicate, accessors, optional mutators.
;; Opaque — only accessible through generated functions.
;; Generative — each call creates a unique type.
(define
syntax-rules-expand
(fn
@@ -1815,7 +1869,13 @@
((full-form (cons (make-symbol "_") form)))
(syntax-rules-try-rules literals rules full-form))))
;; Delimited continuations
;; ═══════════════════════════════════════════════════════════════
;; Part 9: Higher-Order Form Machinery
;;
;; Data-first HO forms: (map coll fn) and (map fn coll) both work.
;; ho-swap-args auto-detects argument order. HoSetupFrame stages
;; argument evaluation, then dispatches to the appropriate step-ho-*.
;; ═══════════════════════════════════════════════════════════════
(define
syntax-rules-try-rules
(fn
@@ -1853,7 +1913,6 @@
closure
"syntax-rules")))))
;; Signal dereferencing with reactive dependency tracking
(define
step-sf-define-library
(fn
@@ -1898,13 +1957,6 @@
(register-library lib-spec export-dict)
(make-cek-value nil env kont))))))
;; ═══════════════════════════════════════════════════════════════
;; 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
@@ -1936,7 +1988,6 @@
(fn (key) (env-bind! env key (get exports key)))
(keys exports))))))))
;; Reactive signal tracking — captures dependency continuation for re-render
(define
step-sf-import
(fn
@@ -1973,13 +2024,6 @@
env
(kont-push (make-perform-frame env) kont)))))
;; ═══════════════════════════════════════════════════════════════
;; Part 9: Higher-Order Form Machinery
;;
;; Data-first HO forms: (map coll fn) and (map fn coll) both work.
;; ho-swap-args auto-detects argument order. HoSetupFrame stages
;; argument evaluation, then dispatches to the appropriate step-ho-*.
;; ═══════════════════════════════════════════════════════════════
(define *protocol-registry* (dict))
(define
@@ -2181,6 +2225,14 @@
(dict-set! impls type-name type-impls)
nil))))))
;; ═══════════════════════════════════════════════════════════════
;; 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
satisfies?
(fn
@@ -2195,6 +2247,9 @@
false
(not (nil? (get (get proto "impls") (type-of value)))))))))
;; 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
check-match-exhaustiveness
(fn
@@ -2252,6 +2307,13 @@
(list local body)
(match-find-clause val (rest clauses) env))))))
;; ═══════════════════════════════════════════════════════════════
;; 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
match-pattern
(fn
@@ -2337,14 +2399,6 @@
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
@@ -2369,9 +2423,6 @@
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
@@ -2417,13 +2468,6 @@
(env-bind! restart-env (first params) restart-arg))
(make-cek-state body restart-env rest-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-if
(fn
@@ -2679,9 +2723,10 @@
((name (trampoline (eval-expr (first args) env)))
(val (trampoline (eval-expr (nth args 1) env)))
(body (slice args 2)))
(scope-push! name val)
(if
(empty? body)
(make-cek-value nil env kont)
(do (scope-pop! name) (make-cek-value nil env kont))
(make-cek-state
(first body)
env
@@ -2699,14 +2744,16 @@
(trampoline (eval-expr (nth args 1) env))
nil))
(frame (kont-find-provide kont name)))
(when
(and frame *bind-tracking*)
(when
(not (contains? *bind-tracking* frame))
(append! *bind-tracking* frame)))
(make-cek-value
(if
frame
(get frame "value")
(if
(env-has? env "context")
(apply (env-get env "context") (list name default-val))
default-val))
(let ((sv (scope-peek name))) (if (nil? sv) default-val sv)))
env
kont))))
@@ -2738,20 +2785,11 @@
(fn
(args env kont)
(let
((name (trampoline (eval-expr (first args) env)))
(new-val (trampoline (eval-expr (nth args 1) env)))
(frame (kont-find-provide kont name)))
(if
frame
(do
(dict-set! frame "value" new-val)
(make-cek-value new-val env kont))
(if
(env-has? env "provide-set!")
(do
(apply (env-get env "provide-set!") (list name new-val))
(make-cek-value new-val env kont))
(make-cek-value nil env kont))))))
((name (trampoline (eval-expr (first args) env))))
(make-cek-state
(nth args 1)
env
(kont-push (make-provide-set-frame name env) kont)))))
(define
step-sf-emit
@@ -3538,17 +3576,59 @@
(fenv (get frame "env")))
(if
(empty? remaining)
(make-cek-value value fenv rest-k)
(make-cek-state
(first remaining)
fenv
(kont-push
(make-provide-frame
(get frame "name")
(get frame "value")
(rest remaining)
fenv)
rest-k)))))
(do
(scope-pop! (get frame "name"))
(make-cek-value value fenv rest-k))
(let
((new-frame (make-provide-frame (get frame "name") (get frame "value") (rest remaining) fenv)))
(dict-set!
new-frame
"subscribers"
(get frame "subscribers"))
(make-cek-state
(first remaining)
fenv
(kont-push new-frame rest-k))))))
("bind"
(let
((tracked *bind-tracking*)
(body (get frame "body"))
(fenv (get frame "env"))
(prev (get frame "prev-tracking")))
(set! *bind-tracking* prev)
(let
((subscriber (fn (fire-kont) (let ((provide-kont (kont-extract-provides fire-kont))) (cek-run (make-cek-state body fenv provide-kont))))))
(for-each
(fn
(pf)
(dict-set!
pf
"subscribers"
(append (get pf "subscribers") (list subscriber))))
tracked))
(make-cek-value value fenv rest-k)))
("provide-set"
(let
((name (get frame "name"))
(fenv (get frame "env"))
(target (kont-find-provide rest-k name)))
(if
target
(let
((old-val (get target "value")))
(dict-set! target "value" value)
(scope-pop! name)
(scope-push! name value)
(when
(not (= old-val value))
(fire-provide-subscribers target rest-k))
(make-cek-value value fenv rest-k))
(if
(env-has? fenv "provide-set!")
(do
(apply (env-get fenv "provide-set!") (list name value))
(make-cek-value value fenv rest-k))
(make-cek-value nil fenv rest-k)))))
("scope-acc"
(let
((remaining (get frame "remaining"))

11
spec/tests/test-unified-reactive.sx
View File

@@ -106,7 +106,7 @@
:prefix "item-"
(assert-equal
(list "item-a" "item-b")
(map (fn (x) (string-append (context :prefix) x)) (list "a" "b")))))
(map (fn (x) (str (context :prefix) x)) (list "a" "b")))))
(deftest
"context with keyword name"
(provide :my-key 99 (assert-equal 99 (context :my-key)))))
@@ -260,10 +260,7 @@
:x 5
(assert-equal
"value: 5"
(bind
(let
((v (context :x)))
(string-append "value: " (number->string v)))))))
(bind (let ((v (context :x))) (str "value: " v))))))
(deftest
"bind no deps is static"
(let
@@ -532,7 +529,7 @@
"guard inside bind"
(provide
:x 1
(assert-equal 1 (bind (guard (exn (#t -1)) (context :x))))))
(assert-equal 1 (bind (guard (exn (true -1)) (context :x))))))
(deftest
"bind with string-append"
(provide
@@ -541,4 +538,4 @@
:second "world"
(assert-equal
"hello world"
(bind (string-append (context :first) " " (context :second))))))))
(bind (str (context :first) " " (context :second))))))))