diff --git a/shared/static/scripts/sx-browser.js b/shared/static/scripts/sx-browser.js index 1fc8fec..34416bf 100644 --- a/shared/static/scripts/sx-browser.js +++ b/shared/static/scripts/sx-browser.js @@ -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); } diff --git a/shared/sx/ref/bootstrap_py.py b/shared/sx/ref/bootstrap_py.py index ad4d251..57f3725 100644 --- a/shared/sx/ref/bootstrap_py.py +++ b/shared/sx/ref/bootstrap_py.py @@ -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)) diff --git a/shared/sx/ref/boundary_parser.py b/shared/sx/ref/boundary_parser.py index ee4d21f..f6fe7b5 100644 --- a/shared/sx/ref/boundary_parser.py +++ b/shared/sx/ref/boundary_parser.py @@ -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") diff --git a/shared/sx/ref/cek.sx b/shared/sx/ref/cek.sx new file mode 100644 index 0000000..addbe7e --- /dev/null +++ b/shared/sx/ref/cek.sx @@ -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))) diff --git a/shared/sx/ref/eval.sx b/shared/sx/ref/eval.sx index edd380e..6429880 100644 --- a/shared/sx/ref/eval.sx +++ b/shared/sx/ref/eval.sx @@ -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)))) ;; -------------------------------------------------------------------------- diff --git a/shared/sx/ref/frames.sx b/shared/sx/ref/frames.sx new file mode 100644 index 0000000..b7881bd --- /dev/null +++ b/shared/sx/ref/frames.sx @@ -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)))) diff --git a/shared/sx/ref/platform_py.py b/shared/sx/ref/platform_py.py index 4768a00..be63bd4 100644 --- a/shared/sx/ref/platform_py.py +++ b/shared/sx/ref/platform_py.py @@ -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 = { diff --git a/shared/sx/ref/run_cek_tests.py b/shared/sx/ref/run_cek_tests.py new file mode 100644 index 0000000..3aae5c6 --- /dev/null +++ b/shared/sx/ref/run_cek_tests.py @@ -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) diff --git a/shared/sx/ref/run_continuation_tests.py b/shared/sx/ref/run_continuation_tests.py new file mode 100644 index 0000000..8a7729e --- /dev/null +++ b/shared/sx/ref/run_continuation_tests.py @@ -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) diff --git a/shared/sx/ref/run_type_tests.py b/shared/sx/ref/run_type_tests.py index d3f4021..8a63f0f 100644 --- a/shared/sx/ref/run_type_tests.py +++ b/shared/sx/ref/run_type_tests.py @@ -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: diff --git a/shared/sx/ref/sx_ref.py b/shared/sx/ref/sx_ref.py index b23ee02..e0f476a 100644 --- a/shared/sx/ref/sx_ref.py +++ b/shared/sx/ref/sx_ref.py @@ -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) diff --git a/shared/sx/ref/test-cek.sx b/shared/sx/ref/test-cek.sx new file mode 100644 index 0000000..52ae7b9 --- /dev/null +++ b/shared/sx/ref/test-cek.sx @@ -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))))")))) diff --git a/shared/sx/ref/test-continuations.sx b/shared/sx/ref/test-continuations.sx new file mode 100644 index 0000000..0177e70 --- /dev/null +++ b/shared/sx/ref/test-continuations.sx @@ -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)))))))) diff --git a/shared/sx/ref/test-types.sx b/shared/sx/ref/test-types.sx index 688cb5d..0e7cea1 100644 --- a/shared/sx/ref/test-types.sx +++ b/shared/sx/ref/test-types.sx @@ -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))))) diff --git a/shared/sx/ref/types.sx b/shared/sx/ref/types.sx index e552757..9ed0073 100644 --- a/shared/sx/ref/types.sx +++ b/shared/sx/ref/types.sx @@ -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 ;; -------------------------------------------------------------------------- diff --git a/shared/sx/types.py b/shared/sx/types.py index db7c54b..b5e325f 100644 --- a/shared/sx/types.py +++ b/shared/sx/types.py @@ -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)