Implement explicit CEK machine, continuations, effect signatures, fix dynamic-wind and inspect shadowing
Three-phase foundations implementation:
Phase A — Activate dormant shift/reset continuations with 24 SX-native tests
covering basic semantics, predicates, stored continuations, nested reset,
scope interaction, and TCO.
Phase B — Bridge compile-time effect system to runtime: boundary_parser extracts
46 effect annotations, platform provides populate_effect_annotations() and
check_component_effects() for static analysis. 6 new type tests.
Phase C — Explicit CEK machine (frames.sx + cek.sx): evaluation state as data
({control, env, kont, phase, value}), 21 frame types, two-phase step function
(step-eval/step-continue), native shift/reset via frame capture. Bootstrapper
integration: --spec-modules cek transpiles to Python with iterative cek_run.
43 interpreted + 49 transpiled tests passing.
Bug fixes:
- inspect() shadowed by `import inspect` in PLATFORM_ASYNC_PY — renamed to
`import inspect as _inspect`
- dynamic-wind missing platform functions (call_thunk, push_wind!, pop_wind!) —
added with try/finally error safety via dynamic_wind_call
Co-Authored-By: Claude Opus 4.6 <noreply@anthropic.com>
This commit is contained in:
@@ -14,7 +14,7 @@
|
||||
// =========================================================================
|
||||
|
||||
var NIL = Object.freeze({ _nil: true, toString: function() { return "nil"; } });
|
||||
var SX_VERSION = "2026-03-13T16:48:03Z";
|
||||
var SX_VERSION = "2026-03-13T19:15:06Z";
|
||||
|
||||
function isNil(x) { return x === NIL || x === null || x === undefined; }
|
||||
function isSxTruthy(x) { return x !== false && !isNil(x); }
|
||||
|
||||
@@ -1129,17 +1129,21 @@ try:
|
||||
from .platform_py import (
|
||||
PREAMBLE, PLATFORM_PY, PRIMITIVES_PY_PRE, PRIMITIVES_PY_POST,
|
||||
PRIMITIVES_PY_MODULES, _ALL_PY_MODULES,
|
||||
PLATFORM_DEPS_PY, PLATFORM_ASYNC_PY, FIXUPS_PY, CONTINUATIONS_PY,
|
||||
PLATFORM_DEPS_PY, PLATFORM_CEK_PY, CEK_FIXUPS_PY, PLATFORM_ASYNC_PY,
|
||||
FIXUPS_PY, CONTINUATIONS_PY,
|
||||
_assemble_primitives_py, public_api_py,
|
||||
ADAPTER_FILES, SPEC_MODULES, EXTENSION_NAMES, EXTENSION_FORMS,
|
||||
ADAPTER_FILES, SPEC_MODULES, SPEC_MODULE_ORDER,
|
||||
EXTENSION_NAMES, EXTENSION_FORMS,
|
||||
)
|
||||
except ImportError:
|
||||
from shared.sx.ref.platform_py import (
|
||||
PREAMBLE, PLATFORM_PY, PRIMITIVES_PY_PRE, PRIMITIVES_PY_POST,
|
||||
PRIMITIVES_PY_MODULES, _ALL_PY_MODULES,
|
||||
PLATFORM_DEPS_PY, PLATFORM_ASYNC_PY, FIXUPS_PY, CONTINUATIONS_PY,
|
||||
PLATFORM_DEPS_PY, PLATFORM_CEK_PY, CEK_FIXUPS_PY, PLATFORM_ASYNC_PY,
|
||||
FIXUPS_PY, CONTINUATIONS_PY,
|
||||
_assemble_primitives_py, public_api_py,
|
||||
ADAPTER_FILES, SPEC_MODULES, EXTENSION_NAMES, EXTENSION_FORMS,
|
||||
ADAPTER_FILES, SPEC_MODULES, SPEC_MODULE_ORDER,
|
||||
EXTENSION_NAMES, EXTENSION_FORMS,
|
||||
)
|
||||
|
||||
|
||||
@@ -1280,7 +1284,11 @@ def compile_ref_to_py(
|
||||
spec_mod_set.add("page-helpers")
|
||||
if "router" in SPEC_MODULES:
|
||||
spec_mod_set.add("router")
|
||||
# cek module requires frames
|
||||
if "cek" in spec_mod_set:
|
||||
spec_mod_set.add("frames")
|
||||
has_deps = "deps" in spec_mod_set
|
||||
has_cek = "cek" in spec_mod_set
|
||||
|
||||
# Core files always included, then selected adapters, then spec modules
|
||||
sx_files = [
|
||||
@@ -1291,8 +1299,14 @@ def compile_ref_to_py(
|
||||
for name in ("html", "sx"):
|
||||
if name in adapter_set:
|
||||
sx_files.append(ADAPTER_FILES[name])
|
||||
# Use explicit ordering for spec modules (respects dependencies)
|
||||
for name in SPEC_MODULE_ORDER:
|
||||
if name in spec_mod_set:
|
||||
sx_files.append(SPEC_MODULES[name])
|
||||
# Any spec modules not in the order list (future-proofing)
|
||||
for name in sorted(spec_mod_set):
|
||||
sx_files.append(SPEC_MODULES[name])
|
||||
if name not in SPEC_MODULE_ORDER:
|
||||
sx_files.append(SPEC_MODULES[name])
|
||||
|
||||
# Pre-scan define-async names (needed before transpilation so emitter
|
||||
# knows which calls require 'await')
|
||||
@@ -1352,6 +1366,9 @@ def compile_ref_to_py(
|
||||
if has_deps:
|
||||
parts.append(PLATFORM_DEPS_PY)
|
||||
|
||||
if has_cek:
|
||||
parts.append(PLATFORM_CEK_PY)
|
||||
|
||||
if has_async:
|
||||
parts.append(PLATFORM_ASYNC_PY)
|
||||
|
||||
@@ -1363,6 +1380,8 @@ def compile_ref_to_py(
|
||||
parts.append("")
|
||||
|
||||
parts.append(FIXUPS_PY)
|
||||
if has_cek:
|
||||
parts.append(CEK_FIXUPS_PY)
|
||||
if has_continuations:
|
||||
parts.append(CONTINUATIONS_PY)
|
||||
parts.append(public_api_py(has_html, has_sx, has_deps, has_async))
|
||||
|
||||
@@ -283,6 +283,58 @@ def parse_boundary_sx() -> tuple[frozenset[str], dict[str, frozenset[str]]]:
|
||||
return frozenset(all_io), frozen_helpers
|
||||
|
||||
|
||||
def parse_boundary_effects() -> dict[str, list[str]]:
|
||||
"""Parse boundary.sx and return effect annotations for all declared primitives.
|
||||
|
||||
Returns a dict mapping primitive name to its declared effects list.
|
||||
E.g. {"current-user": ["io"], "reset!": ["mutation"], "signal": []}.
|
||||
|
||||
Only includes primitives that have an explicit :effects declaration.
|
||||
Pure primitives from primitives.sx are not included (they have no effects).
|
||||
"""
|
||||
source = _read_file("boundary.sx")
|
||||
exprs = parse_all(source)
|
||||
result: dict[str, list[str]] = {}
|
||||
|
||||
_DECL_FORMS = {
|
||||
"define-io-primitive", "declare-signal-primitive",
|
||||
"declare-spread-primitive",
|
||||
}
|
||||
|
||||
for expr in exprs:
|
||||
if not isinstance(expr, list) or len(expr) < 2:
|
||||
continue
|
||||
head = expr[0]
|
||||
if not isinstance(head, Symbol) or head.name not in _DECL_FORMS:
|
||||
continue
|
||||
|
||||
name = expr[1]
|
||||
if not isinstance(name, str):
|
||||
continue
|
||||
|
||||
effects_val = _extract_keyword_arg(expr, "effects")
|
||||
if effects_val is None:
|
||||
# IO primitives default to [io] if no explicit :effects
|
||||
if head.name == "define-io-primitive":
|
||||
result[name] = ["io"]
|
||||
continue
|
||||
|
||||
if isinstance(effects_val, list):
|
||||
effect_names = []
|
||||
for item in effects_val:
|
||||
if isinstance(item, Symbol):
|
||||
effect_names.append(item.name)
|
||||
elif isinstance(item, str):
|
||||
effect_names.append(item)
|
||||
result[name] = effect_names
|
||||
else:
|
||||
# Might be a single symbol
|
||||
if isinstance(effects_val, Symbol):
|
||||
result[name] = [effects_val.name]
|
||||
|
||||
return result
|
||||
|
||||
|
||||
def parse_boundary_types() -> frozenset[str]:
|
||||
"""Parse boundary.sx and return the declared boundary type names."""
|
||||
source = _read_file("boundary.sx")
|
||||
|
||||
812
shared/sx/ref/cek.sx
Normal file
812
shared/sx/ref/cek.sx
Normal file
@@ -0,0 +1,812 @@
|
||||
;; ==========================================================================
|
||||
;; cek.sx — Explicit CEK machine evaluator
|
||||
;;
|
||||
;; Replaces the implicit CEK (tree-walk + trampoline) with explicit
|
||||
;; C/E/K data structures. Each evaluation step is a pure function from
|
||||
;; state to state. Enables stepping, serialization, migration.
|
||||
;;
|
||||
;; The CEK uses the frame types defined in frames.sx.
|
||||
;; eval-expr remains as the public API — it creates a CEK state and runs.
|
||||
;;
|
||||
;; Requires: frames.sx loaded first.
|
||||
;; ==========================================================================
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; 1. Run loop — drive the CEK machine to completion
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(define cek-run
|
||||
(fn (state)
|
||||
;; Drive the CEK machine until terminal state.
|
||||
;; Returns the final value.
|
||||
(if (cek-terminal? state)
|
||||
(cek-value state)
|
||||
(cek-run (cek-step state)))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; 2. Step function — single CEK step
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(define cek-step
|
||||
(fn (state)
|
||||
(if (= (cek-phase state) "eval")
|
||||
(step-eval state)
|
||||
(step-continue state))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; 3. step-eval — Control is an expression, dispatch on type
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(define step-eval
|
||||
(fn (state)
|
||||
(let ((expr (cek-control state))
|
||||
(env (cek-env state))
|
||||
(kont (cek-kont state)))
|
||||
(case (type-of expr)
|
||||
|
||||
;; --- Literals: immediate value ---
|
||||
"number" (make-cek-value expr env kont)
|
||||
"string" (make-cek-value expr env kont)
|
||||
"boolean" (make-cek-value expr env kont)
|
||||
"nil" (make-cek-value nil env kont)
|
||||
|
||||
;; --- Symbol lookup ---
|
||||
"symbol"
|
||||
(let ((name (symbol-name expr)))
|
||||
(let ((val (cond
|
||||
(env-has? env name) (env-get env name)
|
||||
(primitive? name) (get-primitive name)
|
||||
(= name "true") true
|
||||
(= name "false") false
|
||||
(= name "nil") nil
|
||||
:else (error (str "Undefined symbol: " name)))))
|
||||
(make-cek-value val env kont)))
|
||||
|
||||
;; --- Keyword → string ---
|
||||
"keyword" (make-cek-value (keyword-name expr) env kont)
|
||||
|
||||
;; --- Dict literal: evaluate values ---
|
||||
"dict"
|
||||
(let ((ks (keys expr)))
|
||||
(if (empty? ks)
|
||||
(make-cek-value (dict) env kont)
|
||||
;; Build entry pairs from dict, evaluate first value
|
||||
(let ((first-key (first ks))
|
||||
(remaining-entries (list)))
|
||||
(for-each (fn (k) (append! remaining-entries (list k (get expr k))))
|
||||
(rest ks))
|
||||
(make-cek-state
|
||||
(get expr first-key)
|
||||
env
|
||||
(kont-push
|
||||
(make-dict-frame
|
||||
remaining-entries
|
||||
(list (list first-key)) ;; results: list of (key) waiting for val
|
||||
env)
|
||||
kont)))))
|
||||
|
||||
;; --- List = call or special form ---
|
||||
"list"
|
||||
(if (empty? expr)
|
||||
(make-cek-value (list) env kont)
|
||||
(step-eval-list expr env kont))
|
||||
|
||||
;; --- Anything else passes through ---
|
||||
:else (make-cek-value expr env kont)))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; 4. step-eval-list — Dispatch on list head
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(define step-eval-list
|
||||
(fn (expr env kont)
|
||||
(let ((head (first expr))
|
||||
(args (rest expr)))
|
||||
|
||||
;; If head isn't symbol/lambda/list → treat as data list
|
||||
(if (not (or (= (type-of head) "symbol")
|
||||
(= (type-of head) "lambda")
|
||||
(= (type-of head) "list")))
|
||||
;; Evaluate as data list — evaluate each element
|
||||
(if (empty? expr)
|
||||
(make-cek-value (list) env kont)
|
||||
(make-cek-state
|
||||
(first expr) env
|
||||
(kont-push (make-map-frame nil (rest expr) (list) env) kont)))
|
||||
|
||||
;; Head is symbol — check special forms
|
||||
(if (= (type-of head) "symbol")
|
||||
(let ((name (symbol-name head)))
|
||||
(cond
|
||||
;; --- Special forms → push appropriate frame ---
|
||||
(= name "if") (step-sf-if args env kont)
|
||||
(= name "when") (step-sf-when args env kont)
|
||||
(= name "cond") (step-sf-cond args env kont)
|
||||
(= name "case") (step-sf-case args env kont)
|
||||
(= name "and") (step-sf-and args env kont)
|
||||
(= name "or") (step-sf-or args env kont)
|
||||
(= name "let") (step-sf-let args env kont)
|
||||
(= name "let*") (step-sf-let args env kont)
|
||||
(= name "lambda") (step-sf-lambda args env kont)
|
||||
(= name "fn") (step-sf-lambda args env kont)
|
||||
(= name "define") (step-sf-define args env kont)
|
||||
(= name "defcomp") (make-cek-value (sf-defcomp args env) env kont)
|
||||
(= name "defisland") (make-cek-value (sf-defisland args env) env kont)
|
||||
(= name "defmacro") (make-cek-value (sf-defmacro args env) env kont)
|
||||
(= name "defstyle") (make-cek-value (sf-defstyle args env) env kont)
|
||||
(= name "defhandler") (make-cek-value (sf-defhandler args env) env kont)
|
||||
(= name "defpage") (make-cek-value (sf-defpage args env) env kont)
|
||||
(= name "defquery") (make-cek-value (sf-defquery args env) env kont)
|
||||
(= name "defaction") (make-cek-value (sf-defaction args env) env kont)
|
||||
(= name "deftype") (make-cek-value (sf-deftype args env) env kont)
|
||||
(= name "defeffect") (make-cek-value (sf-defeffect args env) env kont)
|
||||
(= name "begin") (step-sf-begin args env kont)
|
||||
(= name "do") (step-sf-begin args env kont)
|
||||
(= name "quote") (make-cek-value (if (empty? args) nil (first args)) env kont)
|
||||
(= name "quasiquote") (make-cek-value (qq-expand (first args) env) env kont)
|
||||
(= name "->") (step-sf-thread-first args env kont)
|
||||
(= name "set!") (step-sf-set! args env kont)
|
||||
(= name "letrec") (make-cek-value (sf-letrec args env) env kont)
|
||||
|
||||
;; Continuations — native in CEK
|
||||
(= name "reset") (step-sf-reset args env kont)
|
||||
(= name "shift") (step-sf-shift args env kont)
|
||||
|
||||
;; Scoped effects
|
||||
(= name "scope") (step-sf-scope args env kont)
|
||||
(= name "provide") (step-sf-provide args env kont)
|
||||
|
||||
;; Dynamic wind
|
||||
(= name "dynamic-wind") (make-cek-value (sf-dynamic-wind args env) env kont)
|
||||
|
||||
;; Higher-order forms
|
||||
(= name "map") (step-ho-map args env kont)
|
||||
(= name "map-indexed") (make-cek-value (ho-map-indexed args env) env kont)
|
||||
(= name "filter") (step-ho-filter args env kont)
|
||||
(= name "reduce") (step-ho-reduce args env kont)
|
||||
(= name "some") (make-cek-value (ho-some args env) env kont)
|
||||
(= name "every?") (make-cek-value (ho-every args env) env kont)
|
||||
(= name "for-each") (step-ho-for-each args env kont)
|
||||
|
||||
;; Macro expansion
|
||||
(and (env-has? env name) (macro? (env-get env name)))
|
||||
(let ((mac (env-get env name)))
|
||||
(make-cek-state (expand-macro mac args env) env kont))
|
||||
|
||||
;; Render expression
|
||||
(and (render-active?) (is-render-expr? expr))
|
||||
(make-cek-value (render-expr expr env) env kont)
|
||||
|
||||
;; Fall through to function call
|
||||
:else (step-eval-call head args env kont)))
|
||||
|
||||
;; Head is lambda or list — function call
|
||||
(step-eval-call head args env kont))))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; 5. Special form step handlers
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
;; if: evaluate condition, push IfFrame
|
||||
(define step-sf-if
|
||||
(fn (args env kont)
|
||||
(make-cek-state
|
||||
(first args) env
|
||||
(kont-push
|
||||
(make-if-frame (nth args 1)
|
||||
(if (> (len args) 2) (nth args 2) nil)
|
||||
env)
|
||||
kont))))
|
||||
|
||||
;; when: evaluate condition, push WhenFrame
|
||||
(define step-sf-when
|
||||
(fn (args env kont)
|
||||
(make-cek-state
|
||||
(first args) env
|
||||
(kont-push (make-when-frame (rest args) env) kont))))
|
||||
|
||||
;; begin/do: evaluate first expr, push BeginFrame for rest
|
||||
(define step-sf-begin
|
||||
(fn (args env kont)
|
||||
(if (empty? args)
|
||||
(make-cek-value nil env kont)
|
||||
(if (= (len args) 1)
|
||||
(make-cek-state (first args) env kont)
|
||||
(make-cek-state
|
||||
(first args) env
|
||||
(kont-push (make-begin-frame (rest args) env) kont))))))
|
||||
|
||||
;; let: start evaluating bindings
|
||||
(define step-sf-let
|
||||
(fn (args env kont)
|
||||
;; Detect named let
|
||||
(if (= (type-of (first args)) "symbol")
|
||||
;; Named let — delegate to existing handler (complex desugaring)
|
||||
(make-cek-value (sf-named-let args env) env kont)
|
||||
(let ((bindings (first args))
|
||||
(body (rest args))
|
||||
(local (env-extend env)))
|
||||
;; Parse first binding
|
||||
(if (empty? bindings)
|
||||
;; No bindings — evaluate body
|
||||
(step-sf-begin body local kont)
|
||||
;; Start evaluating first binding value
|
||||
(let ((first-binding (if (and (= (type-of (first bindings)) "list")
|
||||
(= (len (first bindings)) 2))
|
||||
;; Scheme-style: ((name val) ...)
|
||||
(first bindings)
|
||||
;; Clojure-style: (name val ...) → synthesize pair
|
||||
(list (first bindings) (nth bindings 1))))
|
||||
(rest-bindings (if (and (= (type-of (first bindings)) "list")
|
||||
(= (len (first bindings)) 2))
|
||||
(rest bindings)
|
||||
;; Clojure-style: skip 2 elements
|
||||
(let ((pairs (list)))
|
||||
(reduce
|
||||
(fn (acc i)
|
||||
(append! pairs (list (nth bindings (* i 2))
|
||||
(nth bindings (inc (* i 2))))))
|
||||
nil
|
||||
(range 1 (/ (len bindings) 2)))
|
||||
pairs))))
|
||||
(let ((vname (if (= (type-of (first first-binding)) "symbol")
|
||||
(symbol-name (first first-binding))
|
||||
(first first-binding))))
|
||||
(make-cek-state
|
||||
(nth first-binding 1) local
|
||||
(kont-push
|
||||
(make-let-frame vname rest-bindings body local)
|
||||
kont)))))))))
|
||||
|
||||
;; define: evaluate value expression
|
||||
(define step-sf-define
|
||||
(fn (args env kont)
|
||||
(let ((name-sym (first args))
|
||||
(has-effects (and (>= (len args) 4)
|
||||
(= (type-of (nth args 1)) "keyword")
|
||||
(= (keyword-name (nth args 1)) "effects")))
|
||||
(val-idx (if (and (>= (len args) 4)
|
||||
(= (type-of (nth args 1)) "keyword")
|
||||
(= (keyword-name (nth args 1)) "effects"))
|
||||
3 1))
|
||||
(effect-list (if (and (>= (len args) 4)
|
||||
(= (type-of (nth args 1)) "keyword")
|
||||
(= (keyword-name (nth args 1)) "effects"))
|
||||
(nth args 2) nil)))
|
||||
(make-cek-state
|
||||
(nth args val-idx) env
|
||||
(kont-push
|
||||
(make-define-frame (symbol-name name-sym) env has-effects effect-list)
|
||||
kont)))))
|
||||
|
||||
;; set!: evaluate value
|
||||
(define step-sf-set!
|
||||
(fn (args env kont)
|
||||
(make-cek-state
|
||||
(nth args 1) env
|
||||
(kont-push (make-set-frame (symbol-name (first args)) env) kont))))
|
||||
|
||||
;; and: evaluate first, push AndFrame
|
||||
(define step-sf-and
|
||||
(fn (args env kont)
|
||||
(if (empty? args)
|
||||
(make-cek-value true env kont)
|
||||
(make-cek-state
|
||||
(first args) env
|
||||
(kont-push (make-and-frame (rest args) env) kont)))))
|
||||
|
||||
;; or: evaluate first, push OrFrame
|
||||
(define step-sf-or
|
||||
(fn (args env kont)
|
||||
(if (empty? args)
|
||||
(make-cek-value false env kont)
|
||||
(make-cek-state
|
||||
(first args) env
|
||||
(kont-push (make-or-frame (rest args) env) kont)))))
|
||||
|
||||
;; cond: evaluate first test, push CondFrame
|
||||
(define step-sf-cond
|
||||
(fn (args env kont)
|
||||
(let ((scheme? (cond-scheme? args)))
|
||||
(if scheme?
|
||||
;; Scheme-style: ((test body) ...)
|
||||
(if (empty? args)
|
||||
(make-cek-value nil env kont)
|
||||
(let ((clause (first args))
|
||||
(test (first clause)))
|
||||
;; Check for :else / else
|
||||
(if (or (and (= (type-of test) "symbol")
|
||||
(or (= (symbol-name test) "else")
|
||||
(= (symbol-name test) ":else")))
|
||||
(and (= (type-of test) "keyword")
|
||||
(= (keyword-name test) "else")))
|
||||
(make-cek-state (nth clause 1) env kont)
|
||||
(make-cek-state
|
||||
test env
|
||||
(kont-push (make-cond-frame args env true) kont)))))
|
||||
;; Clojure-style: test body test body ...
|
||||
(if (< (len args) 2)
|
||||
(make-cek-value nil env kont)
|
||||
(let ((test (first args)))
|
||||
(if (or (and (= (type-of test) "keyword") (= (keyword-name test) "else"))
|
||||
(and (= (type-of test) "symbol")
|
||||
(or (= (symbol-name test) "else")
|
||||
(= (symbol-name test) ":else"))))
|
||||
(make-cek-state (nth args 1) env kont)
|
||||
(make-cek-state
|
||||
test env
|
||||
(kont-push (make-cond-frame args env false) kont)))))))))
|
||||
|
||||
;; case: evaluate match value
|
||||
(define step-sf-case
|
||||
(fn (args env kont)
|
||||
(make-cek-state
|
||||
(first args) env
|
||||
(kont-push (make-case-frame nil (rest args) env) kont))))
|
||||
|
||||
;; thread-first: evaluate initial value
|
||||
(define step-sf-thread-first
|
||||
(fn (args env kont)
|
||||
(make-cek-state
|
||||
(first args) env
|
||||
(kont-push (make-thread-frame (rest args) env) kont))))
|
||||
|
||||
;; lambda/fn: immediate — create lambda value
|
||||
(define step-sf-lambda
|
||||
(fn (args env kont)
|
||||
(make-cek-value (sf-lambda args env) env kont)))
|
||||
|
||||
;; scope: evaluate name, then push ScopeFrame
|
||||
(define step-sf-scope
|
||||
(fn (args env kont)
|
||||
;; Delegate to existing sf-scope for now — scope involves mutation
|
||||
(make-cek-value (sf-scope args env) env kont)))
|
||||
|
||||
;; provide: delegate to existing handler
|
||||
(define step-sf-provide
|
||||
(fn (args env kont)
|
||||
(make-cek-value (sf-provide args env) env kont)))
|
||||
|
||||
;; reset: push ResetFrame, evaluate body
|
||||
(define step-sf-reset
|
||||
(fn (args env kont)
|
||||
(make-cek-state
|
||||
(first args) env
|
||||
(kont-push (make-reset-frame env) kont))))
|
||||
|
||||
;; shift: capture frames to nearest reset
|
||||
(define step-sf-shift
|
||||
(fn (args env kont)
|
||||
(let ((k-name (symbol-name (first args)))
|
||||
(body (nth args 1))
|
||||
(captured-result (kont-capture-to-reset kont))
|
||||
(captured (first captured-result))
|
||||
(rest-kont (nth captured-result 1)))
|
||||
;; Store captured frames as a dict on the continuation value.
|
||||
;; When the continuation is invoked, continue-with-call detects
|
||||
;; the cek-frames key and restores them.
|
||||
(let ((k (make-cek-continuation captured rest-kont)))
|
||||
;; Evaluate shift body with k bound, continuation goes to rest-kont
|
||||
(let ((shift-env (env-extend env)))
|
||||
(env-set! shift-env k-name k)
|
||||
(make-cek-state body shift-env rest-kont))))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; 6. Function call step handler
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(define step-eval-call
|
||||
(fn (head args env kont)
|
||||
;; First evaluate the head, then evaluate args left-to-right
|
||||
(make-cek-state
|
||||
head env
|
||||
(kont-push
|
||||
(make-arg-frame nil (list) args env args)
|
||||
kont))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; 7. Higher-order form step handlers
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(define step-ho-map
|
||||
(fn (args env kont)
|
||||
;; Evaluate function, then collection
|
||||
;; For now, delegate to existing ho-map (it's a tight loop)
|
||||
(make-cek-value (ho-map args env) env kont)))
|
||||
|
||||
(define step-ho-filter
|
||||
(fn (args env kont)
|
||||
(make-cek-value (ho-filter args env) env kont)))
|
||||
|
||||
(define step-ho-reduce
|
||||
(fn (args env kont)
|
||||
(make-cek-value (ho-reduce args env) env kont)))
|
||||
|
||||
(define step-ho-for-each
|
||||
(fn (args env kont)
|
||||
(make-cek-value (ho-for-each args env) env kont)))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; 8. step-continue — Value produced, dispatch on top frame
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(define step-continue
|
||||
(fn (state)
|
||||
(let ((value (cek-value state))
|
||||
(env (cek-env state))
|
||||
(kont (cek-kont state)))
|
||||
(if (kont-empty? kont)
|
||||
state ;; Terminal — return as-is
|
||||
(let ((frame (kont-top kont))
|
||||
(rest-k (kont-pop kont))
|
||||
(ft (frame-type frame)))
|
||||
(cond
|
||||
|
||||
;; --- IfFrame: condition evaluated ---
|
||||
(= ft "if")
|
||||
(if (and value (not (nil? value)))
|
||||
(make-cek-state (get frame "then") (get frame "env") rest-k)
|
||||
(if (nil? (get frame "else"))
|
||||
(make-cek-value nil env rest-k)
|
||||
(make-cek-state (get frame "else") (get frame "env") rest-k)))
|
||||
|
||||
;; --- WhenFrame: condition evaluated ---
|
||||
(= ft "when")
|
||||
(if (and value (not (nil? value)))
|
||||
(let ((body (get frame "body"))
|
||||
(fenv (get frame "env")))
|
||||
(if (empty? body)
|
||||
(make-cek-value nil fenv rest-k)
|
||||
(if (= (len body) 1)
|
||||
(make-cek-state (first body) fenv rest-k)
|
||||
(make-cek-state
|
||||
(first body) fenv
|
||||
(kont-push (make-begin-frame (rest body) fenv) rest-k)))))
|
||||
(make-cek-value nil env rest-k))
|
||||
|
||||
;; --- BeginFrame: expression evaluated, continue with next ---
|
||||
(= ft "begin")
|
||||
(let ((remaining (get frame "remaining"))
|
||||
(fenv (get frame "env")))
|
||||
(if (empty? remaining)
|
||||
(make-cek-value value fenv rest-k)
|
||||
(if (= (len remaining) 1)
|
||||
(make-cek-state (first remaining) fenv rest-k)
|
||||
(make-cek-state
|
||||
(first remaining) fenv
|
||||
(kont-push (make-begin-frame (rest remaining) fenv) rest-k)))))
|
||||
|
||||
;; --- LetFrame: binding value evaluated ---
|
||||
(= ft "let")
|
||||
(let ((name (get frame "name"))
|
||||
(remaining (get frame "remaining"))
|
||||
(body (get frame "body"))
|
||||
(local (get frame "env")))
|
||||
;; Bind the value
|
||||
(env-set! local name value)
|
||||
;; More bindings?
|
||||
(if (empty? remaining)
|
||||
;; All bindings done — evaluate body
|
||||
(step-sf-begin body local rest-k)
|
||||
;; Next binding
|
||||
(let ((next-binding (first remaining))
|
||||
(vname (if (= (type-of (first next-binding)) "symbol")
|
||||
(symbol-name (first next-binding))
|
||||
(first next-binding))))
|
||||
(make-cek-state
|
||||
(nth next-binding 1) local
|
||||
(kont-push
|
||||
(make-let-frame vname (rest remaining) body local)
|
||||
rest-k)))))
|
||||
|
||||
;; --- DefineFrame: value evaluated ---
|
||||
(= ft "define")
|
||||
(let ((name (get frame "name"))
|
||||
(fenv (get frame "env"))
|
||||
(has-effects (get frame "has-effects"))
|
||||
(effect-list (get frame "effect-list")))
|
||||
(when (and (lambda? value) (nil? (lambda-name value)))
|
||||
(set-lambda-name! value name))
|
||||
(env-set! fenv name value)
|
||||
;; Effect annotation
|
||||
(when has-effects
|
||||
(let ((effect-names (if (= (type-of effect-list) "list")
|
||||
(map (fn (e) (if (= (type-of e) "symbol")
|
||||
(symbol-name e) (str e)))
|
||||
effect-list)
|
||||
(list (str effect-list))))
|
||||
(effect-anns (if (env-has? fenv "*effect-annotations*")
|
||||
(env-get fenv "*effect-annotations*")
|
||||
(dict))))
|
||||
(dict-set! effect-anns name effect-names)
|
||||
(env-set! fenv "*effect-annotations*" effect-anns)))
|
||||
(make-cek-value value fenv rest-k))
|
||||
|
||||
;; --- SetFrame: value evaluated ---
|
||||
(= ft "set")
|
||||
(let ((name (get frame "name"))
|
||||
(fenv (get frame "env")))
|
||||
(env-set! fenv name value)
|
||||
(make-cek-value value env rest-k))
|
||||
|
||||
;; --- AndFrame: value evaluated ---
|
||||
(= ft "and")
|
||||
(if (not value)
|
||||
(make-cek-value value env rest-k)
|
||||
(let ((remaining (get frame "remaining")))
|
||||
(if (empty? remaining)
|
||||
(make-cek-value value env rest-k)
|
||||
(make-cek-state
|
||||
(first remaining) (get frame "env")
|
||||
(if (= (len remaining) 1)
|
||||
rest-k
|
||||
(kont-push (make-and-frame (rest remaining) (get frame "env")) rest-k))))))
|
||||
|
||||
;; --- OrFrame: value evaluated ---
|
||||
(= ft "or")
|
||||
(if value
|
||||
(make-cek-value value env rest-k)
|
||||
(let ((remaining (get frame "remaining")))
|
||||
(if (empty? remaining)
|
||||
(make-cek-value false env rest-k)
|
||||
(make-cek-state
|
||||
(first remaining) (get frame "env")
|
||||
(if (= (len remaining) 1)
|
||||
rest-k
|
||||
(kont-push (make-or-frame (rest remaining) (get frame "env")) rest-k))))))
|
||||
|
||||
;; --- CondFrame: test evaluated ---
|
||||
(= ft "cond")
|
||||
(let ((remaining (get frame "remaining"))
|
||||
(fenv (get frame "env"))
|
||||
(scheme? (get frame "scheme")))
|
||||
(if scheme?
|
||||
;; Scheme-style: test truthy → evaluate body
|
||||
(if value
|
||||
(make-cek-state (nth (first remaining) 1) fenv rest-k)
|
||||
;; Next clause
|
||||
(let ((next-clauses (rest remaining)))
|
||||
(if (empty? next-clauses)
|
||||
(make-cek-value nil fenv rest-k)
|
||||
(let ((next-clause (first next-clauses))
|
||||
(next-test (first next-clause)))
|
||||
(if (or (and (= (type-of next-test) "symbol")
|
||||
(or (= (symbol-name next-test) "else")
|
||||
(= (symbol-name next-test) ":else")))
|
||||
(and (= (type-of next-test) "keyword")
|
||||
(= (keyword-name next-test) "else")))
|
||||
(make-cek-state (nth next-clause 1) fenv rest-k)
|
||||
(make-cek-state
|
||||
next-test fenv
|
||||
(kont-push (make-cond-frame next-clauses fenv true) rest-k)))))))
|
||||
;; Clojure-style
|
||||
(if value
|
||||
(make-cek-state (nth remaining 1) fenv rest-k)
|
||||
(let ((next (slice remaining 2)))
|
||||
(if (< (len next) 2)
|
||||
(make-cek-value nil fenv rest-k)
|
||||
(let ((next-test (first next)))
|
||||
(if (or (and (= (type-of next-test) "keyword") (= (keyword-name next-test) "else"))
|
||||
(and (= (type-of next-test) "symbol")
|
||||
(or (= (symbol-name next-test) "else")
|
||||
(= (symbol-name next-test) ":else"))))
|
||||
(make-cek-state (nth next 1) fenv rest-k)
|
||||
(make-cek-state
|
||||
next-test fenv
|
||||
(kont-push (make-cond-frame next fenv false) rest-k)))))))))
|
||||
|
||||
;; --- CaseFrame ---
|
||||
(= ft "case")
|
||||
(let ((match-val (get frame "match-val"))
|
||||
(remaining (get frame "remaining"))
|
||||
(fenv (get frame "env")))
|
||||
(if (nil? match-val)
|
||||
;; First step: match-val just evaluated
|
||||
(sf-case-step-loop value remaining fenv rest-k)
|
||||
;; Subsequent: test clause evaluated
|
||||
(sf-case-step-loop match-val remaining fenv rest-k)))
|
||||
|
||||
;; --- ThreadFirstFrame ---
|
||||
(= ft "thread")
|
||||
(let ((remaining (get frame "remaining"))
|
||||
(fenv (get frame "env")))
|
||||
(if (empty? remaining)
|
||||
(make-cek-value value fenv rest-k)
|
||||
;; Apply next form to value
|
||||
(let ((form (first remaining))
|
||||
(rest-forms (rest remaining)))
|
||||
(let ((result (if (= (type-of form) "list")
|
||||
(let ((f (trampoline (eval-expr (first form) fenv)))
|
||||
(rargs (map (fn (a) (trampoline (eval-expr a fenv))) (rest form)))
|
||||
(all-args (cons value rargs)))
|
||||
(cond
|
||||
(and (callable? f) (not (lambda? f))) (apply f all-args)
|
||||
(lambda? f) (trampoline (call-lambda f all-args fenv))
|
||||
:else (error (str "-> form not callable: " (inspect f)))))
|
||||
(let ((f (trampoline (eval-expr form fenv))))
|
||||
(cond
|
||||
(and (callable? f) (not (lambda? f))) (f value)
|
||||
(lambda? f) (trampoline (call-lambda f (list value) fenv))
|
||||
:else (error (str "-> form not callable: " (inspect f))))))))
|
||||
(if (empty? rest-forms)
|
||||
(make-cek-value result fenv rest-k)
|
||||
(make-cek-value result fenv
|
||||
(kont-push (make-thread-frame rest-forms fenv) rest-k)))))))
|
||||
|
||||
;; --- ArgFrame: head or arg evaluated ---
|
||||
(= ft "arg")
|
||||
(let ((f (get frame "f"))
|
||||
(evaled (get frame "evaled"))
|
||||
(remaining (get frame "remaining"))
|
||||
(fenv (get frame "env"))
|
||||
(raw-args (get frame "raw-args")))
|
||||
(if (nil? f)
|
||||
;; Head just evaluated — value is the function
|
||||
(if (empty? remaining)
|
||||
;; No args — call immediately
|
||||
(continue-with-call value (list) fenv raw-args rest-k)
|
||||
;; Start evaluating args
|
||||
(make-cek-state
|
||||
(first remaining) fenv
|
||||
(kont-push
|
||||
(make-arg-frame value (list) (rest remaining) fenv raw-args)
|
||||
rest-k)))
|
||||
;; An arg was evaluated — accumulate
|
||||
(let ((new-evaled (append evaled (list value))))
|
||||
(if (empty? remaining)
|
||||
;; All args evaluated — call
|
||||
(continue-with-call f new-evaled fenv raw-args rest-k)
|
||||
;; Next arg
|
||||
(make-cek-state
|
||||
(first remaining) fenv
|
||||
(kont-push
|
||||
(make-arg-frame f new-evaled (rest remaining) fenv raw-args)
|
||||
rest-k))))))
|
||||
|
||||
;; --- DictFrame: value evaluated ---
|
||||
(= ft "dict")
|
||||
(let ((remaining (get frame "remaining"))
|
||||
(results (get frame "results"))
|
||||
(fenv (get frame "env")))
|
||||
;; Last result entry is (key) — append value to make (key val)
|
||||
(let ((last-result (last results))
|
||||
(completed (append (slice results 0 (dec (len results)))
|
||||
(list (list (first last-result) value)))))
|
||||
(if (empty? remaining)
|
||||
;; All done — build dict
|
||||
(let ((d (dict)))
|
||||
(for-each
|
||||
(fn (pair) (dict-set! d (first pair) (nth pair 1)))
|
||||
completed)
|
||||
(make-cek-value d fenv rest-k))
|
||||
;; Next entry
|
||||
(let ((next-entry (first remaining)))
|
||||
(make-cek-state
|
||||
(nth next-entry 1) fenv
|
||||
(kont-push
|
||||
(make-dict-frame
|
||||
(rest remaining)
|
||||
(append completed (list (list (first next-entry))))
|
||||
fenv)
|
||||
rest-k))))))
|
||||
|
||||
;; --- ResetFrame: body evaluated normally (no shift) ---
|
||||
(= ft "reset")
|
||||
(make-cek-value value env rest-k)
|
||||
|
||||
;; --- ScopeFrame: body result ---
|
||||
(= ft "scope")
|
||||
(let ((name (get frame "name"))
|
||||
(remaining (get frame "remaining"))
|
||||
(fenv (get frame "env")))
|
||||
(if (empty? remaining)
|
||||
(do (scope-pop! name)
|
||||
(make-cek-value value fenv rest-k))
|
||||
(make-cek-state
|
||||
(first remaining) fenv
|
||||
(kont-push
|
||||
(make-scope-frame name (rest remaining) fenv)
|
||||
rest-k))))
|
||||
|
||||
:else (error (str "Unknown frame type: " ft))))))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; 9. Helper: continue with function call
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(define continue-with-call
|
||||
(fn (f args env raw-args kont)
|
||||
(cond
|
||||
;; Continuation — restore captured frames and inject value
|
||||
(continuation? f)
|
||||
(let ((arg (if (empty? args) nil (first args)))
|
||||
(cont-data (continuation-data f)))
|
||||
(let ((captured (get cont-data "captured"))
|
||||
(rest-k (get cont-data "rest-kont")))
|
||||
(make-cek-value arg env (concat captured rest-k))))
|
||||
|
||||
;; Native callable
|
||||
(and (callable? f) (not (lambda? f)) (not (component? f)) (not (island? f)))
|
||||
(make-cek-value (apply f args) env kont)
|
||||
|
||||
;; Lambda — bind params, evaluate body
|
||||
(lambda? f)
|
||||
(let ((params (lambda-params f))
|
||||
(local (env-merge (lambda-closure f) env)))
|
||||
(if (> (len args) (len params))
|
||||
(error (str (or (lambda-name f) "lambda")
|
||||
" expects " (len params) " args, got " (len args)))
|
||||
(do
|
||||
(for-each
|
||||
(fn (pair) (env-set! local (first pair) (nth pair 1)))
|
||||
(zip params args))
|
||||
(for-each
|
||||
(fn (p) (env-set! local p nil))
|
||||
(slice params (len args)))
|
||||
(make-cek-state (lambda-body f) local kont))))
|
||||
|
||||
;; Component — parse kwargs, bind, evaluate body
|
||||
(or (component? f) (island? f))
|
||||
(let ((parsed (parse-keyword-args raw-args env))
|
||||
(kwargs (first parsed))
|
||||
(children (nth parsed 1))
|
||||
(local (env-merge (component-closure f) env)))
|
||||
(for-each
|
||||
(fn (p) (env-set! local p (or (dict-get kwargs p) nil)))
|
||||
(component-params f))
|
||||
(when (component-has-children? f)
|
||||
(env-set! local "children" children))
|
||||
(make-cek-state (component-body f) local kont))
|
||||
|
||||
:else (error (str "Not callable: " (inspect f))))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; 10. Case step loop helper
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(define sf-case-step-loop
|
||||
(fn (match-val clauses env kont)
|
||||
(if (< (len clauses) 2)
|
||||
(make-cek-value nil env kont)
|
||||
(let ((test (first clauses))
|
||||
(body (nth clauses 1)))
|
||||
(if (or (and (= (type-of test) "keyword") (= (keyword-name test) "else"))
|
||||
(and (= (type-of test) "symbol")
|
||||
(or (= (symbol-name test) "else")
|
||||
(= (symbol-name test) ":else"))))
|
||||
(make-cek-state body env kont)
|
||||
;; Evaluate test expression
|
||||
(let ((test-val (trampoline (eval-expr test env))))
|
||||
(if (= match-val test-val)
|
||||
(make-cek-state body env kont)
|
||||
(sf-case-step-loop match-val (slice clauses 2) env kont))))))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; 11. Compatibility wrapper — eval-expr-cek
|
||||
;; --------------------------------------------------------------------------
|
||||
;;
|
||||
;; Drop-in replacement for eval-expr. Creates a CEK state and runs.
|
||||
;; All downstream code (adapters, services) works unchanged.
|
||||
|
||||
(define eval-expr-cek
|
||||
(fn (expr env)
|
||||
(cek-run (make-cek-state expr env (list)))))
|
||||
|
||||
(define trampoline-cek
|
||||
(fn (val)
|
||||
;; In CEK mode, thunks are not produced — values are immediate.
|
||||
;; But for compatibility, resolve any remaining thunks.
|
||||
(if (thunk? val)
|
||||
(eval-expr-cek (thunk-expr val) (thunk-env val))
|
||||
val)))
|
||||
@@ -941,14 +941,8 @@
|
||||
(let ((before (trampoline (eval-expr (first args) env)))
|
||||
(body (trampoline (eval-expr (nth args 1) env)))
|
||||
(after (trampoline (eval-expr (nth args 2) env))))
|
||||
;; Call entry thunk
|
||||
(call-thunk before env)
|
||||
;; Push wind record, run body, pop, call exit
|
||||
(push-wind! before after)
|
||||
(let ((result (call-thunk body env)))
|
||||
(pop-wind!)
|
||||
(call-thunk after env)
|
||||
result))))
|
||||
;; Delegate to platform — needs try/finally for error safety
|
||||
(dynamic-wind-call before body after env))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
213
shared/sx/ref/frames.sx
Normal file
213
shared/sx/ref/frames.sx
Normal file
@@ -0,0 +1,213 @@
|
||||
;; ==========================================================================
|
||||
;; 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)
|
||||
{:type "arg" :f f :evaled evaled :remaining remaining :env env
|
||||
:raw-args raw-args}))
|
||||
|
||||
;; 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 in progress
|
||||
(define make-map-frame
|
||||
(fn (f remaining results env)
|
||||
{:type "map" :f f :remaining remaining :results results :env env}))
|
||||
|
||||
;; 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}))
|
||||
|
||||
;; 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}))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; 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.
|
||||
(define scan
|
||||
(fn (k captured)
|
||||
(if (empty? k)
|
||||
(error "shift without enclosing reset")
|
||||
(let ((frame (first k)))
|
||||
(if (= (frame-type frame) "reset")
|
||||
(list captured (rest k))
|
||||
(scan (rest k) (append captured (list frame))))))))
|
||||
(scan kont (list))))
|
||||
@@ -1095,6 +1095,37 @@ def for_each_indexed(fn, coll):
|
||||
def map_dict(fn, d):
|
||||
return {k: fn(k, v) for k, v in d.items()}
|
||||
|
||||
# Dynamic wind support (used by sf-dynamic-wind in eval.sx)
|
||||
_wind_stack = []
|
||||
|
||||
def push_wind_b(before, after):
|
||||
_wind_stack.append((before, after))
|
||||
return NIL
|
||||
|
||||
def pop_wind_b():
|
||||
if _wind_stack:
|
||||
_wind_stack.pop()
|
||||
return NIL
|
||||
|
||||
def call_thunk(f, env):
|
||||
"""Call a zero-arg function/lambda."""
|
||||
if is_callable(f) and not is_lambda(f):
|
||||
return f()
|
||||
if is_lambda(f):
|
||||
return trampoline(call_lambda(f, [], env))
|
||||
return trampoline(eval_expr([f], env))
|
||||
|
||||
def dynamic_wind_call(before, body, after, env):
|
||||
"""Execute dynamic-wind with try/finally for error safety."""
|
||||
call_thunk(before, env)
|
||||
push_wind_b(before, after)
|
||||
try:
|
||||
result = call_thunk(body, env)
|
||||
finally:
|
||||
pop_wind_b()
|
||||
call_thunk(after, env)
|
||||
return result
|
||||
|
||||
# Aliases used directly by transpiled code
|
||||
first = PRIMITIVES["first"]
|
||||
last = PRIMITIVES["last"]
|
||||
@@ -1184,6 +1215,43 @@ PLATFORM_DEPS_PY = (
|
||||
' c.io_refs = set(refs) if not isinstance(refs, set) else refs\n'
|
||||
)
|
||||
|
||||
# ---------------------------------------------------------------------------
|
||||
# Platform: CEK module — explicit CEK machine support
|
||||
# ---------------------------------------------------------------------------
|
||||
|
||||
PLATFORM_CEK_PY = '''
|
||||
# =========================================================================
|
||||
# Platform: CEK module — explicit CEK machine
|
||||
# =========================================================================
|
||||
|
||||
# Standalone aliases for primitives used by cek.sx / frames.sx
|
||||
inc = PRIMITIVES["inc"]
|
||||
dec = PRIMITIVES["dec"]
|
||||
zip_pairs = PRIMITIVES["zip-pairs"]
|
||||
|
||||
continuation_p = PRIMITIVES["continuation?"]
|
||||
|
||||
def make_cek_continuation(captured, rest_kont):
|
||||
"""Create a Continuation storing captured CEK frames as data."""
|
||||
c = Continuation(lambda v=NIL: v)
|
||||
c._cek_data = {"captured": captured, "rest-kont": rest_kont}
|
||||
return c
|
||||
|
||||
def continuation_data(c):
|
||||
"""Return the _cek_data dict from a CEK continuation."""
|
||||
return getattr(c, '_cek_data', {}) or {}
|
||||
'''
|
||||
|
||||
# Iterative override for cek_run — replaces transpiled recursive version
|
||||
CEK_FIXUPS_PY = '''
|
||||
# Override recursive cek_run with iterative loop (avoids Python stack overflow)
|
||||
def cek_run(state):
|
||||
"""Drive CEK machine to completion (iterative)."""
|
||||
while not cek_terminal_p(state):
|
||||
state = cek_step(state)
|
||||
return cek_value(state)
|
||||
'''
|
||||
|
||||
# ---------------------------------------------------------------------------
|
||||
# Platform: async adapter — async evaluation, I/O dispatch
|
||||
# ---------------------------------------------------------------------------
|
||||
@@ -1194,7 +1262,7 @@ PLATFORM_ASYNC_PY = '''
|
||||
# =========================================================================
|
||||
|
||||
import contextvars
|
||||
import inspect
|
||||
import inspect as _inspect
|
||||
|
||||
from shared.sx.primitives_io import (
|
||||
IO_PRIMITIVES, RequestContext, execute_io,
|
||||
@@ -1287,7 +1355,7 @@ def sx_parse(src):
|
||||
|
||||
|
||||
def is_async_coroutine(x):
|
||||
return inspect.iscoroutine(x)
|
||||
return _inspect.iscoroutine(x)
|
||||
|
||||
|
||||
async def async_await(x):
|
||||
@@ -1542,6 +1610,68 @@ def public_api_py(has_html: bool, has_sx: bool, has_deps: bool = False,
|
||||
'def make_env(**kwargs):',
|
||||
' """Create an environment with initial bindings."""',
|
||||
' return _Env(dict(kwargs))',
|
||||
'',
|
||||
'',
|
||||
'def populate_effect_annotations(env, effect_map=None):',
|
||||
' """Populate *effect-annotations* in env from boundary declarations.',
|
||||
'',
|
||||
' If effect_map is provided, use it directly (dict of name -> effects list).',
|
||||
' Otherwise, parse boundary.sx via boundary_parser.',
|
||||
' """',
|
||||
' if effect_map is None:',
|
||||
' from shared.sx.ref.boundary_parser import parse_boundary_effects',
|
||||
' effect_map = parse_boundary_effects()',
|
||||
' anns = env.get("*effect-annotations*", {})',
|
||||
' if not isinstance(anns, dict):',
|
||||
' anns = {}',
|
||||
' anns.update(effect_map)',
|
||||
' env["*effect-annotations*"] = anns',
|
||||
' return anns',
|
||||
'',
|
||||
'',
|
||||
'def check_component_effects(env, comp_name=None):',
|
||||
' """Check effect violations for components in env.',
|
||||
'',
|
||||
' If comp_name is given, check only that component.',
|
||||
' Returns list of diagnostic dicts (warnings, not errors).',
|
||||
' """',
|
||||
' anns = env.get("*effect-annotations*")',
|
||||
' if not anns:',
|
||||
' return []',
|
||||
' diagnostics = []',
|
||||
' names = [comp_name] if comp_name else [k for k in env if isinstance(k, str) and k.startswith("~")]',
|
||||
' for name in names:',
|
||||
' val = env.get(name)',
|
||||
' if val is not None and type_of(val) == "component":',
|
||||
' comp_effects = anns.get(name)',
|
||||
' if comp_effects is None:',
|
||||
' continue # unannotated — skip',
|
||||
' body = val.body if hasattr(val, "body") else None',
|
||||
' if body is None:',
|
||||
' continue',
|
||||
' _walk_effects(body, name, comp_effects, anns, diagnostics)',
|
||||
' return diagnostics',
|
||||
'',
|
||||
'',
|
||||
'def _walk_effects(node, comp_name, caller_effects, anns, diagnostics):',
|
||||
' """Walk AST node and check effect calls."""',
|
||||
' if not isinstance(node, list) or not node:',
|
||||
' return',
|
||||
' head = node[0]',
|
||||
' if isinstance(head, Symbol):',
|
||||
' callee = head.name',
|
||||
' callee_effects = anns.get(callee)',
|
||||
' if callee_effects is not None and caller_effects is not None:',
|
||||
' for e in callee_effects:',
|
||||
' if e not in caller_effects:',
|
||||
' diagnostics.append({',
|
||||
' "level": "warning",',
|
||||
' "message": f"`{callee}` has effects {callee_effects} but `{comp_name}` only allows {caller_effects or \'[pure]\'}",',
|
||||
' "component": comp_name,',
|
||||
' })',
|
||||
' break',
|
||||
' for child in node[1:]:',
|
||||
' _walk_effects(child, comp_name, caller_effects, anns, diagnostics)',
|
||||
])
|
||||
return '\n'.join(lines)
|
||||
|
||||
@@ -1563,8 +1693,16 @@ 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)"),
|
||||
}
|
||||
|
||||
# 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", "signals", "types", "cek",
|
||||
]
|
||||
|
||||
EXTENSION_NAMES = {"continuations"}
|
||||
|
||||
EXTENSION_FORMS = {
|
||||
|
||||
256
shared/sx/ref/run_cek_tests.py
Normal file
256
shared/sx/ref/run_cek_tests.py
Normal file
@@ -0,0 +1,256 @@
|
||||
#!/usr/bin/env python3
|
||||
"""Run test-cek.sx using the bootstrapped evaluator with CEK module loaded."""
|
||||
from __future__ import annotations
|
||||
import os, sys
|
||||
|
||||
_HERE = os.path.dirname(os.path.abspath(__file__))
|
||||
_PROJECT = os.path.abspath(os.path.join(_HERE, "..", "..", ".."))
|
||||
sys.path.insert(0, _PROJECT)
|
||||
|
||||
from shared.sx.parser import parse_all
|
||||
from shared.sx.ref import sx_ref
|
||||
from shared.sx.ref.sx_ref import (
|
||||
eval_expr, trampoline, make_env, env_get, env_has, env_set,
|
||||
env_extend, env_merge,
|
||||
)
|
||||
from shared.sx.types import (
|
||||
NIL, Symbol, Keyword, Lambda, Component, Island, Continuation, Macro,
|
||||
_ShiftSignal,
|
||||
)
|
||||
|
||||
# Build env with primitives
|
||||
env = make_env()
|
||||
|
||||
# Platform test functions
|
||||
_suite_stack: list[str] = []
|
||||
_pass_count = 0
|
||||
_fail_count = 0
|
||||
|
||||
def _try_call(thunk):
|
||||
try:
|
||||
trampoline(eval_expr([thunk], env))
|
||||
return {"ok": True}
|
||||
except Exception as e:
|
||||
return {"ok": False, "error": str(e)}
|
||||
|
||||
def _report_pass(name):
|
||||
global _pass_count
|
||||
_pass_count += 1
|
||||
ctx = " > ".join(_suite_stack)
|
||||
print(f" PASS: {ctx} > {name}")
|
||||
return NIL
|
||||
|
||||
def _report_fail(name, error):
|
||||
global _fail_count
|
||||
_fail_count += 1
|
||||
ctx = " > ".join(_suite_stack)
|
||||
print(f" FAIL: {ctx} > {name}: {error}")
|
||||
return NIL
|
||||
|
||||
def _push_suite(name):
|
||||
_suite_stack.append(name)
|
||||
print(f"{' ' * (len(_suite_stack)-1)}Suite: {name}")
|
||||
return NIL
|
||||
|
||||
def _pop_suite():
|
||||
if _suite_stack:
|
||||
_suite_stack.pop()
|
||||
return NIL
|
||||
|
||||
def _test_env():
|
||||
return env
|
||||
|
||||
def _sx_parse(source):
|
||||
return parse_all(source)
|
||||
|
||||
def _sx_parse_one(source):
|
||||
"""Parse a single expression."""
|
||||
exprs = parse_all(source)
|
||||
return exprs[0] if exprs else NIL
|
||||
|
||||
def _make_continuation(fn):
|
||||
return Continuation(fn)
|
||||
|
||||
env["try-call"] = _try_call
|
||||
env["report-pass"] = _report_pass
|
||||
env["report-fail"] = _report_fail
|
||||
env["push-suite"] = _push_suite
|
||||
env["pop-suite"] = _pop_suite
|
||||
env["test-env"] = _test_env
|
||||
env["sx-parse"] = _sx_parse
|
||||
env["sx-parse-one"] = _sx_parse_one
|
||||
env["env-get"] = env_get
|
||||
env["env-has?"] = env_has
|
||||
env["env-set!"] = env_set
|
||||
env["env-extend"] = env_extend
|
||||
env["make-continuation"] = _make_continuation
|
||||
env["continuation?"] = lambda x: isinstance(x, Continuation)
|
||||
env["continuation-fn"] = lambda c: c.fn
|
||||
|
||||
def _make_cek_continuation(captured, rest_kont):
|
||||
"""Create a Continuation that stores captured CEK frames as data."""
|
||||
data = {"captured": captured, "rest-kont": rest_kont}
|
||||
# The fn is a dummy — invocation happens via CEK's continue-with-call
|
||||
return Continuation(lambda v=NIL: v)
|
||||
|
||||
# Monkey-patch to store data
|
||||
_orig_make_cek_cont = _make_cek_continuation
|
||||
def _make_cek_continuation_with_data(captured, rest_kont):
|
||||
c = _orig_make_cek_cont(captured, rest_kont)
|
||||
c._cek_data = {"captured": captured, "rest-kont": rest_kont}
|
||||
return c
|
||||
|
||||
env["make-cek-continuation"] = _make_cek_continuation_with_data
|
||||
env["continuation-data"] = lambda c: getattr(c, '_cek_data', {})
|
||||
|
||||
# Register platform functions from sx_ref that cek.sx and eval.sx need
|
||||
# These are normally available as transpiled Python but need to be in the
|
||||
# SX env when interpreting .sx files directly.
|
||||
|
||||
# Type predicates and constructors
|
||||
env["callable?"] = lambda x: callable(x) or isinstance(x, (Lambda, Component, Island, Continuation))
|
||||
env["lambda?"] = lambda x: isinstance(x, Lambda)
|
||||
env["component?"] = lambda x: isinstance(x, Component)
|
||||
env["island?"] = lambda x: isinstance(x, Island)
|
||||
env["macro?"] = lambda x: isinstance(x, Macro)
|
||||
env["thunk?"] = sx_ref.is_thunk
|
||||
env["thunk-expr"] = sx_ref.thunk_expr
|
||||
env["thunk-env"] = sx_ref.thunk_env
|
||||
env["make-thunk"] = sx_ref.make_thunk
|
||||
env["make-lambda"] = sx_ref.make_lambda
|
||||
env["make-component"] = sx_ref.make_component
|
||||
env["make-island"] = sx_ref.make_island
|
||||
env["make-macro"] = sx_ref.make_macro
|
||||
env["make-symbol"] = lambda n: Symbol(n)
|
||||
env["lambda-params"] = lambda f: f.params
|
||||
env["lambda-body"] = lambda f: f.body
|
||||
env["lambda-closure"] = lambda f: f.closure
|
||||
env["lambda-name"] = lambda f: f.name
|
||||
env["set-lambda-name!"] = lambda f, n: setattr(f, 'name', n) or NIL
|
||||
env["component-params"] = lambda c: c.params
|
||||
env["component-body"] = lambda c: c.body
|
||||
env["component-closure"] = lambda c: c.closure
|
||||
env["component-has-children?"] = lambda c: c.has_children
|
||||
env["component-affinity"] = lambda c: getattr(c, 'affinity', 'auto')
|
||||
env["component-set-param-types!"] = lambda c, t: setattr(c, 'param_types', t) or NIL
|
||||
env["macro-params"] = lambda m: m.params
|
||||
env["macro-rest-param"] = lambda m: m.rest_param
|
||||
env["macro-body"] = lambda m: m.body
|
||||
env["macro-closure"] = lambda m: m.closure
|
||||
env["env-merge"] = env_merge
|
||||
env["symbol-name"] = lambda s: s.name if isinstance(s, Symbol) else str(s)
|
||||
env["keyword-name"] = lambda k: k.name if isinstance(k, Keyword) else str(k)
|
||||
env["type-of"] = sx_ref.type_of
|
||||
env["primitive?"] = lambda n: n in sx_ref.PRIMITIVES
|
||||
env["get-primitive"] = lambda n: sx_ref.PRIMITIVES.get(n)
|
||||
env["strip-prefix"] = lambda s, p: s[len(p):] if s.startswith(p) else s
|
||||
env["inspect"] = repr
|
||||
env["debug-log"] = lambda *args: None
|
||||
env["error"] = sx_ref.error
|
||||
env["apply"] = lambda f, args: f(*args)
|
||||
|
||||
# Functions from eval.sx that cek.sx references
|
||||
env["trampoline"] = trampoline
|
||||
env["eval-expr"] = eval_expr
|
||||
env["eval-list"] = sx_ref.eval_list
|
||||
env["eval-call"] = sx_ref.eval_call
|
||||
env["call-lambda"] = sx_ref.call_lambda
|
||||
env["call-component"] = sx_ref.call_component
|
||||
env["parse-keyword-args"] = sx_ref.parse_keyword_args
|
||||
env["sf-lambda"] = sx_ref.sf_lambda
|
||||
env["sf-defcomp"] = sx_ref.sf_defcomp
|
||||
env["sf-defisland"] = sx_ref.sf_defisland
|
||||
env["sf-defmacro"] = sx_ref.sf_defmacro
|
||||
env["sf-defstyle"] = sx_ref.sf_defstyle
|
||||
env["sf-deftype"] = sx_ref.sf_deftype
|
||||
env["sf-defeffect"] = sx_ref.sf_defeffect
|
||||
env["sf-letrec"] = sx_ref.sf_letrec
|
||||
env["sf-named-let"] = sx_ref.sf_named_let
|
||||
env["sf-dynamic-wind"] = sx_ref.sf_dynamic_wind
|
||||
env["sf-scope"] = sx_ref.sf_scope
|
||||
env["sf-provide"] = sx_ref.sf_provide
|
||||
env["qq-expand"] = sx_ref.qq_expand
|
||||
env["expand-macro"] = sx_ref.expand_macro
|
||||
env["cond-scheme?"] = sx_ref.cond_scheme_p
|
||||
|
||||
# Higher-order form handlers
|
||||
env["ho-map"] = sx_ref.ho_map
|
||||
env["ho-map-indexed"] = sx_ref.ho_map_indexed
|
||||
env["ho-filter"] = sx_ref.ho_filter
|
||||
env["ho-reduce"] = sx_ref.ho_reduce
|
||||
env["ho-some"] = sx_ref.ho_some
|
||||
env["ho-every"] = sx_ref.ho_every
|
||||
env["ho-for-each"] = sx_ref.ho_for_each
|
||||
env["call-fn"] = sx_ref.call_fn
|
||||
|
||||
# Render-related (stub for testing — no active rendering)
|
||||
env["render-active?"] = lambda: False
|
||||
env["is-render-expr?"] = lambda expr: False
|
||||
env["render-expr"] = lambda expr, env: NIL
|
||||
|
||||
# Scope primitives
|
||||
env["scope-push!"] = sx_ref.PRIMITIVES.get("scope-push!", lambda *a: NIL)
|
||||
env["scope-pop!"] = sx_ref.PRIMITIVES.get("scope-pop!", lambda *a: NIL)
|
||||
env["context"] = sx_ref.PRIMITIVES.get("context", lambda *a: NIL)
|
||||
env["emit!"] = sx_ref.PRIMITIVES.get("emit!", lambda *a: NIL)
|
||||
env["emitted"] = sx_ref.PRIMITIVES.get("emitted", lambda *a: [])
|
||||
|
||||
# Dynamic wind
|
||||
env["push-wind!"] = lambda before, after: NIL
|
||||
env["pop-wind!"] = lambda: NIL
|
||||
env["call-thunk"] = lambda f, e: f() if callable(f) else trampoline(eval_expr([f], e))
|
||||
|
||||
# Mutation helpers used by parse-keyword-args etc
|
||||
env["dict-get"] = lambda d, k: d.get(k, NIL) if isinstance(d, dict) else NIL
|
||||
|
||||
# defhandler, defpage, defquery, defaction — these are registrations
|
||||
# Use the bootstrapped versions if they exist, otherwise stub
|
||||
for name in ["sf-defhandler", "sf-defpage", "sf-defquery", "sf-defaction"]:
|
||||
pyname = name.replace("-", "_")
|
||||
fn = getattr(sx_ref, pyname, None)
|
||||
if fn:
|
||||
env[name] = fn
|
||||
else:
|
||||
env[name] = lambda args, e, _n=name: NIL
|
||||
|
||||
# Load test framework
|
||||
with open(os.path.join(_HERE, "test-framework.sx")) as f:
|
||||
for expr in parse_all(f.read()):
|
||||
trampoline(eval_expr(expr, env))
|
||||
|
||||
# Load frames module
|
||||
print("Loading frames.sx ...")
|
||||
with open(os.path.join(_HERE, "frames.sx")) as f:
|
||||
for expr in parse_all(f.read()):
|
||||
trampoline(eval_expr(expr, env))
|
||||
|
||||
# Load CEK module
|
||||
print("Loading cek.sx ...")
|
||||
with open(os.path.join(_HERE, "cek.sx")) as f:
|
||||
for expr in parse_all(f.read()):
|
||||
trampoline(eval_expr(expr, env))
|
||||
|
||||
# Define cek-eval helper in SX
|
||||
for expr in parse_all("""
|
||||
(define cek-eval
|
||||
(fn (source)
|
||||
(let ((exprs (sx-parse source)))
|
||||
(let ((result nil))
|
||||
(for-each (fn (e) (set! result (eval-expr-cek e (test-env)))) exprs)
|
||||
result))))
|
||||
"""):
|
||||
trampoline(eval_expr(expr, env))
|
||||
|
||||
# Run tests
|
||||
print("=" * 60)
|
||||
print("Running test-cek.sx")
|
||||
print("=" * 60)
|
||||
|
||||
with open(os.path.join(_HERE, "test-cek.sx")) as f:
|
||||
for expr in parse_all(f.read()):
|
||||
trampoline(eval_expr(expr, env))
|
||||
|
||||
print("=" * 60)
|
||||
print(f"Results: {_pass_count} passed, {_fail_count} failed")
|
||||
print("=" * 60)
|
||||
sys.exit(1 if _fail_count > 0 else 0)
|
||||
101
shared/sx/ref/run_continuation_tests.py
Normal file
101
shared/sx/ref/run_continuation_tests.py
Normal file
@@ -0,0 +1,101 @@
|
||||
#!/usr/bin/env python3
|
||||
"""Run test-continuations.sx using the bootstrapped evaluator with continuations enabled."""
|
||||
from __future__ import annotations
|
||||
import os, sys, subprocess, tempfile
|
||||
|
||||
_HERE = os.path.dirname(os.path.abspath(__file__))
|
||||
_PROJECT = os.path.abspath(os.path.join(_HERE, "..", "..", ".."))
|
||||
sys.path.insert(0, _PROJECT)
|
||||
|
||||
# Bootstrap a fresh sx_ref with continuations enabled
|
||||
print("Bootstrapping with --extensions continuations ...")
|
||||
result = subprocess.run(
|
||||
[sys.executable, os.path.join(_HERE, "bootstrap_py.py"),
|
||||
"--extensions", "continuations"],
|
||||
capture_output=True, text=True, cwd=_PROJECT,
|
||||
)
|
||||
if result.returncode != 0:
|
||||
print("Bootstrap FAILED:")
|
||||
print(result.stderr)
|
||||
sys.exit(1)
|
||||
|
||||
# Write to temp file and import
|
||||
tmp = tempfile.NamedTemporaryFile(mode="w", suffix=".py", delete=False, dir=_HERE)
|
||||
tmp.write(result.stdout)
|
||||
tmp.close()
|
||||
|
||||
try:
|
||||
import importlib.util
|
||||
spec = importlib.util.spec_from_file_location("sx_ref_cont", tmp.name)
|
||||
mod = importlib.util.module_from_spec(spec)
|
||||
spec.loader.exec_module(mod)
|
||||
finally:
|
||||
os.unlink(tmp.name)
|
||||
|
||||
from shared.sx.parser import parse_all
|
||||
from shared.sx.types import NIL
|
||||
|
||||
eval_expr = mod.eval_expr
|
||||
trampoline = mod.trampoline
|
||||
env = mod.make_env()
|
||||
|
||||
# Platform test functions
|
||||
_suite_stack: list[str] = []
|
||||
_pass_count = 0
|
||||
_fail_count = 0
|
||||
|
||||
def _try_call(thunk):
|
||||
try:
|
||||
trampoline(eval_expr([thunk], env))
|
||||
return {"ok": True}
|
||||
except Exception as e:
|
||||
return {"ok": False, "error": str(e)}
|
||||
|
||||
def _report_pass(name):
|
||||
global _pass_count
|
||||
_pass_count += 1
|
||||
ctx = " > ".join(_suite_stack)
|
||||
print(f" PASS: {ctx} > {name}")
|
||||
return NIL
|
||||
|
||||
def _report_fail(name, error):
|
||||
global _fail_count
|
||||
_fail_count += 1
|
||||
ctx = " > ".join(_suite_stack)
|
||||
print(f" FAIL: {ctx} > {name}: {error}")
|
||||
return NIL
|
||||
|
||||
def _push_suite(name):
|
||||
_suite_stack.append(name)
|
||||
print(f"{' ' * (len(_suite_stack)-1)}Suite: {name}")
|
||||
return NIL
|
||||
|
||||
def _pop_suite():
|
||||
if _suite_stack:
|
||||
_suite_stack.pop()
|
||||
return NIL
|
||||
|
||||
env["try-call"] = _try_call
|
||||
env["report-pass"] = _report_pass
|
||||
env["report-fail"] = _report_fail
|
||||
env["push-suite"] = _push_suite
|
||||
env["pop-suite"] = _pop_suite
|
||||
|
||||
# Load test framework
|
||||
with open(os.path.join(_HERE, "test-framework.sx")) as f:
|
||||
for expr in parse_all(f.read()):
|
||||
trampoline(eval_expr(expr, env))
|
||||
|
||||
# Run tests
|
||||
print("=" * 60)
|
||||
print("Running test-continuations.sx")
|
||||
print("=" * 60)
|
||||
|
||||
with open(os.path.join(_HERE, "test-continuations.sx")) as f:
|
||||
for expr in parse_all(f.read()):
|
||||
trampoline(eval_expr(expr, env))
|
||||
|
||||
print("=" * 60)
|
||||
print(f"Results: {_pass_count} passed, {_fail_count} failed")
|
||||
print("=" * 60)
|
||||
sys.exit(1 if _fail_count > 0 else 0)
|
||||
@@ -8,7 +8,7 @@ _PROJECT = os.path.abspath(os.path.join(_HERE, "..", "..", ".."))
|
||||
sys.path.insert(0, _PROJECT)
|
||||
|
||||
from shared.sx.parser import parse_all
|
||||
from shared.sx.ref.sx_ref import eval_expr, trampoline, make_env
|
||||
from shared.sx.ref.sx_ref import eval_expr, trampoline, make_env, env_get, env_has, env_set
|
||||
from shared.sx.types import NIL, Component
|
||||
|
||||
# Build env with primitives
|
||||
@@ -154,6 +154,9 @@ env["component-params"] = _component_params
|
||||
env["component-body"] = _component_body
|
||||
env["component-has-children"] = _component_has_children
|
||||
env["map-dict"] = _map_dict
|
||||
env["env-get"] = env_get
|
||||
env["env-has?"] = env_has
|
||||
env["env-set!"] = env_set
|
||||
|
||||
# Load test framework (macros + assertion helpers)
|
||||
with open(os.path.join(_HERE, "test-framework.sx")) as f:
|
||||
|
||||
@@ -1015,6 +1015,37 @@ def for_each_indexed(fn, coll):
|
||||
def map_dict(fn, d):
|
||||
return {k: fn(k, v) for k, v in d.items()}
|
||||
|
||||
# Dynamic wind support (used by sf-dynamic-wind in eval.sx)
|
||||
_wind_stack = []
|
||||
|
||||
def push_wind_b(before, after):
|
||||
_wind_stack.append((before, after))
|
||||
return NIL
|
||||
|
||||
def pop_wind_b():
|
||||
if _wind_stack:
|
||||
_wind_stack.pop()
|
||||
return NIL
|
||||
|
||||
def call_thunk(f, env):
|
||||
"""Call a zero-arg function/lambda."""
|
||||
if is_callable(f) and not is_lambda(f):
|
||||
return f()
|
||||
if is_lambda(f):
|
||||
return trampoline(call_lambda(f, [], env))
|
||||
return trampoline(eval_expr([f], env))
|
||||
|
||||
def dynamic_wind_call(before, body, after, env):
|
||||
"""Execute dynamic-wind with try/finally for error safety."""
|
||||
call_thunk(before, env)
|
||||
push_wind_b(before, after)
|
||||
try:
|
||||
result = call_thunk(body, env)
|
||||
finally:
|
||||
pop_wind_b()
|
||||
call_thunk(after, env)
|
||||
return result
|
||||
|
||||
# Aliases used directly by transpiled code
|
||||
first = PRIMITIVES["first"]
|
||||
last = PRIMITIVES["last"]
|
||||
@@ -1103,7 +1134,7 @@ def component_set_io_refs(c, refs):
|
||||
# =========================================================================
|
||||
|
||||
import contextvars
|
||||
import inspect
|
||||
import inspect as _inspect
|
||||
|
||||
from shared.sx.primitives_io import (
|
||||
IO_PRIMITIVES, RequestContext, execute_io,
|
||||
@@ -1196,7 +1227,7 @@ def sx_parse(src):
|
||||
|
||||
|
||||
def is_async_coroutine(x):
|
||||
return inspect.iscoroutine(x)
|
||||
return _inspect.iscoroutine(x)
|
||||
|
||||
|
||||
async def async_await(x):
|
||||
@@ -1890,12 +1921,7 @@ def sf_dynamic_wind(args, env):
|
||||
before = trampoline(eval_expr(first(args), env))
|
||||
body = trampoline(eval_expr(nth(args, 1), env))
|
||||
after = trampoline(eval_expr(nth(args, 2), env))
|
||||
call_thunk(before, env)
|
||||
push_wind_b(before, after)
|
||||
result = call_thunk(body, env)
|
||||
pop_wind_b()
|
||||
call_thunk(after, env)
|
||||
return result
|
||||
return dynamic_wind_call(before, body, after, env)
|
||||
|
||||
# sf-scope
|
||||
def sf_scope(args, env):
|
||||
@@ -4634,3 +4660,65 @@ def render(expr, env=None):
|
||||
def make_env(**kwargs):
|
||||
"""Create an environment with initial bindings."""
|
||||
return _Env(dict(kwargs))
|
||||
|
||||
|
||||
def populate_effect_annotations(env, effect_map=None):
|
||||
"""Populate *effect-annotations* in env from boundary declarations.
|
||||
|
||||
If effect_map is provided, use it directly (dict of name -> effects list).
|
||||
Otherwise, parse boundary.sx via boundary_parser.
|
||||
"""
|
||||
if effect_map is None:
|
||||
from shared.sx.ref.boundary_parser import parse_boundary_effects
|
||||
effect_map = parse_boundary_effects()
|
||||
anns = env.get("*effect-annotations*", {})
|
||||
if not isinstance(anns, dict):
|
||||
anns = {}
|
||||
anns.update(effect_map)
|
||||
env["*effect-annotations*"] = anns
|
||||
return anns
|
||||
|
||||
|
||||
def check_component_effects(env, comp_name=None):
|
||||
"""Check effect violations for components in env.
|
||||
|
||||
If comp_name is given, check only that component.
|
||||
Returns list of diagnostic dicts (warnings, not errors).
|
||||
"""
|
||||
anns = env.get("*effect-annotations*")
|
||||
if not anns:
|
||||
return []
|
||||
diagnostics = []
|
||||
names = [comp_name] if comp_name else [k for k in env if isinstance(k, str) and k.startswith("~")]
|
||||
for name in names:
|
||||
val = env.get(name)
|
||||
if val is not None and type_of(val) == "component":
|
||||
comp_effects = anns.get(name)
|
||||
if comp_effects is None:
|
||||
continue # unannotated — skip
|
||||
body = val.body if hasattr(val, "body") else None
|
||||
if body is None:
|
||||
continue
|
||||
_walk_effects(body, name, comp_effects, anns, diagnostics)
|
||||
return diagnostics
|
||||
|
||||
|
||||
def _walk_effects(node, comp_name, caller_effects, anns, diagnostics):
|
||||
"""Walk AST node and check effect calls."""
|
||||
if not isinstance(node, list) or not node:
|
||||
return
|
||||
head = node[0]
|
||||
if isinstance(head, Symbol):
|
||||
callee = head.name
|
||||
callee_effects = anns.get(callee)
|
||||
if callee_effects is not None and caller_effects is not None:
|
||||
for e in callee_effects:
|
||||
if e not in caller_effects:
|
||||
diagnostics.append({
|
||||
"level": "warning",
|
||||
"message": f"`{callee}` has effects {callee_effects} but `{comp_name}` only allows {caller_effects or '[pure]'}",
|
||||
"component": comp_name,
|
||||
})
|
||||
break
|
||||
for child in node[1:]:
|
||||
_walk_effects(child, comp_name, caller_effects, anns, diagnostics)
|
||||
|
||||
241
shared/sx/ref/test-cek.sx
Normal file
241
shared/sx/ref/test-cek.sx
Normal file
@@ -0,0 +1,241 @@
|
||||
;; ==========================================================================
|
||||
;; test-cek.sx — Tests for the explicit CEK machine evaluator
|
||||
;;
|
||||
;; Tests that eval-expr-cek produces identical results to eval-expr.
|
||||
;; Requires: test-framework.sx, frames.sx, cek.sx loaded.
|
||||
;; ==========================================================================
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; 1. Literals
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(defsuite "cek-literals"
|
||||
(deftest "number"
|
||||
(assert-equal 42 (eval-expr-cek 42 (test-env))))
|
||||
|
||||
(deftest "string"
|
||||
(assert-equal "hello" (eval-expr-cek "hello" (test-env))))
|
||||
|
||||
(deftest "boolean true"
|
||||
(assert-equal true (eval-expr-cek true (test-env))))
|
||||
|
||||
(deftest "boolean false"
|
||||
(assert-equal false (eval-expr-cek false (test-env))))
|
||||
|
||||
(deftest "nil"
|
||||
(assert-nil (eval-expr-cek nil (test-env)))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; 2. Symbol lookup
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(defsuite "cek-symbols"
|
||||
(deftest "env lookup"
|
||||
(assert-equal 42
|
||||
(cek-eval "(do (define x 42) x)")))
|
||||
|
||||
(deftest "primitive call resolves"
|
||||
(assert-equal "hello"
|
||||
(cek-eval "(str \"hello\")"))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; 3. Special forms
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(defsuite "cek-if"
|
||||
(deftest "if true branch"
|
||||
(assert-equal 1
|
||||
(cek-eval "(if true 1 2)")))
|
||||
|
||||
(deftest "if false branch"
|
||||
(assert-equal 2
|
||||
(cek-eval "(if false 1 2)")))
|
||||
|
||||
(deftest "if no else"
|
||||
(assert-nil (cek-eval "(if false 1)"))))
|
||||
|
||||
|
||||
(defsuite "cek-when"
|
||||
(deftest "when true"
|
||||
(assert-equal 42
|
||||
(cek-eval "(when true 42)")))
|
||||
|
||||
(deftest "when false"
|
||||
(assert-nil (cek-eval "(when false 42)")))
|
||||
|
||||
(deftest "when multiple body"
|
||||
(assert-equal 3
|
||||
(cek-eval "(when true 1 2 3)"))))
|
||||
|
||||
|
||||
(defsuite "cek-begin"
|
||||
(deftest "do returns last"
|
||||
(assert-equal 3
|
||||
(cek-eval "(do 1 2 3)")))
|
||||
|
||||
(deftest "empty do"
|
||||
(assert-nil (cek-eval "(do)"))))
|
||||
|
||||
|
||||
(defsuite "cek-let"
|
||||
(deftest "basic let"
|
||||
(assert-equal 3
|
||||
(cek-eval "(let ((x 1) (y 2)) (+ x y))")))
|
||||
|
||||
(deftest "let body sequence"
|
||||
(assert-equal 10
|
||||
(cek-eval "(let ((x 5)) 1 2 (+ x 5))")))
|
||||
|
||||
(deftest "nested let"
|
||||
(assert-equal 5
|
||||
(cek-eval "(let ((x 1)) (let ((y 2)) (+ x y (* x y))))"))))
|
||||
|
||||
|
||||
(defsuite "cek-and-or"
|
||||
(deftest "and all true"
|
||||
(assert-equal 3
|
||||
(cek-eval "(and 1 2 3)")))
|
||||
|
||||
(deftest "and short circuit"
|
||||
(assert-false (cek-eval "(and 1 false 3)")))
|
||||
|
||||
(deftest "or first true"
|
||||
(assert-equal 1
|
||||
(cek-eval "(or 1 2 3)")))
|
||||
|
||||
(deftest "or all false"
|
||||
(assert-false (cek-eval "(or false false false)"))))
|
||||
|
||||
|
||||
(defsuite "cek-cond"
|
||||
(deftest "cond first match"
|
||||
(assert-equal "a"
|
||||
(cek-eval "(cond true \"a\" true \"b\")")))
|
||||
|
||||
(deftest "cond second match"
|
||||
(assert-equal "b"
|
||||
(cek-eval "(cond false \"a\" true \"b\")")))
|
||||
|
||||
(deftest "cond else"
|
||||
(assert-equal "c"
|
||||
(cek-eval "(cond false \"a\" :else \"c\")"))))
|
||||
|
||||
|
||||
(defsuite "cek-case"
|
||||
(deftest "case match"
|
||||
(assert-equal "yes"
|
||||
(cek-eval "(case 1 1 \"yes\" 2 \"no\")")))
|
||||
|
||||
(deftest "case no match"
|
||||
(assert-nil
|
||||
(cek-eval "(case 3 1 \"yes\" 2 \"no\")")))
|
||||
|
||||
(deftest "case else"
|
||||
(assert-equal "default"
|
||||
(cek-eval "(case 3 1 \"yes\" :else \"default\")"))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; 4. Function calls
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(defsuite "cek-calls"
|
||||
(deftest "primitive call"
|
||||
(assert-equal 3
|
||||
(cek-eval "(+ 1 2)")))
|
||||
|
||||
(deftest "nested calls"
|
||||
(assert-equal 6
|
||||
(cek-eval "(+ 1 (+ 2 3))")))
|
||||
|
||||
(deftest "lambda call"
|
||||
(assert-equal 10
|
||||
(cek-eval "((fn (x) (* x 2)) 5)")))
|
||||
|
||||
(deftest "defined function"
|
||||
(assert-equal 25
|
||||
(cek-eval "(do (define square (fn (x) (* x x))) (square 5))"))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; 5. Define and set!
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(defsuite "cek-define"
|
||||
(deftest "define binds"
|
||||
(assert-equal 42
|
||||
(cek-eval "(do (define x 42) x)")))
|
||||
|
||||
(deftest "set! mutates"
|
||||
(assert-equal 10
|
||||
(cek-eval "(do (define x 1) (set! x 10) x)"))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; 6. Quote and quasiquote
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(defsuite "cek-quote"
|
||||
(deftest "quote"
|
||||
(let ((result (cek-eval "(quote (1 2 3))")))
|
||||
(assert-equal 3 (len result))))
|
||||
|
||||
(deftest "quasiquote with unquote"
|
||||
(assert-equal (list 1 42 3)
|
||||
(cek-eval "(let ((x 42)) `(1 ,x 3))"))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; 7. Thread-first
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(defsuite "cek-thread-first"
|
||||
(deftest "simple thread"
|
||||
(assert-equal 3
|
||||
(cek-eval "(-> 1 (+ 2))")))
|
||||
|
||||
(deftest "multi-step thread"
|
||||
(assert-equal 6
|
||||
(cek-eval "(-> 1 (+ 2) (* 2))"))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; 8. CEK-specific: stepping
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(defsuite "cek-stepping"
|
||||
(deftest "single step literal"
|
||||
(let ((state (make-cek-state 42 (test-env) (list))))
|
||||
(let ((stepped (cek-step state)))
|
||||
(assert-equal "continue" (cek-phase stepped))
|
||||
(assert-equal 42 (cek-value stepped))
|
||||
(assert-true (cek-terminal? stepped)))))
|
||||
|
||||
(deftest "single step if pushes frame"
|
||||
(let ((state (make-cek-state (sx-parse-one "(if true 1 2)") (test-env) (list))))
|
||||
(let ((stepped (cek-step state)))
|
||||
(assert-equal "eval" (cek-phase stepped))
|
||||
;; Should have pushed an IfFrame
|
||||
(assert-true (> (len (cek-kont stepped)) 0))
|
||||
(assert-equal "if" (frame-type (first (cek-kont stepped))))))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; 9. Native continuations (shift/reset in CEK)
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(defsuite "cek-continuations"
|
||||
(deftest "reset passthrough"
|
||||
(assert-equal 42
|
||||
(cek-eval "(reset 42)")))
|
||||
|
||||
(deftest "shift abort"
|
||||
(assert-equal 42
|
||||
(cek-eval "(reset (+ 1 (shift k 42)))")))
|
||||
|
||||
(deftest "shift with invoke"
|
||||
(assert-equal 11
|
||||
(cek-eval "(reset (+ 1 (shift k (k 10))))"))))
|
||||
140
shared/sx/ref/test-continuations.sx
Normal file
140
shared/sx/ref/test-continuations.sx
Normal file
@@ -0,0 +1,140 @@
|
||||
;; ==========================================================================
|
||||
;; test-continuations.sx — Tests for delimited continuations (shift/reset)
|
||||
;;
|
||||
;; Requires: test-framework.sx loaded, continuations extension enabled.
|
||||
;; ==========================================================================
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; 1. Basic shift/reset
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(defsuite "basic-shift-reset"
|
||||
(deftest "reset passthrough"
|
||||
(assert-equal 42 (reset 42)))
|
||||
|
||||
(deftest "reset evaluates expression"
|
||||
(assert-equal 3 (reset (+ 1 2))))
|
||||
|
||||
(deftest "shift aborts to reset"
|
||||
(assert-equal 42 (reset (+ 1 (shift k 42)))))
|
||||
|
||||
(deftest "shift with single invoke"
|
||||
(assert-equal 11 (reset (+ 1 (shift k (k 10))))))
|
||||
|
||||
(deftest "shift with multiple invokes"
|
||||
(assert-equal (list 11 21)
|
||||
(reset (+ 1 (shift k (list (k 10) (k 20)))))))
|
||||
|
||||
(deftest "shift returns string"
|
||||
(assert-equal "aborted"
|
||||
(reset (+ 1 (shift k "aborted")))))
|
||||
|
||||
(deftest "shift returns nil"
|
||||
(assert-nil (reset (+ 1 (shift k nil)))))
|
||||
|
||||
(deftest "nested expression with shift"
|
||||
(assert-equal 16
|
||||
(+ 1 (reset (+ 10 (shift k (k 5))))))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; 2. Continuation predicates
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(defsuite "continuation-predicates"
|
||||
(deftest "k is a continuation inside shift"
|
||||
(assert-true
|
||||
(reset (shift k (continuation? k)))))
|
||||
|
||||
(deftest "number is not a continuation"
|
||||
(assert-false (continuation? 42)))
|
||||
|
||||
(deftest "function is not a continuation"
|
||||
(assert-false (continuation? (fn (x) x))))
|
||||
|
||||
(deftest "nil is not a continuation"
|
||||
(assert-false (continuation? nil)))
|
||||
|
||||
(deftest "string is not a continuation"
|
||||
(assert-false (continuation? "hello"))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; 3. Continuation as value
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(defsuite "continuation-as-value"
|
||||
(deftest "k returned from reset"
|
||||
;; shift body returns k itself — reset returns the continuation
|
||||
(let ((k (reset (+ 1 (shift k k)))))
|
||||
(assert-true (continuation? k))
|
||||
(assert-equal 11 (k 10))))
|
||||
|
||||
(deftest "invoke returned k multiple times"
|
||||
(let ((k (reset (+ 1 (shift k k)))))
|
||||
(assert-equal 11 (k 10))
|
||||
(assert-equal 21 (k 20))
|
||||
(assert-equal 2 (k 1))))
|
||||
|
||||
(deftest "pass k to another function"
|
||||
(let ((apply-k (fn (k v) (k v))))
|
||||
(assert-equal 15
|
||||
(reset (+ 5 (shift k (apply-k k 10)))))))
|
||||
|
||||
(deftest "k in data structure"
|
||||
(let ((result (reset (+ 1 (shift k (list k 42))))))
|
||||
(assert-equal 42 (nth result 1))
|
||||
(assert-equal 100 ((first result) 99)))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; 4. Nested reset
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(defsuite "nested-reset"
|
||||
(deftest "inner reset captures independently"
|
||||
(assert-equal 12
|
||||
(reset (+ 1 (reset (+ 10 (shift k (k 1))))))))
|
||||
|
||||
(deftest "inner abort outer continues"
|
||||
(assert-equal 43
|
||||
(reset (+ 1 (reset (+ 10 (shift k 42)))))))
|
||||
|
||||
(deftest "outer shift captures outer reset"
|
||||
(assert-equal 100
|
||||
(reset (+ 1 (shift k (k 99)))))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; 5. Interaction with scoped effects
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(defsuite "continuations-with-scopes"
|
||||
(deftest "provide survives resume"
|
||||
(assert-equal "dark"
|
||||
(reset (provide "theme" "dark"
|
||||
(+ 0 (shift k (k 0)))
|
||||
(context "theme")))))
|
||||
|
||||
(deftest "scope and emit across shift"
|
||||
(assert-equal (list "a")
|
||||
(reset (scope "acc"
|
||||
(emit! "acc" "a")
|
||||
(+ 0 (shift k (k 0)))
|
||||
(emitted "acc"))))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; 6. TCO interaction
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(defsuite "tco-interaction"
|
||||
(deftest "shift in tail position"
|
||||
(assert-equal 42
|
||||
(reset (if true (shift k (k 42)) 0))))
|
||||
|
||||
(deftest "shift in let body"
|
||||
(assert-equal 10
|
||||
(reset (let ((x 5))
|
||||
(+ x (shift k (k 5))))))))
|
||||
@@ -597,3 +597,56 @@
|
||||
|
||||
(deftest "nil caller allows all"
|
||||
(assert-true (effects-subset? (list "io") nil))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; build-effect-annotations
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(defsuite "build-effect-annotations"
|
||||
(deftest "builds annotations from io declarations"
|
||||
(let ((decls (list {"name" "fetch"} {"name" "save!"}))
|
||||
(anns (build-effect-annotations decls)))
|
||||
(assert-equal (list "io") (get anns "fetch"))
|
||||
(assert-equal (list "io") (get anns "save!"))))
|
||||
|
||||
(deftest "skips entries without name"
|
||||
(let ((decls (list {"name" "fetch"} {"other" "x"}))
|
||||
(anns (build-effect-annotations decls)))
|
||||
(assert-true (has-key? anns "fetch"))
|
||||
(assert-false (has-key? anns "other"))))
|
||||
|
||||
(deftest "empty declarations produce empty dict"
|
||||
(let ((anns (build-effect-annotations (list))))
|
||||
(assert-equal 0 (len (keys anns))))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; check-component-effects
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
;; Define test components at top level so they're in the main env
|
||||
(defcomp ~eff-pure-card () :effects []
|
||||
(div (fetch "url")))
|
||||
|
||||
(defcomp ~eff-io-card () :effects [io]
|
||||
(div (fetch "url")))
|
||||
|
||||
(defcomp ~eff-unannot-card ()
|
||||
(div (fetch "url")))
|
||||
|
||||
(defsuite "check-component-effects"
|
||||
(deftest "pure component calling io produces diagnostic"
|
||||
(let ((anns {"~eff-pure-card" () "fetch" ("io")})
|
||||
(diagnostics (check-component-effects "~eff-pure-card" (test-env) anns)))
|
||||
(assert-true (> (len diagnostics) 0))))
|
||||
|
||||
(deftest "io component calling io produces no diagnostic"
|
||||
(let ((anns {"~eff-io-card" ("io") "fetch" ("io")})
|
||||
(diagnostics (check-component-effects "~eff-io-card" (test-env) anns)))
|
||||
(assert-equal 0 (len diagnostics))))
|
||||
|
||||
(deftest "unannotated component skips check"
|
||||
(let ((anns {"fetch" ("io")})
|
||||
(diagnostics (check-component-effects "~eff-unannot-card" (test-env) anns)))
|
||||
(assert-equal 0 (len diagnostics)))))
|
||||
|
||||
@@ -860,6 +860,40 @@
|
||||
annotations)))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; 15. Check component effects — convenience wrapper
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Validates that components respect their declared effect annotations.
|
||||
;; Delegates to check-body-walk with nil type checking (effects only).
|
||||
|
||||
(define check-component-effects
|
||||
(fn ((comp-name :as string) env effect-annotations)
|
||||
;; Check a single component's effect usage. Returns diagnostics list.
|
||||
;; Skips type checking — only checks effect violations.
|
||||
(let ((comp (env-get env comp-name))
|
||||
(diagnostics (list)))
|
||||
(when (= (type-of comp) "component")
|
||||
(let ((body (component-body comp)))
|
||||
(check-body-walk body comp-name (dict) (dict) nil env
|
||||
diagnostics nil effect-annotations)))
|
||||
diagnostics)))
|
||||
|
||||
(define check-all-effects
|
||||
(fn (env effect-annotations)
|
||||
;; Check all components in env for effect violations.
|
||||
;; Returns list of all diagnostics.
|
||||
(let ((all-diagnostics (list)))
|
||||
(for-each
|
||||
(fn (name)
|
||||
(let ((val (env-get env name)))
|
||||
(when (= (type-of val) "component")
|
||||
(for-each
|
||||
(fn (d) (append! all-diagnostics d))
|
||||
(check-component-effects name env effect-annotations)))))
|
||||
(keys env))
|
||||
all-diagnostics)))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Platform interface summary
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
@@ -361,11 +361,15 @@ class Continuation:
|
||||
|
||||
Callable with one argument — provides the value that the shift
|
||||
expression "returns" within the delimited context.
|
||||
|
||||
_cek_data: optional dict with CEK frame data (captured frames, rest-kont)
|
||||
for continuations created by the explicit CEK machine.
|
||||
"""
|
||||
__slots__ = ("fn",)
|
||||
__slots__ = ("fn", "_cek_data")
|
||||
|
||||
def __init__(self, fn):
|
||||
self.fn = fn
|
||||
self._cek_data = None
|
||||
|
||||
def __call__(self, value=NIL):
|
||||
return self.fn(value)
|
||||
|
||||
Reference in New Issue
Block a user