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

Step 10c: fix bind subscriber re-evaluation — track names not frames

Browse Source 
Root cause: context called inside lambdas (e.g. swap!) went through
nested cek_run with empty kont, so provide frames weren't found and
never tracked to *bind-tracking*.

Three changes in evaluator.sx:
- step-sf-context: track context names (not frames) to *bind-tracking*
  — names work across cek_run boundaries via scope-peek fallback
- bind continue: resolve tracked names to frames via kont-find-provide
  on rest-k before registering subscribers
- subscriber: use empty kont instead of kont-extract-provides — old
  approach created provide frames whose continue handlers called
  scope-pop!, corrupting the scope stack

2752/2768 OCaml tests pass (all 7 bind subscriber tests fixed).
32/32 WASM native tests pass.

Co-Authored-By: Claude Opus 4.6 (1M context) <noreply@anthropic.com>
This commit is contained in:
giles
2026-04-05 11:05:17 +00:00
parent a965731a33
commit 44b520a9e9
6 changed files with 5366 additions and 8054 deletions
Download Patch File Download Diff File Expand all files Collapse all files

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

File diff suppressed because one or more lines are too long

4949
shared/static/scripts/sx-browser.js
View File

File diff suppressed because one or more lines are too long

509
shared/static/wasm/sx/highlight.sx
View File

