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 match d, k with
| Dict tbl, String key -> Hashtbl.replace tbl key v; v | Dict tbl, String key -> Hashtbl.replace tbl key v; v
| Dict tbl, Keyword 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 -> | VmFrame f, String key ->
(match key with (match key with
| "ip" -> f.vf_ip <- val_to_int v; v | "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 | "emitted" -> f.cf_extra2 | "effect-list" -> f.cf_extra2
| "first-render" -> f.cf_extra2 | "file" -> f.cf_env | "first-render" -> f.cf_extra2 | "file" -> f.cf_env
| "extra" -> f.cf_extra | "extra2" -> f.cf_extra2 | "extra" -> f.cf_extra | "extra2" -> f.cf_extra2
| "subscribers" -> f.cf_results
| "prev-tracking" -> f.cf_extra
| _ -> Nil) | _ -> Nil)
| VmFrame f, String k -> | VmFrame f, String k ->
(match k with (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_env : value; (* environment — every frame has this *)
cf_name : value; (* let/define/set/scope: binding name *) cf_name : value; (* let/define/set/scope: binding name *)
cf_body : value; (* when/let: body expr *) 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_f : value; (* call/map/filter/etc: function *)
cf_args : value; (* call: raw args; arg: evaled args *) 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. *) 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!]). *) (** Mutable string-keyed table (SX dicts support [dict-set!]). *)

6
hosts/ocaml/transpiler.sx
View File

