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

Merge eval.sx + frames.sx + cek.sx into single evaluator.sx

Browse Source 
The core spec is now one file: spec/evaluator.sx (2275 lines).
Three parts:
  Part 1: CEK frames — state and continuation frame constructors
  Part 2: Evaluation utilities — call, parse, define, macro, strict
  Part 3: CEK machine — the sole evaluator

Deleted:
- spec/eval.sx (merged into evaluator.sx)
- spec/frames.sx (merged into evaluator.sx)
- spec/cek.sx (merged into evaluator.sx)
- spec/continuations.sx (dead — CEK handles shift/reset natively)

Updated bootstrappers (JS + Python) to load evaluator.sx as core.
Removed frames/cek from SPEC_MODULES (now part of core).

Bundle size: 392KB → 377KB standard, 418KB → 403KB full.
All tests unchanged: JS 747/747, Full 864/870, Python 679/679.

Co-Authored-By: Claude Opus 4.6 (1M context) <noreply@anthropic.com>
This commit is contained in:
giles
2026-03-15 13:43:48 +00:00
parent b4df216fae
commit e475222099
9 changed files with 1894 additions and 2178 deletions
Download Patch File Download Diff File Expand all files Collapse all files

14
hosts/javascript/bootstrap.py
View File

@@ -112,16 +112,11 @@ def compile_ref_to_js(
spec_mod_set.add("deps")
if "page-helpers" in SPEC_MODULES:
spec_mod_set.add("page-helpers")
# CEK is the canonical evaluator — always included
spec_mod_set.add("cek")
spec_mod_set.add("frames")
# cek module requires frames
if "cek" in spec_mod_set:
spec_mod_set.add("frames")
# CEK is always included (part of evaluator.sx core file)
has_cek = True
has_deps = "deps" in spec_mod_set
has_router = "router" in spec_mod_set
has_page_helpers = "page-helpers" in spec_mod_set
has_cek = "cek" in spec_mod_set
# Resolve extensions
ext_set = set()
@@ -132,9 +127,10 @@ def compile_ref_to_js(
ext_set.add(e)
has_continuations = "continuations" in ext_set
# Build file list: core + adapters + spec modules
# Build file list: core evaluator + adapters + spec modules
# evaluator.sx = merged frames + eval utilities + CEK machine
sx_files = [
("eval.sx", "eval"),
("evaluator.sx", "evaluator (frames + eval + CEK)"),
("render.sx", "render (core)"),
]
for name in ("parser", "html", "sx", "dom", "engine", "orchestration", "boot"):

6
hosts/javascript/platform.py
View File

@@ -46,14 +46,12 @@ SPEC_MODULES = {
"router": ("router.sx", "router (client-side route matching)"),
"signals": ("signals.sx", "signals (reactive signal runtime)"),
"page-helpers": ("page-helpers.sx", "page-helpers (pure data transformation helpers)"),
"frames": ("frames.sx", "frames (CEK continuation frames)"),
"cek": ("cek.sx", "cek (explicit CEK machine evaluator)"),
"types": ("types.sx", "types (gradual type system)"),
}
# Note: frames and cek are now part of evaluator.sx (always loaded as core)
# Explicit ordering for spec modules with dependencies.
# Modules listed here are emitted in this order; any not listed use alphabetical.
SPEC_MODULE_ORDER = ["deps", "frames", "page-helpers", "router", "cek", "signals", "types"]
SPEC_MODULE_ORDER = ["deps", "page-helpers", "router", "signals", "types"]
EXTENSION_NAMES = {"continuations"}

9
hosts/python/bootstrap.py
View File

@@ -1484,15 +1484,14 @@ def compile_ref_to_py(
spec_mod_set.add("page-helpers")
if "router" in SPEC_MODULES:
spec_mod_set.add("router")
# CEK is the canonical evaluator — always include
spec_mod_set.add("cek")
spec_mod_set.add("frames")
# CEK is always included (part of evaluator.sx core file)
has_cek = True
has_deps = "deps" in spec_mod_set
has_cek = "cek" in spec_mod_set
# Core files always included, then selected adapters, then spec modules
# evaluator.sx = merged frames + eval utilities + CEK machine
sx_files = [
("eval.sx", "eval"),
("evaluator.sx", "evaluator (frames + eval + CEK)"),
("forms.sx", "forms (server definition forms)"),
("render.sx", "render (core)"),
]

6
hosts/python/platform.py
View File

@@ -1636,14 +1636,12 @@ SPEC_MODULES = {
"signals": ("signals.sx", "signals (reactive signal runtime)"),
"page-helpers": ("page-helpers.sx", "page-helpers (pure data transformation helpers)"),
"types": ("types.sx", "types (gradual type system)"),
"frames": ("frames.sx", "frames (CEK continuation frames)"),
"cek": ("cek.sx", "cek (explicit CEK machine evaluator)"),
}
# Note: frames and cek are now part of evaluator.sx (always loaded as core)
# Explicit ordering for spec modules with dependencies.
# Modules listed here are emitted in this order; any not listed use alphabetical.
SPEC_MODULE_ORDER = [
"deps", "engine", "frames", "page-helpers", "router", "cek", "signals", "types",
"deps", "engine", "page-helpers", "router", "signals", "types",
]
EXTENSION_NAMES = {"continuations"}

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

File diff suppressed because it is too large Load Diff

248
spec/continuations.sx
View File

@@ -1,248 +0,0 @@
;; ==========================================================================
;; continuations.sx — Delimited continuations (shift/reset)
;;
;; OPTIONAL EXTENSION — not required by the core evaluator.
;; Bootstrappers include this only when the target requests it.
;;
;; Delimited continuations capture "the rest of the computation up to
;; a delimiter." They are strictly less powerful than full call/cc but
;; cover the practical use cases: suspendable rendering, cooperative
;; scheduling, linear async flows, wizard forms, and undo.
;;
;; Two new special forms:
;; (reset body) — establish a delimiter
;; (shift k body) — capture the continuation to the nearest reset
;;
;; One new type:
;; continuation — a captured delimited continuation, callable
;;
;; The captured continuation is a function of one argument. Invoking it
;; provides the value that the shift expression "returns" within the
;; delimited context, then completes the rest of the reset body.
;;
;; Continuations are composable — invoking a continuation returns a
;; value (the result of the reset body), which can be used normally.
;; This is the key difference from undelimited call/cc, where invoking
;; a continuation never returns.
;;
;; Platform requirements:
;; (make-continuation fn) — wrap a function as a continuation value
;; (continuation? x) — type predicate
;; (type-of continuation) → "continuation"
;; Continuations are callable (same dispatch as lambda).
;; ==========================================================================
;; --------------------------------------------------------------------------
;; 1. Type
;; --------------------------------------------------------------------------
;;
;; A continuation is a callable value of one argument.
;;
;; (continuation? k) → true if k is a captured continuation
;; (type-of k) → "continuation"
;; (k value) → invoke: resume the captured computation with value
;;
;; Continuations are first-class: they can be stored in variables, passed
;; as arguments, returned from functions, and put in data structures.
;;
;; Invoking a delimited continuation RETURNS a value — the result of the
;; reset body. This makes them composable:
;;
;; (+ 1 (reset (+ 10 (shift k (k 5)))))
;; ;; k is "add 10 to _ and return from reset"
;; ;; (k 5) → 15, which is returned from reset
;; ;; (+ 1 15) → 16
;;
;; --------------------------------------------------------------------------
;; --------------------------------------------------------------------------
;; 2. reset — establish a continuation delimiter
;; --------------------------------------------------------------------------
;;
;; (reset body)
;;
;; Evaluates body in the current environment. If no shift occurs during
;; evaluation of body, reset simply returns the value of body.
;;
;; If shift occurs, reset is the boundary — the continuation captured by
;; shift extends from the shift point back to (and including) this reset.
;;
;; reset is the "prompt" — it marks where the continuation stops.
;;
;; Semantics:
;; (reset expr) where expr contains no shift
;; → (eval expr env) ;; just evaluates normally
;;
;; (reset ... (shift k body) ...)
;; → captures continuation, evaluates shift's body
;; → the result of the shift body is the result of the reset
;;
;; --------------------------------------------------------------------------
(define sf-reset
(fn ((args :as list) (env :as dict))
;; Single argument: the body expression.
;; Install a continuation delimiter, then evaluate body.
;; The implementation is target-specific:
;; - In Scheme: native reset/shift
;; - In Haskell: Control.Monad.CC or delimited continuations library
;; - In Python: coroutine/generator-based (see implementation notes)
;; - In JavaScript: generator-based or CPS transform
;; - In Rust: CPS transform at compile time
(let ((body (first args)))
(eval-with-delimiter body env))))
;; --------------------------------------------------------------------------
;; 3. shift — capture the continuation to the nearest reset
;; --------------------------------------------------------------------------
;;
;; (shift k body)
;;
;; Captures the continuation from this point back to the nearest enclosing
;; reset and binds it to k. Then evaluates body in the current environment
;; extended with k. The result of body becomes the result of the enclosing
;; reset.
;;
;; k is a function of one argument. Calling (k value) resumes the captured
;; computation with value standing in for the shift expression.
;;
;; The continuation k is composable: (k value) returns a value (the result
;; of the reset body when resumed with value). This means k can be called
;; multiple times, and its result can be used in further computation.
;;
;; Examples:
;;
;; ;; Basic: shift provides a value to the surrounding computation
;; (reset (+ 1 (shift k (k 41))))
;; ;; k = "add 1 to _", (k 41) → 42, reset returns 42
;;
;; ;; Abort: shift can discard the continuation entirely
;; (reset (+ 1 (shift k "aborted")))
;; ;; k is never called, reset returns "aborted"
;;
;; ;; Multiple invocations: k can be called more than once
;; (reset (+ 1 (shift k (list (k 10) (k 20)))))
;; ;; (k 10) → 11, (k 20) → 21, reset returns (11 21)
;;
;; ;; Stored for later: k can be saved and invoked outside reset
;; (define saved nil)
;; (reset (+ 1 (shift k (set! saved k) 0)))
;; ;; reset returns 0, saved holds the continuation
;; (saved 99) ;; → 100
;;
;; --------------------------------------------------------------------------
(define sf-shift
(fn ((args :as list) (env :as dict))
;; Two arguments: the continuation variable name, and the body.
(let ((k-name (symbol-name (first args)))
(body (second args)))
;; Capture the current continuation up to the nearest reset.
;; Bind it to k-name in the environment, then evaluate body.
;; The result of body is returned to the reset.
(capture-continuation k-name body env))))
;; --------------------------------------------------------------------------
;; 4. Interaction with other features
;; --------------------------------------------------------------------------
;;
;; TCO (trampoline):
;; Continuations interact naturally with the trampoline. A shift inside
;; a tail-call position captures the continuation including the pending
;; return. The trampoline resolves thunks before the continuation is
;; delimited.
;;
;; Macros:
;; shift/reset are special forms, not macros. Macros expand before
;; evaluation, so shift inside a macro-expanded form works correctly —
;; it captures the continuation of the expanded code.
;;
;; Components:
;; shift inside a component body captures the continuation of that
;; component's render. The enclosing reset determines the delimiter.
;; This is the foundation for suspendable rendering — a component can
;; shift to suspend, and the server resumes it when data arrives.
;;
;; I/O primitives:
;; I/O primitives execute at invocation time, in whatever context
;; exists then. A continuation that captures a computation containing
;; I/O will re-execute that I/O when invoked. If the I/O requires
;; request context (e.g. current-user), invoking the continuation
;; outside a request will fail — same as calling the I/O directly.
;; This is consistent, not a restriction.
;;
;; In typed targets (Haskell, Rust), the type system can enforce that
;; continuations containing I/O are only invoked in appropriate contexts.
;; In dynamic targets (Python, JS), it fails at runtime.
;;
;; Lexical scope:
;; Continuations capture the dynamic extent (what happens next) but
;; close over the lexical environment at the point of capture. Variable
;; bindings in the continuation refer to the same environment — mutations
;; via set! are visible.
;;
;; --------------------------------------------------------------------------
;; --------------------------------------------------------------------------
;; 5. Implementation notes per target
;; --------------------------------------------------------------------------
;;
;; The bootstrapper emits target-specific continuation machinery.
;; The spec defines semantics; each target chooses representation.
;;
;; Scheme / Racket:
;; Native shift/reset. No transformation needed. The bootstrapper
;; emits (require racket/control) or equivalent.
;;
;; Haskell:
;; Control.Monad.CC provides delimited continuations in the CC monad.
;; Alternatively, the evaluator can be CPS-transformed at compile time.
;; Continuations become first-class functions naturally.
;;
;; Python:
;; Generator-based: reset creates a generator, shift yields from it.
;; The trampoline loop drives the generator. Each yield is a shift
;; point, and send() provides the resume value.
;; Alternative: greenlet-based (stackful coroutines).
;;
;; JavaScript:
;; Generator-based (function* / yield). Similar to Python.
;; Alternative: CPS transform at bootstrap time — the bootstrapper
;; rewrites the evaluator into continuation-passing style, making
;; shift/reset explicit function arguments.
;;
;; Rust:
;; CPS transform at compile time. Continuations become enum variants
;; or boxed closures. The type system ensures continuations are used
;; linearly if desired (affine types via ownership).
;;
;; --------------------------------------------------------------------------
;; --------------------------------------------------------------------------
;; 6. Platform interface — what each target must provide
;; --------------------------------------------------------------------------
;;
;; (eval-with-delimiter expr env)
;; Install a reset delimiter, evaluate expr, return result.
;; If expr calls shift, the continuation is captured up to here.
;;
;; (capture-continuation k-name body env)
;; Capture the current continuation up to the nearest delimiter.
;; Bind it to k-name in env, evaluate body, return result to delimiter.
;;
;; (make-continuation fn)
;; Wrap a native function as a continuation value.
;;
;; (continuation? x)
;; Type predicate.
;;
;; Continuations must be callable via the standard function-call
;; dispatch in eval-list (same path as lambda calls).
;;
;; --------------------------------------------------------------------------

846
spec/eval.sx
View File

@@ -1,846 +0,0 @@
;; ==========================================================================
;; eval.sx — Reference SX evaluator written in SX
;;
;; This is the canonical specification of SX evaluation semantics.
;; A thin bootstrap compiler per target reads this file and emits
;; a native evaluator (JavaScript, Python, Rust, etc.).
;;
;; The evaluator is written in a restricted subset of SX:
;; - defcomp, define, defmacro, lambda/fn
;; - if, when, cond, case, let, do, and, or
;; - map, filter, reduce, some, every?
;; - Primitives: list ops, string ops, arithmetic, predicates
;; - quote, quasiquote/unquote/splice-unquote
;; - Pattern matching via (case (type-of expr) ...)
;;
;; Platform-specific concerns (DOM rendering, async I/O, HTML emission)
;; are declared as interfaces — each target provides its own adapter.
;; ==========================================================================
;; --------------------------------------------------------------------------
;; 1. Types
;; --------------------------------------------------------------------------
;;
;; The evaluator operates on these value types:
;;
;; number — integer or float
;; string — double-quoted text
;; boolean — true / false
;; nil — singleton null
;; symbol — unquoted identifier (e.g. div, ~card, map)
;; keyword — colon-prefixed key (e.g. :class, :id)
;; list — ordered sequence (also used as code)
;; dict — string-keyed hash map
;; lambda — closure: {params, body, closure-env, name?}
;; macro — AST transformer: {params, rest-param, body, closure-env}
;; component — UI component: {name, params, has-children, body, closure-env}
;; island — reactive component: like component but with island flag
;; thunk — deferred eval for TCO: {expr, env}
;;
;; Each target must provide:
;; (type-of x) → one of the strings above
;; (make-lambda ...) → platform Lambda value
;; (make-component ..) → platform Component value
;; (make-island ...) → platform Island value (component + island flag)
;; (make-macro ...) → platform Macro value
;; (make-thunk ...) → platform Thunk value
;;
;; These are declared in platform.sx and implemented per target.
;; --------------------------------------------------------------------------
;; --------------------------------------------------------------------------
;; 2. Trampoline — tail-call optimization
;; --------------------------------------------------------------------------
(define trampoline
(fn ((val :as any))
;; Iteratively resolve thunks until we get an actual value.
;; Each target implements thunk? and thunk-expr/thunk-env.
(let ((result val))
(do
;; Loop while result is a thunk
;; Note: this is pseudo-iteration — bootstrap compilers convert
;; this tail-recursive form to a while loop.
(if (thunk? result)
(trampoline (eval-expr (thunk-expr result) (thunk-env result)))
result)))))
;; --------------------------------------------------------------------------
;; 2b. Strict mode — runtime type checking for primitive calls
;; --------------------------------------------------------------------------
;;
;; When *strict* is true, primitive calls check arg types before dispatch.
;; The primitive param type registry maps name → {positional [[name type]...],
;; rest-type type-or-nil}. Stored in *prim-param-types* in the env.
;;
;; Strict mode is off by default. Hosts can enable it at startup via:
;; (set-strict! true)
;; (set-prim-param-types! types-dict)
(define *strict* false)
(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)))
(define value-matches-type?
(fn (val expected-type)
;; Check if a runtime value matches a declared type string.
(cond
(= expected-type "any") true
(= expected-type "number") (number? val)
(= expected-type "string") (string? val)
(= expected-type "boolean") (boolean? val)
(= expected-type "nil") (nil? val)
(= expected-type "list") (list? val)
(= expected-type "dict") (dict? val)
(= expected-type "lambda") (lambda? val)
(= expected-type "symbol") (= (type-of val) "symbol")
(= expected-type "keyword") (= (type-of val) "keyword")
;; Nullable: "string?" means string or nil
(and (string? expected-type)
(ends-with? expected-type "?"))
(or (nil? val)
(value-matches-type? val (slice expected-type 0 (- (string-length expected-type) 1))))
:else true)))
(define strict-check-args
(fn (name args)
;; Check args against *prim-param-types* if strict mode is on.
;; Throws on type violation. No-op if *strict* is false or types not registered.
(when (and *strict* *prim-param-types*)
(let ((spec (get *prim-param-types* name)))
(when spec
(let ((positional (get spec "positional"))
(rest-type (get spec "rest-type")))
;; Check positional params
(when positional
(for-each
(fn (pair)
(let ((idx (first pair))
(param (nth pair 1))
(p-name (first param))
(p-type (nth param 1)))
(when (< idx (len args))
(let ((val (nth args idx)))
(when (not (value-matches-type? val p-type))
(error (str "Type error: " name " expected " p-type
" for param " p-name
", got " (type-of val) " (" (str val) ")")))))))
(map-indexed (fn (i p) (list i p)) positional)))
;; Check rest args
(when (and rest-type (> (len args) (len (or positional (list)))))
(for-each
(fn (pair)
(let ((idx (first pair))
(val (nth pair 1)))
(when (not (value-matches-type? val rest-type))
(error (str "Type error: " name " expected " rest-type
" for rest arg " idx
", got " (type-of val) " (" (str val) ")")))))
(map-indexed (fn (i v) (list i v))
(slice args (len (or positional (list)))))))))))))
;; --------------------------------------------------------------------------
;; 3. Core evaluator — stub (overridden by CEK in fixups)
;; --------------------------------------------------------------------------
;;
;; eval-expr and trampoline are defined as stubs here so the transpiler
;; creates the variable declarations. The CEK fixups override them with:
;; eval-expr = (expr, env) → cek-run(make-cek-state(expr, env, []))
;; trampoline = (val) → if thunk? then eval-expr(thunk-expr, thunk-env) else val
;; All evaluation goes through the CEK machine.
(define eval-expr
(fn (expr (env :as dict))
;; Stub — overridden by CEK fixup before any code runs.
;; If this executes, CEK fixup failed to load.
(error "eval-expr: CEK fixup not loaded")))
;; [REMOVED] Section 4: Tree-walk eval-list dispatch table — superseded by CEK step-eval-list
;; --------------------------------------------------------------------------
;; 5. Function / lambda / component call
;; --------------------------------------------------------------------------
;; [REMOVED] eval-call — superseded by CEK continue-with-call
(define call-lambda
(fn ((f :as lambda) (args :as list) (caller-env :as dict))
(let ((params (lambda-params f))
(local (env-merge (lambda-closure f) caller-env)))
;; Too many args is an error; too few pads with nil
(if (> (len args) (len params))
(error (str (or (lambda-name f) "lambda")
" expects " (len params) " args, got " (len args)))
(do
;; Bind params — provided args first, then nil for missing
(for-each
(fn (pair) (env-bind! local (first pair) (nth pair 1)))
(zip params args))
(for-each
(fn (p) (env-bind! local p nil))
(slice params (len args)))
;; Return thunk for TCO
(make-thunk (lambda-body f) local))))))
(define call-component
(fn ((comp :as component) (raw-args :as list) (env :as dict))
;; Parse keyword args and children from unevaluated arg list
(let ((parsed (parse-keyword-args raw-args env))
(kwargs (first parsed))
(children (nth parsed 1))
(local (env-merge (component-closure comp) env)))
;; Bind keyword params
(for-each
(fn (p) (env-bind! local p (or (dict-get kwargs p) nil)))
(component-params comp))
;; Bind children if component accepts them
(when (component-has-children? comp)
(env-bind! local "children" children))
;; Return thunk — body evaluated in local env
(make-thunk (component-body comp) local))))
(define parse-keyword-args
(fn ((raw-args :as list) (env :as dict))
;; Walk args: keyword + next-val → kwargs dict, else → children list
(let ((kwargs (dict))
(children (list))
(i 0))
;; Iterative parse — bootstrap converts to while loop
(reduce
(fn (state arg)
(let ((idx (get state "i"))
(skip (get state "skip")))
(if skip
;; This arg was consumed as a keyword value
(assoc state "skip" false "i" (inc idx))
(if (and (= (type-of arg) "keyword")
(< (inc idx) (len raw-args)))
;; Keyword: evaluate next arg and store
(do
(dict-set! kwargs (keyword-name arg)
(trampoline (eval-expr (nth raw-args (inc idx)) env)))
(assoc state "skip" true "i" (inc idx)))
;; Positional: evaluate and add to children
(do
(append! children (trampoline (eval-expr arg env)))
(assoc state "i" (inc idx)))))))
(dict "i" 0 "skip" false)
raw-args)
(list kwargs children))))
;; --------------------------------------------------------------------------
;; 6. Special forms
;; --------------------------------------------------------------------------
;; [REMOVED] sf-if, sf-when, sf-cond, sf-case, sf-and, sf-or, sf-let
;; — all superseded by CEK step handlers in cek.sx
;; cond-scheme? — still needed by CEK's step-sf-cond
(define cond-scheme?
(fn ((clauses :as list))
(every? (fn (c) (and (= (type-of c) "list") (= (len c) 2)))
clauses)))
;; Named let: (let name ((x 0) (y 1)) body...)
;; Desugars to a self-recursive lambda called with initial values.
;; The loop name is bound in the body so recursive calls produce TCO thunks.
(define sf-named-let
(fn ((args :as list) (env :as dict))
(let ((loop-name (symbol-name (first args)))
(bindings (nth args 1))
(body (slice args 2))
(params (list))
(inits (list)))
;; Extract param names and init expressions
(if (and (= (type-of (first bindings)) "list")
(= (len (first bindings)) 2))
;; Scheme-style: ((x 0) (y 1))
(for-each
(fn (binding)
(append! params (if (= (type-of (first binding)) "symbol")
(symbol-name (first binding))
(first binding)))
(append! inits (nth binding 1)))
bindings)
;; Clojure-style: (x 0 y 1)
(reduce
(fn (acc pair-idx)
(do
(append! params (if (= (type-of (nth bindings (* pair-idx 2))) "symbol")
(symbol-name (nth bindings (* pair-idx 2)))
(nth bindings (* pair-idx 2))))
(append! inits (nth bindings (inc (* pair-idx 2))))))
nil
(range 0 (/ (len bindings) 2))))
;; Build loop body (wrap in begin if multiple exprs)
(let ((loop-body (if (= (len body) 1) (first body)
(cons (make-symbol "begin") body)))
(loop-fn (make-lambda params loop-body env)))
;; Self-reference: loop can call itself by name
(set-lambda-name! loop-fn loop-name)
(env-bind! (lambda-closure loop-fn) loop-name loop-fn)
;; Evaluate initial values in enclosing env, then call
(let ((init-vals (map (fn (e) (trampoline (eval-expr e env))) inits)))
(call-lambda loop-fn init-vals env))))))
(define sf-lambda
(fn ((args :as list) (env :as dict))
(let ((params-expr (first args))
(body-exprs (rest args))
(body (if (= (len body-exprs) 1)
(first body-exprs)
(cons (make-symbol "begin") body-exprs)))
(param-names (map (fn (p)
(cond
(= (type-of p) "symbol")
(symbol-name p)
;; Annotated param: (name :as type) → extract name
(and (= (type-of p) "list")
(= (len p) 3)
(= (type-of (nth p 1)) "keyword")
(= (keyword-name (nth p 1)) "as"))
(symbol-name (first p))
:else p))
params-expr)))
(make-lambda param-names body env))))
(define sf-defcomp
(fn ((args :as list) (env :as dict))
;; (defcomp ~name (params) [:affinity :client|:server] body)
;; Body is always the last element. Optional keyword annotations
;; may appear between the params list and the body.
(let ((name-sym (first args))
(params-raw (nth args 1))
(body (last args))
(comp-name (strip-prefix (symbol-name name-sym) "~"))
(parsed (parse-comp-params params-raw))
(params (first parsed))
(has-children (nth parsed 1))
(param-types (nth parsed 2))
(affinity (defcomp-kwarg args "affinity" "auto")))
(let ((comp (make-component comp-name params has-children body env affinity))
(effects (defcomp-kwarg args "effects" nil)))
;; Store type annotations if any were declared
(when (and (not (nil? param-types))
(not (empty? (keys param-types))))
(component-set-param-types! comp param-types))
;; Store effect annotation if declared
(when (not (nil? effects))
(let ((effect-list (if (= (type-of effects) "list")
(map (fn (e) (if (= (type-of e) "symbol")
(symbol-name e) (str e)))
effects)
(list (str effects))))
(effect-anns (if (env-has? env "*effect-annotations*")
(env-get env "*effect-annotations*")
(dict))))
(dict-set! effect-anns (symbol-name name-sym) effect-list)
(env-bind! env "*effect-annotations*" effect-anns)))
(env-bind! env (symbol-name name-sym) comp)
comp))))
(define defcomp-kwarg
(fn ((args :as list) (key :as string) default)
;; Search for :key value between params (index 2) and body (last).
(let ((end (- (len args) 1))
(result default))
(for-each
(fn (i)
(when (and (= (type-of (nth args i)) "keyword")
(= (keyword-name (nth args i)) key)
(< (+ i 1) end))
(let ((val (nth args (+ i 1))))
(set! result (if (= (type-of val) "keyword")
(keyword-name val) val)))))
(range 2 end 1))
result)))
(define parse-comp-params
(fn ((params-expr :as list))
;; Parse (&key param1 param2 &children) → (params has-children param-types)
;; Also accepts &rest as synonym for &children.
;; Supports typed params: (name :as type) — a 3-element list where
;; the second element is the keyword :as. Unannotated params get no
;; type entry. param-types is a dict {name → type-expr} or empty dict.
(let ((params (list))
(param-types (dict))
(has-children false)
(in-key false))
(for-each
(fn (p)
(if (and (= (type-of p) "list")
(= (len p) 3)
(= (type-of (first p)) "symbol")
(= (type-of (nth p 1)) "keyword")
(= (keyword-name (nth p 1)) "as"))
;; Typed param: (name :as type)
(let ((name (symbol-name (first p)))
(ptype (nth p 2)))
;; Convert type to string if it's a symbol
(let ((type-val (if (= (type-of ptype) "symbol")
(symbol-name ptype)
ptype)))
(when (not has-children)
(append! params name)
(dict-set! param-types name type-val))))
;; Untyped param or marker
(when (= (type-of p) "symbol")
(let ((name (symbol-name p)))
(cond
(= name "&key") (set! in-key true)
(= name "&rest") (set! has-children true)
(= name "&children") (set! has-children true)
has-children nil ;; skip params after &children/&rest
in-key (append! params name)
:else (append! params name))))))
params-expr)
(list params has-children param-types))))
(define sf-defisland
(fn ((args :as list) (env :as dict))
;; (defisland ~name (params) body)
;; Like defcomp but creates an island (reactive component).
;; Islands have the same calling convention as components but
;; render with a reactive context on the client.
(let ((name-sym (first args))
(params-raw (nth args 1))
(body (last args))
(comp-name (strip-prefix (symbol-name name-sym) "~"))
(parsed (parse-comp-params params-raw))
(params (first parsed))
(has-children (nth parsed 1)))
(let ((island (make-island comp-name params has-children body env)))
(env-bind! env (symbol-name name-sym) island)
island))))
(define sf-defmacro
(fn ((args :as list) (env :as dict))
(let ((name-sym (first args))
(params-raw (nth args 1))
(body (nth args 2))
(parsed (parse-macro-params params-raw))
(params (first parsed))
(rest-param (nth parsed 1)))
(let ((mac (make-macro params rest-param body env (symbol-name name-sym))))
(env-bind! env (symbol-name name-sym) mac)
mac))))
(define parse-macro-params
(fn ((params-expr :as list))
;; Parse (a b &rest rest) → ((a b) rest)
(let ((params (list))
(rest-param nil))
(reduce
(fn (state p)
(if (and (= (type-of p) "symbol") (= (symbol-name p) "&rest"))
(assoc state "in-rest" true)
(if (get state "in-rest")
(do (set! rest-param (if (= (type-of p) "symbol")
(symbol-name p) p))
state)
(do (append! params (if (= (type-of p) "symbol")
(symbol-name p) p))
state))))
(dict "in-rest" false)
params-expr)
(list params rest-param))))
(define sf-defstyle
(fn ((args :as list) (env :as dict))
;; (defstyle name expr) — bind name to evaluated expr (string, function, etc.)
(let ((name-sym (first args))
(value (trampoline (eval-expr (nth args 1) env))))
(env-bind! env (symbol-name name-sym) value)
value)))
;; -- deftype helpers (must be in eval.sx, not types.sx, because
;; sf-deftype is always compiled but types.sx is a spec module) --
(define make-type-def
(fn ((name :as string) (params :as list) body)
{:name name :params params :body body}))
(define normalize-type-body
(fn (body)
;; Convert AST type expressions to type representation.
;; Symbols → strings, (union ...) → (or ...), dict keys → strings.
(cond
(nil? body) "nil"
(= (type-of body) "symbol")
(symbol-name body)
(= (type-of body) "string")
body
(= (type-of body) "keyword")
(keyword-name body)
(= (type-of body) "dict")
;; Record type — normalize values
(map-dict (fn (k v) (normalize-type-body v)) body)
(= (type-of body) "list")
(if (empty? body) "any"
(let ((head (first body)))
(let ((head-name (if (= (type-of head) "symbol")
(symbol-name head) (str head))))
;; (union a b) → (or a b)
(if (= head-name "union")
(cons "or" (map normalize-type-body (rest body)))
;; (or a b), (list-of t), (-> ...) etc.
(cons head-name (map normalize-type-body (rest body)))))))
:else (str body))))
(define sf-deftype
(fn ((args :as list) (env :as dict))
;; (deftype name body) or (deftype (name a b ...) body)
(let ((name-or-form (first args))
(body-expr (nth args 1))
(type-name nil)
(type-params (list)))
;; Parse name — symbol or (symbol params...)
(if (= (type-of name-or-form) "symbol")
(set! type-name (symbol-name name-or-form))
(when (= (type-of name-or-form) "list")
(set! type-name (symbol-name (first name-or-form)))
(set! type-params
(map (fn (p) (if (= (type-of p) "symbol")
(symbol-name p) (str p)))
(rest name-or-form)))))
;; Normalize and store in *type-registry*
(let ((body (normalize-type-body body-expr))
(registry (if (env-has? env "*type-registry*")
(env-get env "*type-registry*")
(dict))))
(dict-set! registry type-name
(make-type-def type-name type-params body))
(env-bind! env "*type-registry*" registry)
nil))))
(define sf-defeffect
(fn ((args :as list) (env :as dict))
;; (defeffect name) — register an effect name
(let ((effect-name (if (= (type-of (first args)) "symbol")
(symbol-name (first args))
(str (first args))))
(registry (if (env-has? env "*effect-registry*")
(env-get env "*effect-registry*")
(list))))
(when (not (contains? registry effect-name))
(append! registry effect-name))
(env-bind! env "*effect-registry*" registry)
nil)))
(define qq-expand
(fn (template (env :as dict))
(if (not (= (type-of template) "list"))
template
(if (empty? template)
(list)
(let ((head (first template)))
(if (and (= (type-of head) "symbol") (= (symbol-name head) "unquote"))
(trampoline (eval-expr (nth template 1) env))
;; Walk children, handling splice-unquote
(reduce
(fn (result item)
(if (and (= (type-of item) "list")
(= (len item) 2)
(= (type-of (first item)) "symbol")
(= (symbol-name (first item)) "splice-unquote"))
(let ((spliced (trampoline (eval-expr (nth item 1) env))))
(if (= (type-of spliced) "list")
(concat result spliced)
(if (nil? spliced) result (concat result (list spliced)))))
(concat result (list (qq-expand item env)))))
(list)
template)))))))
;; --------------------------------------------------------------------------
;; 6c. letrec — mutually recursive local bindings
;; --------------------------------------------------------------------------
;;
;; (letrec ((even? (fn (n) (if (= n 0) true (odd? (- n 1)))))
;; (odd? (fn (n) (if (= n 0) false (even? (- n 1))))))
;; (even? 10))
;;
;; All bindings are first set to nil in the local env, then all values
;; are evaluated (so they can see each other's names), then lambda
;; closures are patched to include the final bindings.
;; --------------------------------------------------------------------------
(define sf-letrec
(fn ((args :as list) (env :as dict))
(let ((bindings (first args))
(body (rest args))
(local (env-extend env))
(names (list))
(val-exprs (list)))
;; First pass: bind all names to nil
(if (and (= (type-of (first bindings)) "list")
(= (len (first bindings)) 2))
;; Scheme-style
(for-each
(fn (binding)
(let ((vname (if (= (type-of (first binding)) "symbol")
(symbol-name (first binding))
(first binding))))
(append! names vname)
(append! val-exprs (nth binding 1))
(env-bind! local vname nil)))
bindings)
;; Clojure-style
(reduce
(fn (acc pair-idx)
(let ((vname (if (= (type-of (nth bindings (* pair-idx 2))) "symbol")
(symbol-name (nth bindings (* pair-idx 2)))
(nth bindings (* pair-idx 2))))
(val-expr (nth bindings (inc (* pair-idx 2)))))
(append! names vname)
(append! val-exprs val-expr)
(env-bind! local vname nil)))
nil
(range 0 (/ (len bindings) 2))))
;; Second pass: evaluate values (they can see each other's names)
(let ((values (map (fn (e) (trampoline (eval-expr e local))) val-exprs)))
;; Bind final values
(for-each
(fn (pair) (env-bind! local (first pair) (nth pair 1)))
(zip names values))
;; Patch lambda closures so they see the final bindings
(for-each
(fn (val)
(when (lambda? val)
(for-each
(fn (n) (env-bind! (lambda-closure val) n (env-get local n)))
names)))
values))
;; Evaluate body
(for-each
(fn (e) (trampoline (eval-expr e local)))
(slice body 0 (dec (len body))))
(make-thunk (last body) local))))
;; --------------------------------------------------------------------------
;; 6d. dynamic-wind — entry/exit guards
;; --------------------------------------------------------------------------
;;
;; (dynamic-wind before-thunk body-thunk after-thunk)
;;
;; All three are zero-argument functions (thunks):
;; 1. Call before-thunk
;; 2. Call body-thunk, capture result
;; 3. Call after-thunk (always, even on error)
;; 4. Return body result
;;
;; The wind stack is maintained so that when continuations jump across
;; dynamic-wind boundaries, the correct before/after thunks fire.
;; Without active continuations, this is equivalent to try/finally.
;;
;; Platform requirements:
;; (push-wind! before after) — push wind record onto stack
;; (pop-wind!) — pop wind record from stack
;; (call-thunk f env) — call a zero-arg function
;; --------------------------------------------------------------------------
(define sf-dynamic-wind
(fn ((args :as list) (env :as dict))
(let ((before (trampoline (eval-expr (first args) env)))
(body (trampoline (eval-expr (nth args 1) env)))
(after (trampoline (eval-expr (nth args 2) env))))
;; Delegate to platform — needs try/finally for error safety
(dynamic-wind-call before body after env))))
;; --------------------------------------------------------------------------
;; 6a2. scope — unified render-time dynamic scope primitive
;; --------------------------------------------------------------------------
;;
;; (scope name body...) or (scope name :value v body...)
;; Push a named scope with optional value and empty accumulator,
;; evaluate body, pop scope. Returns last body result.
;;
;; `provide` is sugar: (provide name value body...) = (scope name :value value body...)
(define sf-scope
(fn ((args :as list) (env :as dict))
(let ((name (trampoline (eval-expr (first args) env)))
(rest (slice args 1))
(val nil)
(body-exprs nil))
;; Check for :value keyword
(if (and (>= (len rest) 2) (= (type-of (first rest)) "keyword") (= (keyword-name (first rest)) "value"))
(do (set! val (trampoline (eval-expr (nth rest 1) env)))
(set! body-exprs (slice rest 2)))
(set! body-exprs rest))
(scope-push! name val)
(let ((result nil))
(for-each (fn (e) (set! result (trampoline (eval-expr e env)))) body-exprs)
(scope-pop! name)
result))))
;; provide — sugar for scope with a value
;; (provide name value body...) → (scope name :value value body...)
(define sf-provide
(fn ((args :as list) (env :as dict))
(let ((name (trampoline (eval-expr (first args) env)))
(val (trampoline (eval-expr (nth args 1) env)))
(body-exprs (slice args 2))
(result nil))
(scope-push! name val)
(for-each (fn (e) (set! result (trampoline (eval-expr e env)))) body-exprs)
(scope-pop! name)
result)))
;; --------------------------------------------------------------------------
;; 6b. Macro expansion
;; --------------------------------------------------------------------------
(define expand-macro
(fn ((mac :as macro) (raw-args :as list) (env :as dict))
(let ((local (env-merge (macro-closure mac) env)))
;; Bind positional params (unevaluated)
(for-each
(fn (pair)
(env-bind! local (first pair)
(if (< (nth pair 1) (len raw-args))
(nth raw-args (nth pair 1))
nil)))
(map-indexed (fn (i p) (list p i)) (macro-params mac)))
;; Bind &rest param
(when (macro-rest-param mac)
(env-bind! local (macro-rest-param mac)
(slice raw-args (len (macro-params mac)))))
;; Evaluate body → new AST
(trampoline (eval-expr (macro-body mac) local)))))
;; [REMOVED] Section 7: Tree-walk HO forms — superseded by CEK step-ho-* in cek.sx
;; --------------------------------------------------------------------------
;; 8. Primitives — pure functions available in all targets
;; --------------------------------------------------------------------------
;; These are the ~80 built-in functions. Each target implements them
;; natively but they MUST have identical semantics. This section serves
;; as the specification — bootstrap compilers use it for reference.
;;
;; Primitives are NOT defined here as SX lambdas (that would be circular).
;; Instead, this is a declarative registry that bootstrap compilers read.
;; --------------------------------------------------------------------------
;; See primitives.sx for the full specification.
;; --------------------------------------------------------------------------
;; 9. Platform interface — must be provided by each target
;; --------------------------------------------------------------------------
;;
;; Type inspection:
;; (type-of x) → "number" | "string" | "boolean" | "nil"
;; | "symbol" | "keyword" | "list" | "dict"
;; | "lambda" | "component" | "macro" | "thunk"
;; | "spread"
;; (symbol-name sym) → string
;; (keyword-name kw) → string
;;
;; Constructors:
;; (make-lambda params body env) → Lambda
;; (make-component name params has-children body env affinity) → Component
;; (make-macro params rest-param body env name) → Macro
;; (make-thunk expr env) → Thunk
;;
;; Accessors:
;; (lambda-params f) → list of strings
;; (lambda-body f) → expr
;; (lambda-closure f) → env
;; (lambda-name f) → string or nil
;; (set-lambda-name! f n) → void
;; (component-params c) → list of strings
;; (component-body c) → expr
;; (component-closure c) → env
;; (component-has-children? c) → boolean
;; (component-affinity c) → "auto" | "client" | "server"
;;
;; (make-island name params has-children body env) → Island
;; (island? x) → boolean
;; ;; Islands reuse component accessors: component-params, component-body, etc.
;;
;; (make-spread attrs) → Spread (attrs dict injected onto parent element)
;; (spread? x) → boolean
;; (spread-attrs s) → dict
;;
;; (macro-params m) → list of strings
;; (macro-rest-param m) → string or nil
;; (macro-body m) → expr
;; (macro-closure m) → env
;; (thunk? x) → boolean
;; (thunk-expr t) → expr
;; (thunk-env t) → env
;;
;; Predicates:
;; (callable? x) → boolean (native function or lambda)
;; (lambda? x) → boolean
;; (component? x) → boolean
;; (island? x) → boolean
;; (macro? x) → boolean
;; (primitive? name) → boolean (is name a registered primitive?)
;; (get-primitive name) → function
;;
;; Environment:
;; (env-has? env name) → boolean
;; (env-get env name) → value
;; (env-bind! env name val) → void (create binding on THIS env, no chain walk)
;; (env-set! env name val) → void (mutate existing binding, walks scope chain)
;; (env-extend env) → new env inheriting from env
;; (env-merge base overlay) → new env with overlay on top
;;
;; Mutation helpers (for parse-keyword-args):
;; (dict-set! d key val) → void
;; (dict-get d key) → value or nil
;; (append! lst val) → void (mutating append)
;;
;; Error:
;; (error msg) → raise/throw with message
;; (inspect x) → string representation for debugging
;;
;; Utility:
;; (strip-prefix s prefix) → string with prefix removed (or s unchanged)
;; (apply f args) → call f with args list
;; (zip lists...) → list of tuples
;;
;;
;; Dynamic wind (for dynamic-wind):
;; (push-wind! before after) → void (push wind record onto stack)
;; (pop-wind!) → void (pop wind record from stack)
;; (call-thunk f env) → value (call a zero-arg function)
;;
;; Render-time accumulators:
;; (collect! bucket value) → void (add to named bucket, deduplicated)
;; (collected bucket) → list (all values in bucket)
;; (clear-collected! bucket) → void (empty the bucket)
;; --------------------------------------------------------------------------

1101
spec/cek.sx → spec/evaluator.sx
View File

File diff suppressed because it is too large Load Diff

262
spec/frames.sx
View File

@@ -1,262 +0,0 @@
;; ==========================================================================
;; frames.sx — CEK machine frame types
;;
;; Defines the continuation frame types used by the explicit CEK evaluator.
;; Each frame represents a "what to do next" when a sub-evaluation completes.
;;
;; A CEK state is a dict:
;; {:control expr — expression being evaluated (or nil in continue phase)
;; :env env — current environment
;; :kont list — continuation: list of frames (stack, head = top)
;; :phase "eval"|"continue"
;; :value any} — value produced (only in continue phase)
;;
;; Two-phase step function:
;; step-eval: control is expression → dispatch → push frame + new control
;; step-continue: value produced → pop frame → dispatch → new state
;;
;; Terminal state: phase = "continue" and kont is empty → value is final result.
;; ==========================================================================
;; --------------------------------------------------------------------------
;; 1. CEK State constructors
;; --------------------------------------------------------------------------
(define make-cek-state
(fn (control env kont)
{:control control :env env :kont kont :phase "eval" :value nil}))
(define make-cek-value
(fn (value env kont)
{:control nil :env env :kont kont :phase "continue" :value value}))
(define cek-terminal?
(fn (state)
(and (= (get state "phase") "continue")
(empty? (get state "kont")))))
(define cek-control (fn (s) (get s "control")))
(define cek-env (fn (s) (get s "env")))
(define cek-kont (fn (s) (get s "kont")))
(define cek-phase (fn (s) (get s "phase")))
(define cek-value (fn (s) (get s "value")))
;; --------------------------------------------------------------------------
;; 2. Frame constructors
;; --------------------------------------------------------------------------
;; Each frame type is a dict with a "type" key and frame-specific data.
;; IfFrame: waiting for condition value
;; After condition evaluates, choose then or else branch
(define make-if-frame
(fn (then-expr else-expr env)
{:type "if" :then then-expr :else else-expr :env env}))
;; WhenFrame: waiting for condition value
;; If truthy, evaluate body exprs sequentially
(define make-when-frame
(fn (body-exprs env)
{:type "when" :body body-exprs :env env}))
;; BeginFrame: sequential evaluation
;; Remaining expressions to evaluate after current one
(define make-begin-frame
(fn (remaining env)
{:type "begin" :remaining remaining :env env}))
;; LetFrame: binding evaluation in progress
;; name = current binding name, remaining = remaining (name val) pairs
;; body = body expressions to evaluate after all bindings
(define make-let-frame
(fn (name remaining body local)
{:type "let" :name name :remaining remaining :body body :env local}))
;; DefineFrame: waiting for value to bind
(define make-define-frame
(fn (name env has-effects effect-list)
{:type "define" :name name :env env
:has-effects has-effects :effect-list effect-list}))
;; SetFrame: waiting for value to assign
(define make-set-frame
(fn (name env)
{:type "set" :name name :env env}))
;; ArgFrame: evaluating function arguments
;; f = function value (already evaluated), evaled = already evaluated args
;; remaining = remaining arg expressions
(define make-arg-frame
(fn (f evaled remaining env raw-args head-name)
{:type "arg" :f f :evaled evaled :remaining remaining :env env
:raw-args raw-args :head-name (or head-name nil)}))
;; CallFrame: about to call with fully evaluated args
(define make-call-frame
(fn (f args env)
{:type "call" :f f :args args :env env}))
;; CondFrame: evaluating cond clauses
(define make-cond-frame
(fn (remaining env scheme?)
{:type "cond" :remaining remaining :env env :scheme scheme?}))
;; CaseFrame: evaluating case clauses
(define make-case-frame
(fn (match-val remaining env)
{:type "case" :match-val match-val :remaining remaining :env env}))
;; ThreadFirstFrame: pipe threading
(define make-thread-frame
(fn (remaining env)
{:type "thread" :remaining remaining :env env}))
;; MapFrame: higher-order map/map-indexed in progress
(define make-map-frame
(fn (f remaining results env)
{:type "map" :f f :remaining remaining :results results :env env :indexed false}))
(define make-map-indexed-frame
(fn (f remaining results env)
{:type "map" :f f :remaining remaining :results results :env env :indexed true}))
;; FilterFrame: higher-order filter in progress
(define make-filter-frame
(fn (f remaining results current-item env)
{:type "filter" :f f :remaining remaining :results results
:current-item current-item :env env}))
;; ReduceFrame: higher-order reduce in progress
(define make-reduce-frame
(fn (f remaining env)
{:type "reduce" :f f :remaining remaining :env env}))
;; ForEachFrame: higher-order for-each in progress
(define make-for-each-frame
(fn (f remaining env)
{:type "for-each" :f f :remaining remaining :env env}))
;; SomeFrame: higher-order some (short-circuit on first truthy)
(define make-some-frame
(fn (f remaining env)
{:type "some" :f f :remaining remaining :env env}))
;; EveryFrame: higher-order every? (short-circuit on first falsy)
(define make-every-frame
(fn (f remaining env)
{:type "every" :f f :remaining remaining :env env}))
;; ScopeFrame: scope-pop! when frame pops
(define make-scope-frame
(fn (name remaining env)
{:type "scope" :name name :remaining remaining :env env}))
;; ResetFrame: delimiter for shift/reset continuations
(define make-reset-frame
(fn (env)
{:type "reset" :env env}))
;; DictFrame: evaluating dict values
(define make-dict-frame
(fn (remaining results env)
{:type "dict" :remaining remaining :results results :env env}))
;; AndFrame: short-circuit and
(define make-and-frame
(fn (remaining env)
{:type "and" :remaining remaining :env env}))
;; OrFrame: short-circuit or
(define make-or-frame
(fn (remaining env)
{:type "or" :remaining remaining :env env}))
;; QuasiquoteFrame (not a real frame — QQ is handled specially)
;; DynamicWindFrame: phases of dynamic-wind
(define make-dynamic-wind-frame
(fn (phase body-thunk after-thunk env)
{:type "dynamic-wind" :phase phase
:body-thunk body-thunk :after-thunk after-thunk :env env}))
;; ReactiveResetFrame: delimiter for reactive deref-as-shift
;; Carries an update-fn that gets called with new values on re-render.
(define make-reactive-reset-frame
(fn (env update-fn first-render?)
{:type "reactive-reset" :env env :update-fn update-fn
:first-render first-render?}))
;; DerefFrame: awaiting evaluation of deref's argument
(define make-deref-frame
(fn (env)
{:type "deref" :env env}))
;; --------------------------------------------------------------------------
;; 3. Frame accessors
;; --------------------------------------------------------------------------
(define frame-type (fn (f) (get f "type")))
;; --------------------------------------------------------------------------
;; 4. Continuation operations
;; --------------------------------------------------------------------------
(define kont-push
(fn (frame kont) (cons frame kont)))
(define kont-top
(fn (kont) (first kont)))
(define kont-pop
(fn (kont) (rest kont)))
(define kont-empty?
(fn (kont) (empty? kont)))
;; --------------------------------------------------------------------------
;; 5. CEK shift/reset support
;; --------------------------------------------------------------------------
;; shift captures all frames up to the nearest ResetFrame.
;; reset pushes a ResetFrame.
(define kont-capture-to-reset
(fn (kont)
;; Returns (captured-frames remaining-kont).
;; captured-frames: frames from top up to (not including) ResetFrame.
;; remaining-kont: frames after ResetFrame.
;; Stops at either "reset" or "reactive-reset" frames.
(define scan
(fn (k captured)
(if (empty? k)
(error "shift without enclosing reset")
(let ((frame (first k)))
(if (or (= (frame-type frame) "reset")
(= (frame-type frame) "reactive-reset"))
(list captured (rest k))
(scan (rest k) (append captured (list frame))))))))
(scan kont (list))))
;; Check if a ReactiveResetFrame exists anywhere in the continuation
(define has-reactive-reset-frame?
(fn (kont)
(if (empty? kont) false
(if (= (frame-type (first kont)) "reactive-reset") true
(has-reactive-reset-frame? (rest kont))))))
;; Capture frames up to nearest ReactiveResetFrame.
;; Returns (captured-frames, reset-frame, remaining-kont).
(define kont-capture-to-reactive-reset
(fn (kont)
(define scan
(fn (k captured)
(if (empty? k)
(error "reactive deref without enclosing reactive-reset")
(let ((frame (first k)))
(if (= (frame-type frame) "reactive-reset")
(list captured frame (rest k))
(scan (rest k) (append captured (list frame))))))))
(scan kont (list))))