@@ -1,6 +1,7 @@
(define-library (sx highlight) (define-library
(sx highlight)
(export (export
sx-specials sx-specials
sx-special? sx-special?
@@ -16,204 +17,184 @@
highlight-sx highlight-sx
highlight) highlight)
(begin (begin
(define
(define sx-specials
sx-specials (list
(list "defcomp"
"defcomp" "defrelation"
"defrelation" "defisland"
"defisland" "defpage"
"defpage" "defhelper"
"defhelper" "define"
"define" "defmacro"
"defmacro" "defconfig"
"defconfig" "deftest"
"deftest" "if"
"if" "when"
"when" "cond"
"cond" "case"
"case" "and"
"and" "or"
"or" "not"
"not" "let"
"let" "let*"
"let*" "lambda"
"lambda" "fn"
"fn" "do"
"do" "begin"
"begin" "quote"
"quote" "quasiquote"
"quasiquote" "->"
"->" "map"
"map" "filter"
"filter" "reduce"
"reduce" "some"
"some" "every?"
"every?" "map-indexed"
"map-indexed" "for-each"
"for-each" "&key"
"&key" "&rest"
"&rest" "set!"
"set!")) "satisfies?"
"match"
(define sx-special? (fn (s) (some (fn (x) (= x s)) sx-specials))) "let-match"
"define-protocol"
(define hl-digit? (fn (c) (and (>= c "0") (<= c "9")))) "implement"
"->>"
(define "|>"
hl-alpha? "as->"
(fn (c) (or (and (>= c "a") (<= c "z")) (and (>= c "A") (<= c "Z"))))) "define-library"
"import"
(define "perform"
hl-sym-char? "guard"
(fn "call/cc"
(c) "raise"
(or "define-syntax"
(hl-alpha? c) "syntax-rules"
(hl-digit? c) "make-parameter"
(= c "_") "parameterize"))
(= c "-") (define sx-special? (fn (s) (some (fn (x) (= x s)) sx-specials)))
(= c "?") (define hl-digit? (fn (c) (and (>= c "0") (<= c "9"))))
(= c "!") (define
(= c "+") hl-alpha?
(= c "*") (fn
(= c "/") (c)
(= c "<") (or (and (>= c "a") (<= c "z")) (and (>= c "A") (<= c "Z")))))
(= c ">") (define
(= c "=") hl-sym-char?
(= c "&") (fn
(= c ".")))) (c)
(or
(define hl-ws? (fn (c) (or (= c " ") (= c "\n") (= c "\t") (= c "\r")))) (hl-alpha? c)
(hl-digit? c)
(define hl-escape (fn (s) s)) (= c "_")
(= c "-")
(define (= c "?")
hl-span (= c "!")
(fn (= c "+")
(class text) (= c "*")
(if (= c "/")
(= class "") (= c "<")
(list (quote span) text) (= c ">")
(list (quote span) (make-keyword "class") class text)))) (= c "=")
(= c "&")
(define (= c "."))))
tokenize-sx (define
(fn hl-ws?
(code) (fn (c) (or (= c " ") (= c "\n") (= c "\t") (= c "\r"))))
(let (define hl-escape (fn (s) s))
((tokens (list)) (i 0) (len (string-length code))) (define
(let hl-span
loop (fn
() (class text)
(when (if
(< i len) (= class "")
(list (quote span) text)
(list (quote span) (make-keyword "class") class text))))
(define
tokenize-sx
(fn
(code)
(let
((tokens (list)) (i 0) (len (string-length code)))
(let (let
((c (substring code i (+ i 1)))) loop
(if ()
(= c ";") (when
(< i len)
(let (let
((start i)) ((c (substring code i (+ i 1))))
(set! i (+ i 1))
(let
scan
()
(when
(and
(< i len)
(not (= (substring code i (+ i 1)) "\n")))
(set! i (+ i 1))
(scan)))
(set!
tokens
(append
tokens
(list (list "comment" (substring code start i))))))
(if
(= c "\"")
(let
((start i))
(set! i (+ i 1))
(let
sloop
()
(when
(< i len)
(let
((sc (substring code i (+ i 1))))
(if
(= sc "\\")
(do (set! i (+ i 2)) (sloop))
(if
(= sc "\"")
(set! i (+ i 1))
(do (set! i (+ i 1)) (sloop)))))))
(set!
tokens
(append
tokens
(list (list "string" (substring code start i))))))
(if (if
(= c ":") (= c ";")
(let (let
((start i)) ((start i))
(set! i (+ i 1)) (set! i (+ i 1))
(when (let
(and scan
(< i len) ()
(hl-alpha? (substring code i (+ i 1)))) (when
(let (and
scan (< i len)
() (not (= (substring code i (+ i 1)) "\n")))
(when (set! i (+ i 1))
(and (scan)))
(< i len)
(hl-sym-char? (substring code i (+ i 1))))
(set! i (+ i 1))
(scan))))
(set! (set!
tokens tokens
(append (append
tokens tokens
(list (list "keyword" (substring code start i)))))) (list (list "comment" (substring code start i))))))
(if (if
(= c "~") (= c "\"")
(let (let
((start i)) ((start i))
(set! i (+ i 1)) (set! i (+ i 1))
(let (let
scan sloop
() ()
(when (when
(and (< i len)
(< i len) (let
(let ((sc (substring code i (+ i 1))))
((x (substring code i (+ i 1)))) (if
(or (hl-sym-char? x) (= x "/")))) (= sc "\\")
(set! i (+ i 1)) (do (set! i (+ i 2)) (sloop))
(scan))) (if
(= sc "\"")
(set! i (+ i 1))
(do (set! i (+ i 1)) (sloop)))))))
(set! (set!
tokens tokens
(append (append
tokens tokens
(list (list "component" (substring code start i)))))) (list (list "string" (substring code start i))))))
(if (if
(or (= c ":")
(= c "(") (let
(= c ")") ((start i))
(= c "[") (set! i (+ i 1))
(= c "]") (when
(= c "{") (and
(= c "}")) (< i len)
(do (hl-alpha? (substring code i (+ i 1))))
(let
scan
()
(when
(and
(< i len)
(hl-sym-char? (substring code i (+ i 1))))
(set! i (+ i 1))
(scan))))
(set! (set!
tokens tokens
(append tokens (list (list "paren" c)))) (append
(set! i (+ i 1))) tokens
(list (list "keyword" (substring code start i))))))
(if (if
(hl-digit? c) (= c "~")
(let (let
((start i)) ((start i))
(set! i (+ i 1))
(let (let
scan scan
() ()
@@ -222,53 +203,30 @@
(< i len) (< i len)
(let (let
((x (substring code i (+ i 1)))) ((x (substring code i (+ i 1))))
(or (hl-digit? x) (= x ".")))) (or (hl-sym-char? x) (= x "/"))))
(set! i (+ i 1)) (set! i (+ i 1))
(scan))) (scan)))
(set! (set!
tokens tokens
(append (append
tokens tokens
(list (list "number" (substring code start i)))))) (list
(list "component" (substring code start i))))))
(if (if
(hl-sym-char? c) (or
(let (= c "(")
((start i)) (= c ")")
(let (= c "[")
scan (= c "]")
() (= c "{")
(when (= c "}"))
(and (do
(< i len) (set!
(hl-sym-char? (substring code i (+ i 1)))) tokens
(set! i (+ i 1)) (append tokens (list (list "paren" c))))
(scan))) (set! i (+ i 1)))
(let
((text (substring code start i)))
(if
(or
(= text "true")
(= text "false")
(= text "nil"))
(set!
tokens
(append
tokens
(list (list "boolean" text))))
(if
(sx-special? text)
(set!
tokens
(append
tokens
(list (list "special" text))))
(set!
tokens
(append
tokens
(list (list "symbol" text))))))))
(if (if
(hl-ws? c) (hl-digit? c)
(let (let
((start i)) ((start i))
(let (let
@@ -277,49 +235,106 @@
(when (when
(and (and
(< i len) (< i len)
(hl-ws? (substring code i (+ i 1)))) (let
((x (substring code i (+ i 1))))
(or (hl-digit? x) (= x "."))))
(set! i (+ i 1)) (set! i (+ i 1))
(scan))) (scan)))
(set! (set!
tokens tokens
(append (append
tokens tokens
(list (list "ws" (substring code start i)))))) (list
(do (list "number" (substring code start i))))))
(set! (if
tokens (hl-sym-char? c)
(append tokens (list (list "other" c)))) (let
(set! i (+ i 1)))))))))))) ((start i))
(loop))) (let
tokens))) scan
()
(define sx-token-classes {:boolean "text-orange-600" :component "text-rose-600 font-semibold" :number "text-amber-700" :string "text-emerald-700" :special "text-sky-700 font-semibold" :paren "text-stone-400" :keyword "text-violet-600" :comment "text-stone-400 italic"}) (when
(and
(define (< i len)
render-sx-tokens (hl-sym-char?
(fn (substring code i (+ i 1))))
(tokens) (set! i (+ i 1))
(map (scan)))
(let
((text (substring code start i)))
(if
(or
(= text "true")
(= text "false")
(= text "nil"))
(set!
tokens
(append
tokens
(list (list "boolean" text))))
(if
(sx-special? text)
(set!
tokens
(append
tokens
(list (list "special" text))))
(set!
tokens
(append
tokens
(list (list "symbol" text))))))))
(if
(hl-ws? c)
(let
((start i))
(let
scan
()
(when
(and
(< i len)
(hl-ws? (substring code i (+ i 1))))
(set! i (+ i 1))
(scan)))
(set!
tokens
(append
tokens
(list
(list "ws" (substring code start i))))))
(do
(set!
tokens
(append tokens (list (list "other" c))))
(set! i (+ i 1))))))))))))
(loop)))
tokens)))
(define sx-token-classes {:boolean "text-orange-600" :component "text-rose-600 font-semibold" :number "text-amber-700" :string "text-emerald-700" :special "text-sky-700 font-semibold" :paren "text-stone-400" :keyword "text-violet-600" :comment "text-stone-400 italic"})
(define
render-sx-tokens
(fn (fn
(tok) (tokens)
(let (map
((cls (or (dict-get sx-token-classes (first tok)) ""))) (fn
(hl-span cls (nth tok 1)))) (tok)
tokens))) (let
((cls (or (dict-get sx-token-classes (first tok)) "")))
(define highlight-sx (fn (code) (render-sx-tokens (tokenize-sx code)))) (hl-span cls (nth tok 1))))
tokens)))
(define (define highlight-sx (fn (code) (-> code tokenize-sx render-sx-tokens)))
highlight (define
(fn highlight
(code lang) (fn
(if (code lang)
(or (= lang "lisp") (= lang "sx") (= lang "sexp") (= lang "scheme")) (if
(highlight-sx code) (or
(list (quote code) code)))) (= lang "lisp")
(= lang "sx")
(= lang "sexp")
)) ;; end define-library (= lang "scheme"))
(highlight-sx code)
(list (quote code) code)))))) ;; end define-library
;; Re-export to global namespace for backward compatibility ;; Re-export to global namespace for backward compatibility
(import (sx highlight)) (import (sx highlight))