@@ -285,7 +285,7 @@
(define (define
ml-mutable-globals ml-mutable-globals
(list "*strict*" "*prim-param-types*" "*last-error-kont*")) (list "*strict*" "*prim-param-types*" "*last-error-kont*" "*bind-tracking*"))
(define (define
ml-is-mutable-global? ml-is-mutable-global?
@@ -539,6 +539,8 @@
(ef "results") (ef "results")
(some (fn (k) (= k "raw-args")) items) (some (fn (k) (= k "raw-args")) items)
(ef "raw-args") (ef "raw-args")
(some (fn (k) (= k "subscribers")) items)
(ef "subscribers")
:else "Nil") :else "Nil")
"; cf_extra = " "; cf_extra = "
(cond (cond
@@ -562,6 +564,8 @@
(ef "update-fn") (ef "update-fn")
(some (fn (k) (= k "head-name")) items) (some (fn (k) (= k "head-name")) items)
(ef "head-name") (ef "head-name")
(some (fn (k) (= k "prev-tracking")) items)
(ef "prev-tracking")
(some (fn (k) (= k "extra")) items) (some (fn (k) (= k "extra")) items)
(ef "extra") (ef "extra")
:else "Nil") :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-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})) (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-reset-frame (fn (env) {:env env :type "reset"}))
(define make-dict-frame (fn (remaining results env) {:env env :results results :type "dict" :remaining remaining})) (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-and-frame (fn (remaining env) {:env env :type "and" :remaining remaining}))
(define make-or-frame (fn (remaining env) {:env env :type "or" :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 (define
make-dynamic-wind-frame 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})) (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 (define
make-reactive-reset-frame make-reactive-reset-frame
(fn (env update-fn first-render?) {:first-render first-render? :update-fn update-fn :env env :type "reactive-reset"})) (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"})) (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"})) (define make-deref-frame (fn (env) {:env env :type "deref"}))
;; R7RS exception frames (raise, guard)
(define (define
make-ho-setup-frame 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})) (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})) (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 (define
kont-collect-comp-trace kont-collect-comp-trace
(fn (fn
@@ -161,27 +171,22 @@
(define make-handler-frame (fn (handlers remaining env) {:env env :type "handler" :f handlers :remaining remaining})) (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-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})) (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-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})) (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-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-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})) (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 (define
make-parameterize-frame make-parameterize-frame
(fn (remaining current-param results body env) {:env env :body body :results results :type "parameterize" :f current-param :remaining remaining})) (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 handler-fn
(find-matching-handler (rest handlers) condition))))))) (find-matching-handler (rest handlers) condition)))))))
;; Capture frames up to a reset boundary — used by shift
(define (define
kont-find-handler kont-find-handler
(fn (fn
@@ -255,16 +259,16 @@
(list match frame (rest kont)))) (list match frame (rest kont))))
(kont-find-restart (rest kont) name)))))) (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 ;; Part 4: Extension Points & Mutable State
;; ;;
;; Custom special forms registry, render hooks, strict mode. ;; Custom special forms registry, render hooks, strict mode.
;; Mutable globals use set! — the transpiler emits OCaml refs. ;; 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-top (fn (kont) (first kont)))
(define kont-pop (fn (kont) (rest kont))) (define kont-pop (fn (kont) (rest kont)))
@@ -371,14 +375,6 @@
(scan (rest k) (append captured (list frame)))))))) (scan (rest k) (append captured (list frame))))))))
(scan kont (list)))) (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 ;; Part 5: Evaluation Utilities
;; ;;
@@ -387,15 +383,26 @@
;; defmacro, quasiquote), and macro expansion. ;; defmacro, quasiquote), and macro expansion.
;; ═══════════════════════════════════════════════════════════════ ;; ═══════════════════════════════════════════════════════════════
;; Forward declaration — redefined at end of file as CEK entry point ;; 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. ;; Shared param binding for lambda/component calls.
;; Handles &rest collection — used by both call-lambda and continue-with-call. ;; 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 ;; 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 (define
library-name-key library-name-key
(fn (fn
@@ -404,11 +411,11 @@
"." "."
(map (fn (s) (if (symbol? s) (symbol-name s) (str s))) spec)))) (map (fn (s) (if (symbol? s) (symbol-name s) (str s))) spec))))
;; Special form constructors — build state for CEK evaluation
(define (define
library-loaded? library-loaded?
(fn (spec) (has-key? *library-registry* (library-name-key spec)))) (fn (spec) (has-key? *library-registry* (library-name-key spec))))
;; Cond/case helpers
(define (define
library-exports library-exports
(fn (fn
@@ -421,7 +428,6 @@
(spec exports) (spec exports)
(dict-set! *library-registry* (library-name-key spec) {:exports 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-registry* (dict))
(define io-register! (fn (name spec) (dict-set! *io-registry* name spec))) (define io-register! (fn (name spec) (dict-set! *io-registry* name spec)))
@@ -432,6 +438,7 @@
(define io-names (fn () (keys *io-registry*))) (define io-names (fn () (keys *io-registry*)))
;; Quasiquote expansion
(define (define
step-sf-io step-sf-io
(fn (fn
@@ -458,13 +465,13 @@
(define *strict* false) (define *strict* false)
;; Quasiquote expansion
(define set-strict! (fn (val) (set! *strict* val))) (define set-strict! (fn (val) (set! *strict* val)))
(define *prim-param-types* nil) (define *prim-param-types* nil)
(define set-prim-param-types! (fn (types) (set! *prim-param-types* types))) (define set-prim-param-types! (fn (types) (set! *prim-param-types* types)))
;; Macro expansion — expand then re-evaluate the result
(define (define
value-matches-type? value-matches-type?
(fn (fn
@@ -491,6 +498,14 @@
(slice expected-type 0 (- (string-length expected-type) 1)))) (slice expected-type 0 (- (string-length expected-type) 1))))
true))))) 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 (define
strict-check-args strict-check-args
(fn (fn
@@ -562,7 +577,6 @@
(define eval-expr (fn (expr (env :as dict)) nil)) (define eval-expr (fn (expr (env :as dict)) nil))
;; Macro expansion — expand then re-evaluate the result
(define (define
bind-lambda-params bind-lambda-params
(fn (fn
@@ -588,12 +602,10 @@
false)))) false))))
;; ═══════════════════════════════════════════════════════════════ ;; ═══════════════════════════════════════════════════════════════
;; Part 6: CEK Machine Core ;; Part 7: Special Form Step Functions
;; ;;
;; cek-run: trampoline loop — steps until terminal. ;; Each step-sf-* handles one special form in the eval phase.
;; cek-step: single step — dispatches on phase (eval vs continue). ;; They push frames and return new CEK states — never recurse.
;; step-eval: evaluates control expression, pushes frames.
;; step-continue: pops a frame, processes result.
;; ═══════════════════════════════════════════════════════════════ ;; ═══════════════════════════════════════════════════════════════
(define (define
call-lambda call-lambda
@@ -621,6 +633,7 @@
(slice params (len args)))) (slice params (len args))))
(make-thunk (lambda-body f) local)))) (make-thunk (lambda-body f) local))))
;; R7RS guard: desugars to call/cc + handler-bind with sentinel re-raise
(define (define
call-component call-component
(fn (fn
@@ -638,6 +651,9 @@
(env-bind! local "children" children)) (env-bind! local "children" children))
(make-thunk (component-body comp) local)))) (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 (define
parse-keyword-args parse-keyword-args
(fn (fn
@@ -669,12 +685,7 @@
raw-args) raw-args)
(list kwargs children)))) (list kwargs children))))
;; ═══════════════════════════════════════════════════════════════ ;; call/cc: capture entire kont as undelimited escape continuation
;; 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.
;; ═══════════════════════════════════════════════════════════════
(define (define
cond-scheme? cond-scheme?
(fn (fn
@@ -692,7 +703,6 @@
(= (symbol-name (nth c 1)) "=>"))))) (= (symbol-name (nth c 1)) "=>")))))
clauses))) clauses)))
;; R7RS guard: desugars to call/cc + handler-bind with sentinel re-raise
(define (define
is-else-clause? is-else-clause?
(fn (fn
@@ -703,9 +713,6 @@
(= (type-of test) "symbol") (= (type-of test) "symbol")
(or (= (symbol-name test) "else") (= (symbol-name test) ":else")))))) (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 (define
sf-named-let sf-named-let
(fn (fn
@@ -753,7 +760,7 @@
((init-vals (map (fn (e) (trampoline (eval-expr e env))) inits))) ((init-vals (map (fn (e) (trampoline (eval-expr e env))) inits)))
(cek-call loop-fn init-vals)))))) (cek-call loop-fn init-vals))))))
;; call/cc: capture entire kont as undelimited escape continuation ;; Pattern matching (match form)
(define (define
sf-lambda sf-lambda
(fn (fn
@@ -783,6 +790,7 @@
params-expr))) params-expr)))
(make-lambda param-names body env)))) (make-lambda param-names body env))))
;; Condition system special forms
(define (define
sf-defcomp sf-defcomp
(fn (fn
@@ -842,7 +850,6 @@
(range 2 end 1)) (range 2 end 1))
result))) result)))
;; Pattern matching (match form)
(define (define
parse-comp-params parse-comp-params
(fn (fn
@@ -889,7 +896,6 @@
params-expr) params-expr)
(list params has-children param-types)))) (list params has-children param-types))))
;; Condition system special forms
(define (define
sf-defisland sf-defisland
(fn (fn
@@ -1181,6 +1187,7 @@
state state
(cek-step-loop (cek-step state))))) (cek-step-loop (cek-step state)))))
;; Scope/provide/context — structured downward data passing
(define (define
cek-run cek-run
(fn (fn
@@ -1211,7 +1218,6 @@
(step-eval state) (step-eval state)
(step-continue state)))) (step-continue state))))
;; Scope/provide/context — structured downward data passing
(define (define
step-eval step-eval
(fn (fn
@@ -1268,6 +1274,18 @@
(step-eval-list expr env kont)) (step-eval-list expr env kont))
:else (make-cek-value 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 (define
step-sf-raise step-sf-raise
(fn (fn
@@ -1277,6 +1295,8 @@
env env
(kont-push (make-raise-eval-frame env false) kont)))) (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 (define
step-sf-guard step-sf-guard
(fn (fn
@@ -1350,6 +1370,8 @@
env env
kont)))) kont))))
;; Find which pattern variable in a template drives an ellipsis.
;; Returns the variable name (string) whose binding is a list, or nil.
(define (define
step-sf-callcc step-sf-callcc
(fn (fn
@@ -1359,18 +1381,8 @@
env env
(kont-push (make-callcc-frame env) kont)))) (kont-push (make-callcc-frame env) kont))))
;; ═══════════════════════════════════════════════════════════════ ;; Find ALL ellipsis-bound pattern variables in a template.
;; R7RS syntax-rules / define-syntax ;; Returns a list of variable name strings.
;;
;; 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 (define
step-sf-case step-sf-case
(fn (fn
@@ -1380,8 +1392,8 @@
env env
(kont-push (make-case-frame nil (rest args) env) kont)))) (kont-push (make-case-frame nil (rest args) env) kont))))
;; Match a list pattern against a form list, handling ellipsis at any position. ;; Instantiate a template with pattern variable bindings.
;; pi = pattern index, fi = form index. ;; Handles ellipsis repetition and recursive substitution.
(define (define
step-sf-let-match step-sf-let-match
(fn (fn
@@ -1395,8 +1407,9 @@
env env
kont)))) kont))))
;; Find which pattern variable in a template drives an ellipsis. ;; Walk a template list, handling ellipsis at any position.
;; Returns the variable name (string) whose binding is a list, or nil. ;; 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 (define
step-eval-list step-eval-list
(fn (fn
@@ -1509,6 +1522,7 @@
("peek" (step-sf-peek args env kont)) ("peek" (step-sf-peek args env kont))
("provide!" (step-sf-provide! args env kont)) ("provide!" (step-sf-provide! args env kont))
("context" (step-sf-context args env kont)) ("context" (step-sf-context args env kont))
("bind" (step-sf-bind args env kont))
("emit!" (step-sf-emit args env kont)) ("emit!" (step-sf-emit args env kont))
("emitted" (step-sf-emitted args env kont)) ("emitted" (step-sf-emitted args env kont))
("handler-bind" (step-sf-handler-bind args env kont)) ("handler-bind" (step-sf-handler-bind args env kont))
@@ -1563,8 +1577,51 @@
:else (step-eval-call head args env kont))))) :else (step-eval-call head args env kont)))))
(step-eval-call head args env kont)))))) (step-eval-call head args env kont))))))
;; Find ALL ellipsis-bound pattern variables in a template. ;; Try each syntax-rules clause against a form.
;; Returns a list of variable name strings. ;; 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 (define
step-sf-parameterize step-sf-parameterize
(fn (fn
@@ -1583,8 +1640,17 @@
(make-parameterize-frame bindings nil (list) body env) (make-parameterize-frame bindings nil (list) body env)
kont))))))) kont)))))))
;; Instantiate a template with pattern variable bindings. ;; R7RS records (SRFI-9)
;; Handles ellipsis repetition and recursive substitution. ;;
;; (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 (define
syntax-rules-match syntax-rules-match
(fn (fn
@@ -1605,9 +1671,7 @@
(syntax-rules-match-list pattern 0 form 0 literals) (syntax-rules-match-list pattern 0 form 0 literals)
:else (if (= pattern form) (dict) nil)))) :else (if (= pattern form) (dict) nil))))
;; Walk a template list, handling ellipsis at any position. ;; Delimited continuations
;; 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 (define
syntax-rules-match-list syntax-rules-match-list
(fn (fn
@@ -1690,10 +1754,6 @@
(keys sub-result)) (keys sub-result))
rest-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 (define
syntax-rules-find-var syntax-rules-find-var
(fn (fn
@@ -1713,6 +1773,7 @@
template) template)
:else nil))) :else nil)))
;; Signal dereferencing with reactive dependency tracking
(define (define
syntax-rules-find-all-vars syntax-rules-find-all-vars
(fn (fn
@@ -1730,10 +1791,13 @@
template) template)
:else (list)))) :else (list))))
;; Special form: (syntax-rules (literal ...) (pattern template) ...) ;; ═══════════════════════════════════════════════════════════════
;; Creates a Macro with rules/literals stored in closure env. ;; Part 8: Call Dispatch
;; Body is a marker symbol; expand-macro detects it and calls ;;
;; the pattern matcher directly. ;; 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 (define
syntax-rules-instantiate syntax-rules-instantiate
(fn (fn
@@ -1747,6 +1811,7 @@
template template
:else (syntax-rules-instantiate-list template 0 bindings)))) :else (syntax-rules-instantiate-list template 0 bindings))))
;; Reactive signal tracking — captures dependency continuation for re-render
(define (define
syntax-rules-instantiate-list syntax-rules-instantiate-list
(fn (fn
@@ -1796,17 +1861,6 @@
(syntax-rules-instantiate elem bindings) (syntax-rules-instantiate elem bindings)
(syntax-rules-instantiate-list template (+ i 1) 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 (define
syntax-rules-expand syntax-rules-expand
(fn (fn
@@ -1815,7 +1869,13 @@
((full-form (cons (make-symbol "_") form))) ((full-form (cons (make-symbol "_") form)))
(syntax-rules-try-rules literals rules full-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 (define
syntax-rules-try-rules syntax-rules-try-rules
(fn (fn
@@ -1853,7 +1913,6 @@
closure closure
"syntax-rules"))))) "syntax-rules")))))
;; Signal dereferencing with reactive dependency tracking
(define (define
step-sf-define-library step-sf-define-library
(fn (fn
@@ -1898,13 +1957,6 @@
(register-library lib-spec export-dict) (register-library lib-spec export-dict)
(make-cek-value nil env kont)))))) (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 (define
bind-import-set bind-import-set
(fn (fn
@@ -1936,7 +1988,6 @@
(fn (key) (env-bind! env key (get exports key))) (fn (key) (env-bind! env key (get exports key)))
(keys exports)))))))) (keys exports))))))))
;; Reactive signal tracking — captures dependency continuation for re-render
(define (define
step-sf-import step-sf-import
(fn (fn
@@ -1973,13 +2024,6 @@
env env
(kont-push (make-perform-frame env) kont))))) (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 *protocol-registry* (dict))
(define (define
@@ -2181,6 +2225,14 @@
(dict-set! impls type-name type-impls) (dict-set! impls type-name type-impls)
nil)))))) 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 (define
satisfies? satisfies?
(fn (fn
@@ -2195,6 +2247,9 @@
false false
(not (nil? (get (get proto "impls") (type-of value))))))))) (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 (define
check-match-exhaustiveness check-match-exhaustiveness
(fn (fn
@@ -2252,6 +2307,13 @@
(list local body) (list local body)
(match-find-clause val (rest clauses) env)))))) (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 (define
match-pattern match-pattern
(fn (fn
@@ -2337,14 +2399,6 @@
env env
(kont-push (make-handler-frame handlers (rest body) env) kont)))))) (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 (define
step-sf-restart-case step-sf-restart-case
(fn (fn
@@ -2369,9 +2423,6 @@
env env
(kont-push (make-restart-frame restarts (list) env) kont))))) (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 (define
step-sf-signal step-sf-signal
(fn (fn
@@ -2417,13 +2468,6 @@
(env-bind! restart-env (first params) restart-arg)) (env-bind! restart-env (first params) restart-arg))
(make-cek-state body restart-env rest-kont))))))) (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 (define
step-sf-if step-sf-if
(fn (fn
@@ -2679,9 +2723,10 @@
((name (trampoline (eval-expr (first args) env))) ((name (trampoline (eval-expr (first args) env)))
(val (trampoline (eval-expr (nth args 1) env))) (val (trampoline (eval-expr (nth args 1) env)))
(body (slice args 2))) (body (slice args 2)))
(scope-push! name val)
(if (if
(empty? body) (empty? body)
(make-cek-value nil env kont) (do (scope-pop! name) (make-cek-value nil env kont))
(make-cek-state (make-cek-state
(first body) (first body)
env env
@@ -2699,14 +2744,16 @@
(trampoline (eval-expr (nth args 1) env)) (trampoline (eval-expr (nth args 1) env))
nil)) nil))
(frame (kont-find-provide kont name))) (frame (kont-find-provide kont name)))
(when
(and frame *bind-tracking*)
(when
(not (contains? *bind-tracking* frame))
(append! *bind-tracking* frame)))
(make-cek-value (make-cek-value
(if (if
frame frame
(get frame "value") (get frame "value")
(if (let ((sv (scope-peek name))) (if (nil? sv) default-val sv)))
(env-has? env "context")
(apply (env-get env "context") (list name default-val))
default-val))
env env
kont)))) kont))))
@@ -2738,20 +2785,11 @@
(fn (fn
(args env kont) (args env kont)
(let (let
((name (trampoline (eval-expr (first args) env))) ((name (trampoline (eval-expr (first args) env))))
(new-val (trampoline (eval-expr (nth args 1) env))) (make-cek-state
(frame (kont-find-provide kont name))) (nth args 1)
(if env
frame (kont-push (make-provide-set-frame name env) kont)))))
(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))))))
(define (define
step-sf-emit step-sf-emit
@@ -3538,17 +3576,59 @@
(fenv (get frame "env"))) (fenv (get frame "env")))
(if (if
(empty? remaining) (empty? remaining)
(make-cek-value value fenv rest-k) (do
(make-cek-state (scope-pop! (get frame "name"))
(first remaining) (make-cek-value value fenv rest-k))
fenv (let
(kont-push ((new-frame (make-provide-frame (get frame "name") (get frame "value") (rest remaining) fenv)))
(make-provide-frame (dict-set!
(get frame "name") new-frame
(get frame "value") "subscribers"
(rest remaining) (get frame "subscribers"))
fenv) (make-cek-state
rest-k))))) (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" ("scope-acc"
(let (let
((remaining (get frame "remaining")) ((remaining (get frame "remaining"))

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

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