7932
shared/static/wasm/sx_browser.bc.js
View File

File diff suppressed because one or more lines are too long

2
shared/static/wasm/sx_browser.bc.wasm.js
View File

@@ -1792,7 +1792,7 @@
blake2_js_for_wasm_create: blake2_js_for_wasm_create}; blake2_js_for_wasm_create: blake2_js_for_wasm_create};
} }
(globalThis)) (globalThis))
({"link":[["runtime-0db9b496",0],["prelude-d7e4b000",0],["stdlib-23ce0836",[]],["sx-418217b8",[2]],["jsoo_runtime-f96b44a8",[2]],["js_of_ocaml-651f6707",[2,4]],["dune__exe__Sx_browser-0734e8ba",[2,3,5]],["std_exit-10fb8830",[2]],["start-f5d3f095",0]],"generated":(b=>{var ({"link":[["runtime-0db9b496",0],["prelude-d7e4b000",0],["stdlib-23ce0836",[]],["sx-b2cc3269",[2]],["jsoo_runtime-f96b44a8",[2]],["js_of_ocaml-651f6707",[2,4]],["dune__exe__Sx_browser-9b135b3a",[2,3,5]],["std_exit-10fb8830",[2]],["start-f5d3f095",0]],"generated":(b=>{var
c=b,a=b?.module?.export||b;return{"env":{"caml_ba_kind_of_typed_array":()=>{throw new c=b,a=b?.module?.export||b;return{"env":{"caml_ba_kind_of_typed_array":()=>{throw new
Error("caml_ba_kind_of_typed_array not implemented")},"caml_exn_with_js_backtrace":()=>{throw new Error("caml_ba_kind_of_typed_array not implemented")},"caml_exn_with_js_backtrace":()=>{throw new
Error("caml_exn_with_js_backtrace not implemented")},"caml_int64_create_lo_mi_hi":()=>{throw new Error("caml_exn_with_js_backtrace not implemented")},"caml_int64_create_lo_mi_hi":()=>{throw new

22
spec/evaluator.sx
View File

@@ -2745,10 +2745,10 @@
nil)) nil))
(frame (kont-find-provide kont name))) (frame (kont-find-provide kont name)))
(when (when
(and frame *bind-tracking*) *bind-tracking*
(when (when
(not (contains? *bind-tracking* frame)) (not (contains? *bind-tracking* name))
(append! *bind-tracking* frame))) (append! *bind-tracking* name)))
(make-cek-value (make-cek-value
(if (if
frame frame
@@ -3597,14 +3597,18 @@
(prev (get frame "prev-tracking"))) (prev (get frame "prev-tracking")))
(set! *bind-tracking* prev) (set! *bind-tracking* prev)
(let (let
((subscriber (fn (fire-kont) (let ((provide-kont (kont-extract-provides fire-kont))) (cek-run (make-cek-state body fenv provide-kont)))))) ((subscriber (fn (fire-kont) (cek-run (make-cek-state body fenv (list))))))
(for-each (for-each
(fn (fn
(pf) (name)
(dict-set! (let
pf ((pf (kont-find-provide rest-k name)))
"subscribers" (when
(append (get pf "subscribers") (list subscriber)))) pf
(dict-set!
pf
"subscribers"
(append (get pf "subscribers") (list subscriber))))))
tracked)) tracked))
(make-cek-value value fenv rest-k))) (make-cek-value value fenv rest-k)))
("provide-set" ("provide-set"