giles
3a268e7277
Some checks failed
Build and Deploy / build-and-deploy (push) Has been cancelled
Evaluator: data-first higher-order forms — ho-swap-args auto-detects (map coll fn) vs (map fn coll), both work. Threading + HO: (-> data (map fn)) dispatches through CEK HO machinery via quoted-value splice. 17 new tests in test-cek-advanced.sx. Fix plan pages: add mother-language, isolated-evaluator, rust-wasm-host to page-functions.sx plan() — were in defpage but missing from URL router. Aser error handling: pages.py now catches EvalError separately, renders visible error banner instead of silently sending empty content. All except blocks include traceback in logs. Scope primitives: register collect!/collected/clear-collected!/emitted/ emit!/context in shared/sx/primitives.py so hand-written _aser can resolve them (fixes ~cssx/flush expansion failure). New test file: shared/sx/tests/test_aser_errors.py — 19 pytest tests for error propagation through all aser control flow forms. Co-Authored-By: Claude Opus 4.6 (1M context) <noreply@anthropic.com>
2532 lines
103 KiB
Plaintext
2532 lines
103 KiB
Plaintext
;; ==========================================================================
|
|
;; evaluator.sx — The SX evaluator specification
|
|
;;
|
|
;; This is the canonical, single-file specification of SX evaluation.
|
|
;; All evaluation goes through the CEK machine (explicit control,
|
|
;; environment, and continuation). There is no tree-walk interpreter.
|
|
;;
|
|
;; Structure:
|
|
;; Part 1: CEK frames — state and continuation frame constructors
|
|
;; Part 2: Evaluation utilities — lambda/component call, keyword arg
|
|
;; parsing, macro expansion, quasiquote, definition forms
|
|
;; Part 3: CEK machine — step function, frame dispatch, call dispatch
|
|
;;
|
|
;; The evaluator is written in a restricted subset of SX that bootstrap
|
|
;; compilers (JS, Python) can transpile to native code.
|
|
;;
|
|
;; Platform interface (must be provided by each host):
|
|
;; See Part 2 section headers for type constructors, env operations,
|
|
;; and rendering primitives.
|
|
;; ==========================================================================
|
|
|
|
|
|
;; **************************************************************************
|
|
;; Part 1: CEK Frames — state, continuation, and frame constructors
|
|
;; **************************************************************************
|
|
|
|
;; --------------------------------------------------------------------------
|
|
;; 1. CEK State constructors
|
|
;; --------------------------------------------------------------------------
|
|
|
|
(define make-cek-state
|
|
(fn (control env kont)
|
|
{:control control :env env :kont kont :phase "eval" :value nil}))
|
|
|
|
(define make-cek-value
|
|
(fn (value env kont)
|
|
{:control nil :env env :kont kont :phase "continue" :value value}))
|
|
|
|
(define cek-terminal?
|
|
(fn (state)
|
|
(and (= (get state "phase") "continue")
|
|
(empty? (get state "kont")))))
|
|
|
|
(define cek-control (fn (s) (get s "control")))
|
|
(define cek-env (fn (s) (get s "env")))
|
|
(define cek-kont (fn (s) (get s "kont")))
|
|
(define cek-phase (fn (s) (get s "phase")))
|
|
(define cek-value (fn (s) (get s "value")))
|
|
|
|
|
|
;; --------------------------------------------------------------------------
|
|
;; 2. Frame constructors
|
|
;; --------------------------------------------------------------------------
|
|
;; Each frame type is a dict with a "type" key and frame-specific data.
|
|
|
|
;; IfFrame: waiting for condition value
|
|
;; After condition evaluates, choose then or else branch
|
|
(define make-if-frame
|
|
(fn (then-expr else-expr env)
|
|
{:type "if" :then then-expr :else else-expr :env env}))
|
|
|
|
;; WhenFrame: waiting for condition value
|
|
;; If truthy, evaluate body exprs sequentially
|
|
(define make-when-frame
|
|
(fn (body-exprs env)
|
|
{:type "when" :body body-exprs :env env}))
|
|
|
|
;; BeginFrame: sequential evaluation
|
|
;; Remaining expressions to evaluate after current one
|
|
(define make-begin-frame
|
|
(fn (remaining env)
|
|
{:type "begin" :remaining remaining :env env}))
|
|
|
|
;; LetFrame: binding evaluation in progress
|
|
;; name = current binding name, remaining = remaining (name val) pairs
|
|
;; body = body expressions to evaluate after all bindings
|
|
(define make-let-frame
|
|
(fn (name remaining body local)
|
|
{:type "let" :name name :remaining remaining :body body :env local}))
|
|
|
|
;; DefineFrame: waiting for value to bind
|
|
(define make-define-frame
|
|
(fn (name env has-effects effect-list)
|
|
{:type "define" :name name :env env
|
|
:has-effects has-effects :effect-list effect-list}))
|
|
|
|
;; SetFrame: waiting for value to assign
|
|
(define make-set-frame
|
|
(fn (name env)
|
|
{:type "set" :name name :env env}))
|
|
|
|
;; ArgFrame: evaluating function arguments
|
|
;; f = function value (already evaluated), evaled = already evaluated args
|
|
;; remaining = remaining arg expressions
|
|
(define make-arg-frame
|
|
(fn (f evaled remaining env raw-args head-name)
|
|
{:type "arg" :f f :evaled evaled :remaining remaining :env env
|
|
:raw-args raw-args :head-name (or head-name nil)}))
|
|
|
|
;; CallFrame: about to call with fully evaluated args
|
|
(define make-call-frame
|
|
(fn (f args env)
|
|
{:type "call" :f f :args args :env env}))
|
|
|
|
;; CondFrame: evaluating cond clauses
|
|
(define make-cond-frame
|
|
(fn (remaining env scheme?)
|
|
{:type "cond" :remaining remaining :env env :scheme scheme?}))
|
|
|
|
;; CaseFrame: evaluating case clauses
|
|
(define make-case-frame
|
|
(fn (match-val remaining env)
|
|
{:type "case" :match-val match-val :remaining remaining :env env}))
|
|
|
|
;; ThreadFirstFrame: pipe threading
|
|
(define make-thread-frame
|
|
(fn (remaining env)
|
|
{:type "thread" :remaining remaining :env env}))
|
|
|
|
;; MapFrame: higher-order map/map-indexed in progress
|
|
(define make-map-frame
|
|
(fn (f remaining results env)
|
|
{:type "map" :f f :remaining remaining :results results :env env :indexed false}))
|
|
|
|
(define make-map-indexed-frame
|
|
(fn (f remaining results env)
|
|
{:type "map" :f f :remaining remaining :results results :env env :indexed true}))
|
|
|
|
;; FilterFrame: higher-order filter in progress
|
|
(define make-filter-frame
|
|
(fn (f remaining results current-item env)
|
|
{:type "filter" :f f :remaining remaining :results results
|
|
:current-item current-item :env env}))
|
|
|
|
;; ReduceFrame: higher-order reduce in progress
|
|
(define make-reduce-frame
|
|
(fn (f remaining env)
|
|
{:type "reduce" :f f :remaining remaining :env env}))
|
|
|
|
;; ForEachFrame: higher-order for-each in progress
|
|
(define make-for-each-frame
|
|
(fn (f remaining env)
|
|
{:type "for-each" :f f :remaining remaining :env env}))
|
|
|
|
;; SomeFrame: higher-order some (short-circuit on first truthy)
|
|
(define make-some-frame
|
|
(fn (f remaining env)
|
|
{:type "some" :f f :remaining remaining :env env}))
|
|
|
|
;; EveryFrame: higher-order every? (short-circuit on first falsy)
|
|
(define make-every-frame
|
|
(fn (f remaining env)
|
|
{:type "every" :f f :remaining remaining :env env}))
|
|
|
|
;; ScopeFrame: remaining body expressions for scope special form
|
|
(define make-scope-frame
|
|
(fn (name remaining env)
|
|
{:type "scope" :name name :remaining remaining :env env}))
|
|
|
|
;; ProvideFrame: dynamic variable binding (context reads this from kont)
|
|
(define make-provide-frame
|
|
(fn (name value remaining env)
|
|
{:type "provide" :name name :value value :remaining remaining :env env}))
|
|
|
|
;; ScopeAccFrame: accumulator scope (emit! appends, emitted reads)
|
|
(define make-scope-acc-frame
|
|
(fn (name value remaining env)
|
|
{:type "scope-acc" :name name :value (or value nil)
|
|
:emitted (list) :remaining remaining :env env}))
|
|
|
|
;; ResetFrame: delimiter for shift/reset continuations
|
|
(define make-reset-frame
|
|
(fn (env)
|
|
{:type "reset" :env env}))
|
|
|
|
;; DictFrame: evaluating dict values
|
|
(define make-dict-frame
|
|
(fn (remaining results env)
|
|
{:type "dict" :remaining remaining :results results :env env}))
|
|
|
|
;; AndFrame: short-circuit and
|
|
(define make-and-frame
|
|
(fn (remaining env)
|
|
{:type "and" :remaining remaining :env env}))
|
|
|
|
;; OrFrame: short-circuit or
|
|
(define make-or-frame
|
|
(fn (remaining env)
|
|
{:type "or" :remaining remaining :env env}))
|
|
|
|
;; QuasiquoteFrame (not a real frame — QQ is handled specially)
|
|
|
|
;; DynamicWindFrame: phases of dynamic-wind
|
|
(define make-dynamic-wind-frame
|
|
(fn (phase body-thunk after-thunk env)
|
|
{:type "dynamic-wind" :phase phase
|
|
:body-thunk body-thunk :after-thunk after-thunk :env env}))
|
|
|
|
;; ReactiveResetFrame: delimiter for reactive deref-as-shift
|
|
;; Carries an update-fn that gets called with new values on re-render.
|
|
(define make-reactive-reset-frame
|
|
(fn (env update-fn first-render?)
|
|
{:type "reactive-reset" :env env :update-fn update-fn
|
|
:first-render first-render?}))
|
|
|
|
;; DerefFrame: awaiting evaluation of deref's argument
|
|
(define make-deref-frame
|
|
(fn (env)
|
|
{:type "deref" :env env}))
|
|
|
|
;; HoSetupFrame: staged evaluation of higher-order form arguments
|
|
;; ho-type is "map", "filter", "reduce", etc.
|
|
;; Evaluates args one at a time, then dispatches to the iteration frame.
|
|
(define make-ho-setup-frame
|
|
(fn (ho-type remaining-args evaled-args env)
|
|
{:type "ho-setup" :ho-type ho-type :remaining remaining-args
|
|
:evaled evaled-args :env env}))
|
|
|
|
|
|
;; --------------------------------------------------------------------------
|
|
;; 3. Frame accessors
|
|
;; --------------------------------------------------------------------------
|
|
|
|
(define frame-type (fn (f) (get f "type")))
|
|
|
|
|
|
;; --------------------------------------------------------------------------
|
|
;; 4. Continuation operations
|
|
;; --------------------------------------------------------------------------
|
|
|
|
(define kont-push
|
|
(fn (frame kont) (cons frame kont)))
|
|
|
|
(define kont-top
|
|
(fn (kont) (first kont)))
|
|
|
|
(define kont-pop
|
|
(fn (kont) (rest kont)))
|
|
|
|
(define kont-empty?
|
|
(fn (kont) (empty? kont)))
|
|
|
|
|
|
;; --------------------------------------------------------------------------
|
|
;; 5. CEK shift/reset support
|
|
;; --------------------------------------------------------------------------
|
|
;; shift captures all frames up to the nearest ResetFrame.
|
|
;; reset pushes a ResetFrame.
|
|
|
|
(define kont-capture-to-reset
|
|
(fn (kont)
|
|
;; Returns (captured-frames remaining-kont).
|
|
;; captured-frames: frames from top up to (not including) ResetFrame.
|
|
;; remaining-kont: frames after ResetFrame.
|
|
;; Stops at either "reset" or "reactive-reset" frames.
|
|
(define scan
|
|
(fn (k captured)
|
|
(if (empty? k)
|
|
(error "shift without enclosing reset")
|
|
(let ((frame (first k)))
|
|
(if (or (= (frame-type frame) "reset")
|
|
(= (frame-type frame) "reactive-reset"))
|
|
(list captured (rest k))
|
|
(scan (rest k) (append captured (list frame))))))))
|
|
(scan kont (list))))
|
|
|
|
;; Walk kont for nearest ProvideFrame with matching name
|
|
(define kont-find-provide
|
|
(fn (kont name)
|
|
(if (empty? kont) nil
|
|
(let ((frame (first kont)))
|
|
(if (and (= (frame-type frame) "provide")
|
|
(= (get frame "name") name))
|
|
frame
|
|
(kont-find-provide (rest kont) name))))))
|
|
|
|
;; Walk kont for nearest ScopeAccFrame with matching name
|
|
(define kont-find-scope-acc
|
|
(fn (kont name)
|
|
(if (empty? kont) nil
|
|
(let ((frame (first kont)))
|
|
(if (and (= (frame-type frame) "scope-acc")
|
|
(= (get frame "name") name))
|
|
frame
|
|
(kont-find-scope-acc (rest kont) name))))))
|
|
|
|
;; Check if a ReactiveResetFrame exists anywhere in the continuation
|
|
(define has-reactive-reset-frame?
|
|
(fn (kont)
|
|
(if (empty? kont) false
|
|
(if (= (frame-type (first kont)) "reactive-reset") true
|
|
(has-reactive-reset-frame? (rest kont))))))
|
|
|
|
;; Capture frames up to nearest ReactiveResetFrame.
|
|
;; Returns (captured-frames, reset-frame, remaining-kont).
|
|
(define kont-capture-to-reactive-reset
|
|
(fn (kont)
|
|
(define scan
|
|
(fn (k captured)
|
|
(if (empty? k)
|
|
(error "reactive deref without enclosing reactive-reset")
|
|
(let ((frame (first k)))
|
|
(if (= (frame-type frame) "reactive-reset")
|
|
(list captured frame (rest k))
|
|
(scan (rest k) (append captured (list frame))))))))
|
|
(scan kont (list))))
|
|
|
|
|
|
;; **************************************************************************
|
|
;; Part 2: Evaluation Utilities
|
|
;; **************************************************************************
|
|
|
|
;; --------------------------------------------------------------------------
|
|
;; 1. Types
|
|
;; --------------------------------------------------------------------------
|
|
;;
|
|
;; The evaluator operates on these value types:
|
|
;;
|
|
;; number — integer or float
|
|
;; string — double-quoted text
|
|
;; boolean — true / false
|
|
;; nil — singleton null
|
|
;; symbol — unquoted identifier (e.g. div, ~card, map)
|
|
;; keyword — colon-prefixed key (e.g. :class, :id)
|
|
;; list — ordered sequence (also used as code)
|
|
;; dict — string-keyed hash map
|
|
;; lambda — closure: {params, body, closure-env, name?}
|
|
;; macro — AST transformer: {params, rest-param, body, closure-env}
|
|
;; component — UI component: {name, params, has-children, body, closure-env}
|
|
;; island — reactive component: like component but with island flag
|
|
;; thunk — deferred eval for TCO: {expr, env}
|
|
;;
|
|
;; Each target must provide:
|
|
;; (type-of x) → one of the strings above
|
|
;; (make-lambda ...) → platform Lambda value
|
|
;; (make-component ..) → platform Component value
|
|
;; (make-island ...) → platform Island value (component + island flag)
|
|
;; (make-macro ...) → platform Macro value
|
|
;; (make-thunk ...) → platform Thunk value
|
|
;;
|
|
;; These are declared in platform.sx and implemented per target.
|
|
;; --------------------------------------------------------------------------
|
|
|
|
|
|
;; --------------------------------------------------------------------------
|
|
;; 2. Trampoline — tail-call optimization
|
|
;; --------------------------------------------------------------------------
|
|
|
|
(define trampoline
|
|
(fn ((val :as any))
|
|
;; Iteratively resolve thunks until we get an actual value.
|
|
;; Each target implements thunk? and thunk-expr/thunk-env.
|
|
(let ((result val))
|
|
(do
|
|
;; Loop while result is a thunk
|
|
;; Note: this is pseudo-iteration — bootstrap compilers convert
|
|
;; this tail-recursive form to a while loop.
|
|
(if (thunk? result)
|
|
(trampoline (eval-expr (thunk-expr result) (thunk-env result)))
|
|
result)))))
|
|
|
|
|
|
;; --------------------------------------------------------------------------
|
|
;; 2b. Strict mode — runtime type checking for primitive calls
|
|
;; --------------------------------------------------------------------------
|
|
;;
|
|
;; When *strict* is true, primitive calls check arg types before dispatch.
|
|
;; The primitive param type registry maps name → {positional [[name type]...],
|
|
;; rest-type type-or-nil}. Stored in *prim-param-types* in the env.
|
|
;;
|
|
;; Strict mode is off by default. Hosts can enable it at startup via:
|
|
;; (set-strict! true)
|
|
;; (set-prim-param-types! types-dict)
|
|
|
|
(define *strict* false)
|
|
|
|
(define set-strict!
|
|
(fn (val)
|
|
(set! *strict* val)))
|
|
|
|
(define *prim-param-types* nil)
|
|
|
|
(define set-prim-param-types!
|
|
(fn (types)
|
|
(set! *prim-param-types* types)))
|
|
|
|
(define value-matches-type?
|
|
(fn (val expected-type)
|
|
;; Check if a runtime value matches a declared type string.
|
|
(cond
|
|
(= expected-type "any") true
|
|
(= expected-type "number") (number? val)
|
|
(= expected-type "string") (string? val)
|
|
(= expected-type "boolean") (boolean? val)
|
|
(= expected-type "nil") (nil? val)
|
|
(= expected-type "list") (list? val)
|
|
(= expected-type "dict") (dict? val)
|
|
(= expected-type "lambda") (lambda? val)
|
|
(= expected-type "symbol") (= (type-of val) "symbol")
|
|
(= expected-type "keyword") (= (type-of val) "keyword")
|
|
;; Nullable: "string?" means string or nil
|
|
(and (string? expected-type)
|
|
(ends-with? expected-type "?"))
|
|
(or (nil? val)
|
|
(value-matches-type? val (slice expected-type 0 (- (string-length expected-type) 1))))
|
|
:else true)))
|
|
|
|
(define strict-check-args
|
|
(fn (name args)
|
|
;; Check args against *prim-param-types* if strict mode is on.
|
|
;; Throws on type violation. No-op if *strict* is false or types not registered.
|
|
(when (and *strict* *prim-param-types*)
|
|
(let ((spec (get *prim-param-types* name)))
|
|
(when spec
|
|
(let ((positional (get spec "positional"))
|
|
(rest-type (get spec "rest-type")))
|
|
;; Check positional params
|
|
(when positional
|
|
(for-each
|
|
(fn (pair)
|
|
(let ((idx (first pair))
|
|
(param (nth pair 1))
|
|
(p-name (first param))
|
|
(p-type (nth param 1)))
|
|
(when (< idx (len args))
|
|
(let ((val (nth args idx)))
|
|
(when (not (value-matches-type? val p-type))
|
|
(error (str "Type error: " name " expected " p-type
|
|
" for param " p-name
|
|
", got " (type-of val) " (" (str val) ")")))))))
|
|
(map-indexed (fn (i p) (list i p)) positional)))
|
|
;; Check rest args
|
|
(when (and rest-type (> (len args) (len (or positional (list)))))
|
|
(for-each
|
|
(fn (pair)
|
|
(let ((idx (first pair))
|
|
(val (nth pair 1)))
|
|
(when (not (value-matches-type? val rest-type))
|
|
(error (str "Type error: " name " expected " rest-type
|
|
" for rest arg " idx
|
|
", got " (type-of val) " (" (str val) ")")))))
|
|
(map-indexed (fn (i v) (list i v))
|
|
(slice args (len (or positional (list)))))))))))))
|
|
|
|
|
|
;; --------------------------------------------------------------------------
|
|
;; 3. Core evaluator — stub (overridden by CEK in fixups)
|
|
;; --------------------------------------------------------------------------
|
|
;;
|
|
;; eval-expr and trampoline are defined as stubs here so the transpiler
|
|
;; creates the variable declarations. The CEK fixups override them with:
|
|
;; eval-expr = (expr, env) → cek-run(make-cek-state(expr, env, []))
|
|
;; trampoline = (val) → if thunk? then eval-expr(thunk-expr, thunk-env) else val
|
|
;; All evaluation goes through the CEK machine.
|
|
|
|
;; eval-expr: forward declaration — redefined at end of file after cek-run exists.
|
|
;; This stub is needed so functions between here and Part 3 can reference eval-expr.
|
|
(define eval-expr
|
|
(fn (expr (env :as dict)) nil))
|
|
|
|
|
|
|
|
|
|
;; --------------------------------------------------------------------------
|
|
;; 5. Function / lambda / component call
|
|
;; --------------------------------------------------------------------------
|
|
|
|
(define call-lambda
|
|
(fn ((f :as lambda) (args :as list) (caller-env :as dict))
|
|
(let ((params (lambda-params f))
|
|
(local (env-merge (lambda-closure f) caller-env)))
|
|
;; Too many args is an error; too few pads with nil
|
|
(if (> (len args) (len params))
|
|
(error (str (or (lambda-name f) "lambda")
|
|
" expects " (len params) " args, got " (len args)))
|
|
(do
|
|
;; Bind params — provided args first, then nil for missing
|
|
(for-each
|
|
(fn (pair) (env-bind! local (first pair) (nth pair 1)))
|
|
(zip params args))
|
|
(for-each
|
|
(fn (p) (env-bind! local p nil))
|
|
(slice params (len args)))
|
|
;; Return thunk for TCO
|
|
(make-thunk (lambda-body f) local))))))
|
|
|
|
|
|
(define call-component
|
|
(fn ((comp :as component) (raw-args :as list) (env :as dict))
|
|
;; Parse keyword args and children from unevaluated arg list
|
|
(let ((parsed (parse-keyword-args raw-args env))
|
|
(kwargs (first parsed))
|
|
(children (nth parsed 1))
|
|
(local (env-merge (component-closure comp) env)))
|
|
;; Bind keyword params
|
|
(for-each
|
|
(fn (p) (env-bind! local p (or (dict-get kwargs p) nil)))
|
|
(component-params comp))
|
|
;; Bind children if component accepts them
|
|
(when (component-has-children? comp)
|
|
(env-bind! local "children" children))
|
|
;; Return thunk — body evaluated in local env
|
|
(make-thunk (component-body comp) local))))
|
|
|
|
|
|
(define parse-keyword-args
|
|
(fn ((raw-args :as list) (env :as dict))
|
|
;; Walk args: keyword + next-val → kwargs dict, else → children list
|
|
(let ((kwargs (dict))
|
|
(children (list))
|
|
(i 0))
|
|
;; Iterative parse — bootstrap converts to while loop
|
|
(reduce
|
|
(fn (state arg)
|
|
(let ((idx (get state "i"))
|
|
(skip (get state "skip")))
|
|
(if skip
|
|
;; This arg was consumed as a keyword value
|
|
(assoc state "skip" false "i" (inc idx))
|
|
(if (and (= (type-of arg) "keyword")
|
|
(< (inc idx) (len raw-args)))
|
|
;; Keyword: evaluate next arg and store
|
|
(do
|
|
(dict-set! kwargs (keyword-name arg)
|
|
(trampoline (eval-expr (nth raw-args (inc idx)) env)))
|
|
(assoc state "skip" true "i" (inc idx)))
|
|
;; Positional: evaluate and add to children
|
|
(do
|
|
(append! children (trampoline (eval-expr arg env)))
|
|
(assoc state "i" (inc idx)))))))
|
|
(dict "i" 0 "skip" false)
|
|
raw-args)
|
|
(list kwargs children))))
|
|
|
|
|
|
;; --------------------------------------------------------------------------
|
|
;; 6. Special forms
|
|
;; --------------------------------------------------------------------------
|
|
;; — all superseded by CEK step handlers in cek.sx
|
|
|
|
|
|
;; cond-scheme? — still needed by CEK's step-sf-cond
|
|
(define cond-scheme?
|
|
(fn ((clauses :as list))
|
|
(every? (fn (c) (and (= (type-of c) "list") (= (len c) 2)))
|
|
clauses)))
|
|
|
|
|
|
;; Named let: (let name ((x 0) (y 1)) body...)
|
|
;; Desugars to a self-recursive lambda called with initial values.
|
|
;; The loop name is bound in the body so recursive calls produce TCO thunks.
|
|
(define sf-named-let
|
|
(fn ((args :as list) (env :as dict))
|
|
(let ((loop-name (symbol-name (first args)))
|
|
(bindings (nth args 1))
|
|
(body (slice args 2))
|
|
(params (list))
|
|
(inits (list)))
|
|
;; Extract param names and init expressions
|
|
(if (and (= (type-of (first bindings)) "list")
|
|
(= (len (first bindings)) 2))
|
|
;; Scheme-style: ((x 0) (y 1))
|
|
(for-each
|
|
(fn (binding)
|
|
(append! params (if (= (type-of (first binding)) "symbol")
|
|
(symbol-name (first binding))
|
|
(first binding)))
|
|
(append! inits (nth binding 1)))
|
|
bindings)
|
|
;; Clojure-style: (x 0 y 1)
|
|
(reduce
|
|
(fn (acc pair-idx)
|
|
(do
|
|
(append! params (if (= (type-of (nth bindings (* pair-idx 2))) "symbol")
|
|
(symbol-name (nth bindings (* pair-idx 2)))
|
|
(nth bindings (* pair-idx 2))))
|
|
(append! inits (nth bindings (inc (* pair-idx 2))))))
|
|
nil
|
|
(range 0 (/ (len bindings) 2))))
|
|
;; Build loop body (wrap in begin if multiple exprs)
|
|
(let ((loop-body (if (= (len body) 1) (first body)
|
|
(cons (make-symbol "begin") body)))
|
|
(loop-fn (make-lambda params loop-body env)))
|
|
;; Self-reference: loop can call itself by name
|
|
(set-lambda-name! loop-fn loop-name)
|
|
(env-bind! (lambda-closure loop-fn) loop-name loop-fn)
|
|
;; Evaluate initial values in enclosing env, then call
|
|
(let ((init-vals (map (fn (e) (trampoline (eval-expr e env))) inits)))
|
|
(call-lambda loop-fn init-vals env))))))
|
|
|
|
|
|
(define sf-lambda
|
|
(fn ((args :as list) (env :as dict))
|
|
(let ((params-expr (first args))
|
|
(body-exprs (rest args))
|
|
(body (if (= (len body-exprs) 1)
|
|
(first body-exprs)
|
|
(cons (make-symbol "begin") body-exprs)))
|
|
(param-names (map (fn (p)
|
|
(cond
|
|
(= (type-of p) "symbol")
|
|
(symbol-name p)
|
|
;; Annotated param: (name :as type) → extract name
|
|
(and (= (type-of p) "list")
|
|
(= (len p) 3)
|
|
(= (type-of (nth p 1)) "keyword")
|
|
(= (keyword-name (nth p 1)) "as"))
|
|
(symbol-name (first p))
|
|
:else p))
|
|
params-expr)))
|
|
(make-lambda param-names body env))))
|
|
|
|
|
|
(define sf-defcomp
|
|
(fn ((args :as list) (env :as dict))
|
|
;; (defcomp ~name (params) [:affinity :client|:server] body)
|
|
;; Body is always the last element. Optional keyword annotations
|
|
;; may appear between the params list and the body.
|
|
(let ((name-sym (first args))
|
|
(params-raw (nth args 1))
|
|
(body (last args))
|
|
(comp-name (strip-prefix (symbol-name name-sym) "~"))
|
|
(parsed (parse-comp-params params-raw))
|
|
(params (first parsed))
|
|
(has-children (nth parsed 1))
|
|
(param-types (nth parsed 2))
|
|
(affinity (defcomp-kwarg args "affinity" "auto")))
|
|
(let ((comp (make-component comp-name params has-children body env affinity))
|
|
(effects (defcomp-kwarg args "effects" nil)))
|
|
;; Store type annotations if any were declared
|
|
(when (and (not (nil? param-types))
|
|
(not (empty? (keys param-types))))
|
|
(component-set-param-types! comp param-types))
|
|
;; Store effect annotation if declared
|
|
(when (not (nil? effects))
|
|
(let ((effect-list (if (= (type-of effects) "list")
|
|
(map (fn (e) (if (= (type-of e) "symbol")
|
|
(symbol-name e) (str e)))
|
|
effects)
|
|
(list (str effects))))
|
|
(effect-anns (if (env-has? env "*effect-annotations*")
|
|
(env-get env "*effect-annotations*")
|
|
(dict))))
|
|
(dict-set! effect-anns (symbol-name name-sym) effect-list)
|
|
(env-bind! env "*effect-annotations*" effect-anns)))
|
|
(env-bind! env (symbol-name name-sym) comp)
|
|
comp))))
|
|
|
|
(define defcomp-kwarg
|
|
(fn ((args :as list) (key :as string) default)
|
|
;; Search for :key value between params (index 2) and body (last).
|
|
(let ((end (- (len args) 1))
|
|
(result default))
|
|
(for-each
|
|
(fn (i)
|
|
(when (and (= (type-of (nth args i)) "keyword")
|
|
(= (keyword-name (nth args i)) key)
|
|
(< (+ i 1) end))
|
|
(let ((val (nth args (+ i 1))))
|
|
(set! result (if (= (type-of val) "keyword")
|
|
(keyword-name val) val)))))
|
|
(range 2 end 1))
|
|
result)))
|
|
|
|
(define parse-comp-params
|
|
(fn ((params-expr :as list))
|
|
;; Parse (&key param1 param2 &children) → (params has-children param-types)
|
|
;; Also accepts &rest as synonym for &children.
|
|
;; Supports typed params: (name :as type) — a 3-element list where
|
|
;; the second element is the keyword :as. Unannotated params get no
|
|
;; type entry. param-types is a dict {name → type-expr} or empty dict.
|
|
(let ((params (list))
|
|
(param-types (dict))
|
|
(has-children false)
|
|
(in-key false))
|
|
(for-each
|
|
(fn (p)
|
|
(if (and (= (type-of p) "list")
|
|
(= (len p) 3)
|
|
(= (type-of (first p)) "symbol")
|
|
(= (type-of (nth p 1)) "keyword")
|
|
(= (keyword-name (nth p 1)) "as"))
|
|
;; Typed param: (name :as type)
|
|
(let ((name (symbol-name (first p)))
|
|
(ptype (nth p 2)))
|
|
;; Convert type to string if it's a symbol
|
|
(let ((type-val (if (= (type-of ptype) "symbol")
|
|
(symbol-name ptype)
|
|
ptype)))
|
|
(when (not has-children)
|
|
(append! params name)
|
|
(dict-set! param-types name type-val))))
|
|
;; Untyped param or marker
|
|
(when (= (type-of p) "symbol")
|
|
(let ((name (symbol-name p)))
|
|
(cond
|
|
(= name "&key") (set! in-key true)
|
|
(= name "&rest") (set! has-children true)
|
|
(= name "&children") (set! has-children true)
|
|
has-children nil ;; skip params after &children/&rest
|
|
in-key (append! params name)
|
|
:else (append! params name))))))
|
|
params-expr)
|
|
(list params has-children param-types))))
|
|
|
|
|
|
(define sf-defisland
|
|
(fn ((args :as list) (env :as dict))
|
|
;; (defisland ~name (params) body)
|
|
;; Like defcomp but creates an island (reactive component).
|
|
;; Islands have the same calling convention as components but
|
|
;; render with a reactive context on the client.
|
|
(let ((name-sym (first args))
|
|
(params-raw (nth args 1))
|
|
(body (last args))
|
|
(comp-name (strip-prefix (symbol-name name-sym) "~"))
|
|
(parsed (parse-comp-params params-raw))
|
|
(params (first parsed))
|
|
(has-children (nth parsed 1)))
|
|
(let ((island (make-island comp-name params has-children body env)))
|
|
(env-bind! env (symbol-name name-sym) island)
|
|
island))))
|
|
|
|
|
|
(define sf-defmacro
|
|
(fn ((args :as list) (env :as dict))
|
|
(let ((name-sym (first args))
|
|
(params-raw (nth args 1))
|
|
(body (nth args 2))
|
|
(parsed (parse-macro-params params-raw))
|
|
(params (first parsed))
|
|
(rest-param (nth parsed 1)))
|
|
(let ((mac (make-macro params rest-param body env (symbol-name name-sym))))
|
|
(env-bind! env (symbol-name name-sym) mac)
|
|
mac))))
|
|
|
|
(define parse-macro-params
|
|
(fn ((params-expr :as list))
|
|
;; Parse (a b &rest rest) → ((a b) rest)
|
|
(let ((params (list))
|
|
(rest-param nil))
|
|
(reduce
|
|
(fn (state p)
|
|
(if (and (= (type-of p) "symbol") (= (symbol-name p) "&rest"))
|
|
(assoc state "in-rest" true)
|
|
(if (get state "in-rest")
|
|
(do (set! rest-param (if (= (type-of p) "symbol")
|
|
(symbol-name p) p))
|
|
state)
|
|
(do (append! params (if (= (type-of p) "symbol")
|
|
(symbol-name p) p))
|
|
state))))
|
|
(dict "in-rest" false)
|
|
params-expr)
|
|
(list params rest-param))))
|
|
|
|
|
|
(define sf-defstyle
|
|
(fn ((args :as list) (env :as dict))
|
|
;; (defstyle name expr) — bind name to evaluated expr (string, function, etc.)
|
|
(let ((name-sym (first args))
|
|
(value (trampoline (eval-expr (nth args 1) env))))
|
|
(env-bind! env (symbol-name name-sym) value)
|
|
value)))
|
|
|
|
|
|
;; -- deftype helpers (must be in eval.sx, not types.sx, because
|
|
;; sf-deftype is always compiled but types.sx is a spec module) --
|
|
|
|
(define make-type-def
|
|
(fn ((name :as string) (params :as list) body)
|
|
{:name name :params params :body body}))
|
|
|
|
(define normalize-type-body
|
|
(fn (body)
|
|
;; Convert AST type expressions to type representation.
|
|
;; Symbols → strings, (union ...) → (or ...), dict keys → strings.
|
|
(cond
|
|
(nil? body) "nil"
|
|
(= (type-of body) "symbol")
|
|
(symbol-name body)
|
|
(= (type-of body) "string")
|
|
body
|
|
(= (type-of body) "keyword")
|
|
(keyword-name body)
|
|
(= (type-of body) "dict")
|
|
;; Record type — normalize values
|
|
(map-dict (fn (k v) (normalize-type-body v)) body)
|
|
(= (type-of body) "list")
|
|
(if (empty? body) "any"
|
|
(let ((head (first body)))
|
|
(let ((head-name (if (= (type-of head) "symbol")
|
|
(symbol-name head) (str head))))
|
|
;; (union a b) → (or a b)
|
|
(if (= head-name "union")
|
|
(cons "or" (map normalize-type-body (rest body)))
|
|
;; (or a b), (list-of t), (-> ...) etc.
|
|
(cons head-name (map normalize-type-body (rest body)))))))
|
|
:else (str body))))
|
|
|
|
(define sf-deftype
|
|
(fn ((args :as list) (env :as dict))
|
|
;; (deftype name body) or (deftype (name a b ...) body)
|
|
(let ((name-or-form (first args))
|
|
(body-expr (nth args 1))
|
|
(type-name nil)
|
|
(type-params (list)))
|
|
;; Parse name — symbol or (symbol params...)
|
|
(if (= (type-of name-or-form) "symbol")
|
|
(set! type-name (symbol-name name-or-form))
|
|
(when (= (type-of name-or-form) "list")
|
|
(set! type-name (symbol-name (first name-or-form)))
|
|
(set! type-params
|
|
(map (fn (p) (if (= (type-of p) "symbol")
|
|
(symbol-name p) (str p)))
|
|
(rest name-or-form)))))
|
|
;; Normalize and store in *type-registry*
|
|
(let ((body (normalize-type-body body-expr))
|
|
(registry (if (env-has? env "*type-registry*")
|
|
(env-get env "*type-registry*")
|
|
(dict))))
|
|
(dict-set! registry type-name
|
|
(make-type-def type-name type-params body))
|
|
(env-bind! env "*type-registry*" registry)
|
|
nil))))
|
|
|
|
|
|
(define sf-defeffect
|
|
(fn ((args :as list) (env :as dict))
|
|
;; (defeffect name) — register an effect name
|
|
(let ((effect-name (if (= (type-of (first args)) "symbol")
|
|
(symbol-name (first args))
|
|
(str (first args))))
|
|
(registry (if (env-has? env "*effect-registry*")
|
|
(env-get env "*effect-registry*")
|
|
(list))))
|
|
(when (not (contains? registry effect-name))
|
|
(append! registry effect-name))
|
|
(env-bind! env "*effect-registry*" registry)
|
|
nil)))
|
|
|
|
|
|
(define qq-expand
|
|
(fn (template (env :as dict))
|
|
(if (not (= (type-of template) "list"))
|
|
template
|
|
(if (empty? template)
|
|
(list)
|
|
(let ((head (first template)))
|
|
(if (and (= (type-of head) "symbol") (= (symbol-name head) "unquote"))
|
|
(trampoline (eval-expr (nth template 1) env))
|
|
;; Walk children, handling splice-unquote
|
|
(reduce
|
|
(fn (result item)
|
|
(if (and (= (type-of item) "list")
|
|
(= (len item) 2)
|
|
(= (type-of (first item)) "symbol")
|
|
(= (symbol-name (first item)) "splice-unquote"))
|
|
(let ((spliced (trampoline (eval-expr (nth item 1) env))))
|
|
(if (= (type-of spliced) "list")
|
|
(concat result spliced)
|
|
(if (nil? spliced) result (concat result (list spliced)))))
|
|
(concat result (list (qq-expand item env)))))
|
|
(list)
|
|
template)))))))
|
|
|
|
|
|
;; --------------------------------------------------------------------------
|
|
;; 6c. letrec — mutually recursive local bindings
|
|
;; --------------------------------------------------------------------------
|
|
;;
|
|
;; (letrec ((even? (fn (n) (if (= n 0) true (odd? (- n 1)))))
|
|
;; (odd? (fn (n) (if (= n 0) false (even? (- n 1))))))
|
|
;; (even? 10))
|
|
;;
|
|
;; All bindings are first set to nil in the local env, then all values
|
|
;; are evaluated (so they can see each other's names), then lambda
|
|
;; closures are patched to include the final bindings.
|
|
;; --------------------------------------------------------------------------
|
|
|
|
(define sf-letrec
|
|
(fn ((args :as list) (env :as dict))
|
|
(let ((bindings (first args))
|
|
(body (rest args))
|
|
(local (env-extend env))
|
|
(names (list))
|
|
(val-exprs (list)))
|
|
;; First pass: bind all names to nil
|
|
(if (and (= (type-of (first bindings)) "list")
|
|
(= (len (first bindings)) 2))
|
|
;; Scheme-style
|
|
(for-each
|
|
(fn (binding)
|
|
(let ((vname (if (= (type-of (first binding)) "symbol")
|
|
(symbol-name (first binding))
|
|
(first binding))))
|
|
(append! names vname)
|
|
(append! val-exprs (nth binding 1))
|
|
(env-bind! local vname nil)))
|
|
bindings)
|
|
;; Clojure-style
|
|
(reduce
|
|
(fn (acc pair-idx)
|
|
(let ((vname (if (= (type-of (nth bindings (* pair-idx 2))) "symbol")
|
|
(symbol-name (nth bindings (* pair-idx 2)))
|
|
(nth bindings (* pair-idx 2))))
|
|
(val-expr (nth bindings (inc (* pair-idx 2)))))
|
|
(append! names vname)
|
|
(append! val-exprs val-expr)
|
|
(env-bind! local vname nil)))
|
|
nil
|
|
(range 0 (/ (len bindings) 2))))
|
|
;; Second pass: evaluate values (they can see each other's names)
|
|
(let ((values (map (fn (e) (trampoline (eval-expr e local))) val-exprs)))
|
|
;; Bind final values
|
|
(for-each
|
|
(fn (pair) (env-bind! local (first pair) (nth pair 1)))
|
|
(zip names values))
|
|
;; Patch lambda closures so they see the final bindings
|
|
(for-each
|
|
(fn (val)
|
|
(when (lambda? val)
|
|
(for-each
|
|
(fn (n) (env-bind! (lambda-closure val) n (env-get local n)))
|
|
names)))
|
|
values))
|
|
;; Evaluate body
|
|
(for-each
|
|
(fn (e) (trampoline (eval-expr e local)))
|
|
(slice body 0 (dec (len body))))
|
|
(make-thunk (last body) local))))
|
|
|
|
|
|
;; --------------------------------------------------------------------------
|
|
;; 6d. dynamic-wind — entry/exit guards
|
|
;; --------------------------------------------------------------------------
|
|
;;
|
|
;; (dynamic-wind before-thunk body-thunk after-thunk)
|
|
;;
|
|
;; All three are zero-argument functions (thunks):
|
|
;; 1. Call before-thunk
|
|
;; 2. Call body-thunk, capture result
|
|
;; 3. Call after-thunk (always, even on error)
|
|
;; 4. Return body result
|
|
;;
|
|
;; The wind stack is maintained so that when continuations jump across
|
|
;; dynamic-wind boundaries, the correct before/after thunks fire.
|
|
;; Without active continuations, this is equivalent to try/finally.
|
|
;;
|
|
;; Platform requirements:
|
|
;; (push-wind! before after) — push wind record onto stack
|
|
;; (pop-wind!) — pop wind record from stack
|
|
;; (call-thunk f env) — call a zero-arg function
|
|
;; --------------------------------------------------------------------------
|
|
|
|
(define sf-dynamic-wind
|
|
(fn ((args :as list) (env :as dict))
|
|
(let ((before (trampoline (eval-expr (first args) env)))
|
|
(body (trampoline (eval-expr (nth args 1) env)))
|
|
(after (trampoline (eval-expr (nth args 2) env))))
|
|
;; Delegate to platform — needs try/finally for error safety
|
|
(dynamic-wind-call before body after env))))
|
|
|
|
|
|
;; --------------------------------------------------------------------------
|
|
;; 6a2. scope — unified render-time dynamic scope primitive
|
|
;; --------------------------------------------------------------------------
|
|
;;
|
|
;; (scope name body...) or (scope name :value v body...)
|
|
;; Push a named scope with optional value and empty accumulator,
|
|
;; evaluate body, pop scope. Returns last body result.
|
|
;;
|
|
;; `provide` is sugar: (provide name value body...) = (scope name :value value body...)
|
|
|
|
(define sf-scope
|
|
(fn ((args :as list) (env :as dict))
|
|
(let ((name (trampoline (eval-expr (first args) env)))
|
|
(rest (slice args 1))
|
|
(val nil)
|
|
(body-exprs nil))
|
|
;; Check for :value keyword
|
|
(if (and (>= (len rest) 2) (= (type-of (first rest)) "keyword") (= (keyword-name (first rest)) "value"))
|
|
(do (set! val (trampoline (eval-expr (nth rest 1) env)))
|
|
(set! body-exprs (slice rest 2)))
|
|
(set! body-exprs rest))
|
|
(scope-push! name val)
|
|
(let ((result nil))
|
|
(for-each (fn (e) (set! result (trampoline (eval-expr e env)))) body-exprs)
|
|
(scope-pop! name)
|
|
result))))
|
|
|
|
|
|
;; provide — sugar for scope with a value
|
|
;; (provide name value body...) → (scope name :value value body...)
|
|
|
|
(define sf-provide
|
|
(fn ((args :as list) (env :as dict))
|
|
(let ((name (trampoline (eval-expr (first args) env)))
|
|
(val (trampoline (eval-expr (nth args 1) env)))
|
|
(body-exprs (slice args 2))
|
|
(result nil))
|
|
(scope-push! name val)
|
|
(for-each (fn (e) (set! result (trampoline (eval-expr e env)))) body-exprs)
|
|
(scope-pop! name)
|
|
result)))
|
|
|
|
|
|
;; --------------------------------------------------------------------------
|
|
;; 6b. Macro expansion
|
|
;; --------------------------------------------------------------------------
|
|
|
|
(define expand-macro
|
|
(fn ((mac :as macro) (raw-args :as list) (env :as dict))
|
|
(let ((local (env-merge (macro-closure mac) env)))
|
|
;; Bind positional params (unevaluated)
|
|
(for-each
|
|
(fn (pair)
|
|
(env-bind! local (first pair)
|
|
(if (< (nth pair 1) (len raw-args))
|
|
(nth raw-args (nth pair 1))
|
|
nil)))
|
|
(map-indexed (fn (i p) (list p i)) (macro-params mac)))
|
|
;; Bind &rest param
|
|
(when (macro-rest-param mac)
|
|
(env-bind! local (macro-rest-param mac)
|
|
(slice raw-args (len (macro-params mac)))))
|
|
;; Evaluate body → new AST
|
|
(trampoline (eval-expr (macro-body mac) local)))))
|
|
|
|
|
|
|
|
;; --------------------------------------------------------------------------
|
|
;; 8. Primitives — pure functions available in all targets
|
|
;; --------------------------------------------------------------------------
|
|
;; These are the ~80 built-in functions. Each target implements them
|
|
;; natively but they MUST have identical semantics. This section serves
|
|
;; as the specification — bootstrap compilers use it for reference.
|
|
;;
|
|
;; Primitives are NOT defined here as SX lambdas (that would be circular).
|
|
;; Instead, this is a declarative registry that bootstrap compilers read.
|
|
;; --------------------------------------------------------------------------
|
|
|
|
;; See primitives.sx for the full specification.
|
|
|
|
|
|
;; --------------------------------------------------------------------------
|
|
;; 9. Platform interface — must be provided by each target
|
|
;; --------------------------------------------------------------------------
|
|
;;
|
|
;; Type inspection:
|
|
;; (type-of x) → "number" | "string" | "boolean" | "nil"
|
|
;; | "symbol" | "keyword" | "list" | "dict"
|
|
;; | "lambda" | "component" | "macro" | "thunk"
|
|
;; | "spread"
|
|
;; (symbol-name sym) → string
|
|
;; (keyword-name kw) → string
|
|
;;
|
|
;; Constructors:
|
|
;; (make-lambda params body env) → Lambda
|
|
;; (make-component name params has-children body env affinity) → Component
|
|
;; (make-macro params rest-param body env name) → Macro
|
|
;; (make-thunk expr env) → Thunk
|
|
;;
|
|
;; Accessors:
|
|
;; (lambda-params f) → list of strings
|
|
;; (lambda-body f) → expr
|
|
;; (lambda-closure f) → env
|
|
;; (lambda-name f) → string or nil
|
|
;; (set-lambda-name! f n) → void
|
|
;; (component-params c) → list of strings
|
|
;; (component-body c) → expr
|
|
;; (component-closure c) → env
|
|
;; (component-has-children? c) → boolean
|
|
;; (component-affinity c) → "auto" | "client" | "server"
|
|
;;
|
|
;; (make-island name params has-children body env) → Island
|
|
;; (island? x) → boolean
|
|
;; ;; Islands reuse component accessors: component-params, component-body, etc.
|
|
;;
|
|
;; (make-spread attrs) → Spread (attrs dict injected onto parent element)
|
|
;; (spread? x) → boolean
|
|
;; (spread-attrs s) → dict
|
|
;;
|
|
;; (macro-params m) → list of strings
|
|
;; (macro-rest-param m) → string or nil
|
|
;; (macro-body m) → expr
|
|
;; (macro-closure m) → env
|
|
;; (thunk? x) → boolean
|
|
;; (thunk-expr t) → expr
|
|
;; (thunk-env t) → env
|
|
;;
|
|
;; Predicates:
|
|
;; (callable? x) → boolean (native function or lambda)
|
|
;; (lambda? x) → boolean
|
|
;; (component? x) → boolean
|
|
;; (island? x) → boolean
|
|
;; (macro? x) → boolean
|
|
;; (primitive? name) → boolean (is name a registered primitive?)
|
|
;; (get-primitive name) → function
|
|
;;
|
|
;; Environment:
|
|
;; (env-has? env name) → boolean
|
|
;; (env-get env name) → value
|
|
;; (env-bind! env name val) → void (create binding on THIS env, no chain walk)
|
|
;; (env-set! env name val) → void (mutate existing binding, walks scope chain)
|
|
;; (env-extend env) → new env inheriting from env
|
|
;; (env-merge base overlay) → new env with overlay on top
|
|
;;
|
|
;; Mutation helpers (for parse-keyword-args):
|
|
;; (dict-set! d key val) → void
|
|
;; (dict-get d key) → value or nil
|
|
;; (append! lst val) → void (mutating append)
|
|
;;
|
|
;; Error:
|
|
;; (error msg) → raise/throw with message
|
|
;; (inspect x) → string representation for debugging
|
|
;;
|
|
;; Utility:
|
|
;; (strip-prefix s prefix) → string with prefix removed (or s unchanged)
|
|
;; (apply f args) → call f with args list
|
|
;; (zip lists...) → list of tuples
|
|
;;
|
|
;;
|
|
;; Dynamic wind (for dynamic-wind):
|
|
;; (push-wind! before after) → void (push wind record onto stack)
|
|
;; (pop-wind!) → void (pop wind record from stack)
|
|
;; (call-thunk f env) → value (call a zero-arg function)
|
|
;;
|
|
;; Render-time accumulators:
|
|
;; (collect! bucket value) → void (add to named bucket, deduplicated)
|
|
;; (collected bucket) → list (all values in bucket)
|
|
;; (clear-collected! bucket) → void (empty the bucket)
|
|
;; --------------------------------------------------------------------------
|
|
|
|
|
|
;; **************************************************************************
|
|
;; Part 3: CEK Machine — the sole evaluator
|
|
;; **************************************************************************
|
|
|
|
;; --------------------------------------------------------------------------
|
|
;; 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)
|
|
|
|
;; Reactive deref-as-shift
|
|
(= name "deref") (step-sf-deref args env kont)
|
|
|
|
;; Scoped effects — frame-based dynamic scope
|
|
(= name "scope") (step-sf-scope args env kont)
|
|
(= name "provide") (step-sf-provide args env kont)
|
|
(= name "context") (step-sf-context args env kont)
|
|
(= name "emit!") (step-sf-emit args env kont)
|
|
(= name "emitted") (step-sf-emitted 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") (step-ho-map-indexed args env kont)
|
|
(= name "filter") (step-ho-filter args env kont)
|
|
(= name "reduce") (step-ho-reduce args env kont)
|
|
(= name "some") (step-ho-some args env kont)
|
|
(= name "every?") (step-ho-every args 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
|
|
;; scope: push ScopeAccFrame, evaluate body. emit!/emitted walk kont.
|
|
;; (scope name body...) or (scope name :value v body...)
|
|
(define step-sf-scope
|
|
(fn (args env kont)
|
|
(let ((name (trampoline (eval-expr (first args) env)))
|
|
(rest-args (slice args 1))
|
|
(val nil)
|
|
(body nil))
|
|
;; Check for :value keyword
|
|
(if (and (>= (len rest-args) 2)
|
|
(= (type-of (first rest-args)) "keyword")
|
|
(= (keyword-name (first rest-args)) "value"))
|
|
(do (set! val (trampoline (eval-expr (nth rest-args 1) env)))
|
|
(set! body (slice rest-args 2)))
|
|
(set! body rest-args))
|
|
;; Push ScopeAccFrame and start evaluating body
|
|
(if (empty? body)
|
|
(make-cek-value nil env kont)
|
|
(if (= (len body) 1)
|
|
(make-cek-state (first body) env
|
|
(kont-push (make-scope-acc-frame name val (list) env) kont))
|
|
(make-cek-state (first body) env
|
|
(kont-push
|
|
(make-scope-acc-frame name val (rest body) env)
|
|
kont)))))))
|
|
|
|
;; provide: push ProvideFrame, evaluate body. context walks kont to read.
|
|
;; (provide name value body...)
|
|
(define step-sf-provide
|
|
(fn (args env kont)
|
|
(let ((name (trampoline (eval-expr (first args) env)))
|
|
(val (trampoline (eval-expr (nth args 1) env)))
|
|
(body (slice args 2)))
|
|
;; Push ProvideFrame and start evaluating body
|
|
(if (empty? body)
|
|
(make-cek-value nil env kont)
|
|
(if (= (len body) 1)
|
|
(make-cek-state (first body) env
|
|
(kont-push (make-provide-frame name val (list) env) kont))
|
|
(make-cek-state (first body) env
|
|
(kont-push
|
|
(make-provide-frame name val (rest body) env)
|
|
kont)))))))
|
|
|
|
;; context: walk kont for nearest ProvideFrame with matching name
|
|
(define step-sf-context
|
|
(fn (args env kont)
|
|
(let ((name (trampoline (eval-expr (first args) env)))
|
|
(default-val (if (>= (len args) 2)
|
|
(trampoline (eval-expr (nth args 1) env))
|
|
nil))
|
|
(frame (kont-find-provide kont name)))
|
|
(if frame
|
|
(make-cek-value (get frame "value") env kont)
|
|
(if (>= (len args) 2)
|
|
(make-cek-value default-val env kont)
|
|
(error (str "No provider for: " name)))))))
|
|
|
|
;; emit!: walk kont for nearest ScopeAccFrame, append value
|
|
(define step-sf-emit
|
|
(fn (args env kont)
|
|
(let ((name (trampoline (eval-expr (first args) env)))
|
|
(val (trampoline (eval-expr (nth args 1) env)))
|
|
(frame (kont-find-scope-acc kont name)))
|
|
(if frame
|
|
(do (append! (get frame "emitted") val)
|
|
(make-cek-value nil env kont))
|
|
(error (str "No scope for emit!: " name))))))
|
|
|
|
;; emitted: walk kont for nearest ScopeAccFrame, return accumulated list
|
|
(define step-sf-emitted
|
|
(fn (args env kont)
|
|
(let ((name (trampoline (eval-expr (first args) env)))
|
|
(frame (kont-find-scope-acc kont name)))
|
|
(if frame
|
|
(make-cek-value (get frame "emitted") env kont)
|
|
(error (str "No scope for emitted: " name))))))
|
|
|
|
;; 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-bind! shift-env k-name k)
|
|
(make-cek-state body shift-env rest-kont))))))
|
|
|
|
|
|
;; deref: evaluate argument, push DerefFrame
|
|
(define step-sf-deref
|
|
(fn (args env kont)
|
|
(make-cek-state
|
|
(first args) env
|
|
(kont-push (make-deref-frame env) kont))))
|
|
|
|
;; cek-call — call a function via CEK (replaces invoke)
|
|
(define cek-call
|
|
(fn (f args)
|
|
(let ((a (if (nil? args) (list) args)))
|
|
(cond
|
|
(nil? f) nil
|
|
(lambda? f) (cek-run (continue-with-call f a (dict) a (list)))
|
|
(callable? f) (apply f a)
|
|
:else nil))))
|
|
|
|
;; reactive-shift-deref: the heart of deref-as-shift
|
|
;; When deref encounters a signal inside a reactive-reset boundary,
|
|
;; capture the continuation up to the reactive-reset as the subscriber.
|
|
(define reactive-shift-deref
|
|
(fn (sig env kont)
|
|
(let ((scan-result (kont-capture-to-reactive-reset kont))
|
|
(captured-frames (first scan-result))
|
|
(reset-frame (nth scan-result 1))
|
|
(remaining-kont (nth scan-result 2))
|
|
(update-fn (get reset-frame "update-fn")))
|
|
;; Sub-scope for nested subscriber cleanup on re-invocation
|
|
(let ((sub-disposers (list)))
|
|
(let ((subscriber
|
|
(fn ()
|
|
;; Dispose previous nested subscribers
|
|
(for-each (fn (d) (cek-call d nil)) sub-disposers)
|
|
(set! sub-disposers (list))
|
|
;; Re-invoke: push fresh ReactiveResetFrame (first-render=false)
|
|
(let ((new-reset (make-reactive-reset-frame env update-fn false))
|
|
(new-kont (concat captured-frames
|
|
(list new-reset)
|
|
remaining-kont)))
|
|
(with-island-scope
|
|
(fn (d) (append! sub-disposers d))
|
|
(fn ()
|
|
(cek-run
|
|
(make-cek-value (signal-value sig) env new-kont))))))))
|
|
;; Register subscriber
|
|
(signal-add-sub! sig subscriber)
|
|
;; Register cleanup with island scope
|
|
(register-in-scope
|
|
(fn ()
|
|
(signal-remove-sub! sig subscriber)
|
|
(for-each (fn (d) (cek-call d nil)) sub-disposers)))
|
|
;; Initial render: value flows through captured frames + reset (first-render=true)
|
|
;; so the full expression completes normally
|
|
(let ((initial-kont (concat captured-frames
|
|
(list reset-frame)
|
|
remaining-kont)))
|
|
(make-cek-value (signal-value sig) env initial-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
|
|
;; Preserve head name for strict mode type checking
|
|
(let ((hname (if (= (type-of head) "symbol") (symbol-name head) nil)))
|
|
(make-cek-state
|
|
head env
|
|
(kont-push
|
|
(make-arg-frame nil (list) args env args hname)
|
|
kont)))))
|
|
|
|
|
|
;; --------------------------------------------------------------------------
|
|
;; 7. Higher-order form step handlers
|
|
;; --------------------------------------------------------------------------
|
|
|
|
;; CEK-native higher-order forms — each callback invocation goes through
|
|
;; continue-with-call so deref-as-shift works inside callbacks.
|
|
;; Function and collection args are evaluated via tree-walk (simple exprs),
|
|
;; then the loop is driven by CEK frames.
|
|
|
|
;; HO step handlers — push HoSetupFrame to evaluate args via CEK
|
|
;; (no nested eval-expr calls). When all args are evaluated, the
|
|
;; HoSetupFrame dispatch in step-continue sets up the iteration frame.
|
|
|
|
;; ho-form-name? — is this symbol name a higher-order special form?
|
|
(define ho-form-name?
|
|
(fn (name)
|
|
(or (= name "map") (= name "map-indexed") (= name "filter")
|
|
(= name "reduce") (= name "some") (= name "every?")
|
|
(= name "for-each"))))
|
|
|
|
;; ho-fn? — is this value usable as a HO callback?
|
|
(define ho-fn?
|
|
(fn (v) (or (callable? v) (lambda? v))))
|
|
|
|
;; ho-swap-args: normalise data-first arg order
|
|
;; 2-arg forms: (coll fn) → (fn coll)
|
|
;; 3-arg reduce: (coll fn init) → (fn init coll)
|
|
(define ho-swap-args
|
|
(fn (ho-type evaled)
|
|
(if (= ho-type "reduce")
|
|
(let ((a (first evaled))
|
|
(b (nth evaled 1)))
|
|
(if (and (not (ho-fn? a)) (ho-fn? b))
|
|
(list b (nth evaled 2) a)
|
|
evaled))
|
|
(let ((a (first evaled))
|
|
(b (nth evaled 1)))
|
|
(if (and (not (ho-fn? a)) (ho-fn? b))
|
|
(list b a)
|
|
evaled)))))
|
|
|
|
;; ho-setup-dispatch: all HO args evaluated, set up iteration
|
|
(define ho-setup-dispatch
|
|
(fn (ho-type evaled env kont)
|
|
(let ((ordered (ho-swap-args ho-type evaled)))
|
|
(let ((f (first ordered)))
|
|
(cond
|
|
(= ho-type "map")
|
|
(let ((coll (nth ordered 1)))
|
|
(if (empty? coll)
|
|
(make-cek-value (list) env kont)
|
|
(continue-with-call f (list (first coll)) env (list)
|
|
(kont-push (make-map-frame f (rest coll) (list) env) kont))))
|
|
|
|
(= ho-type "map-indexed")
|
|
(let ((coll (nth ordered 1)))
|
|
(if (empty? coll)
|
|
(make-cek-value (list) env kont)
|
|
(continue-with-call f (list 0 (first coll)) env (list)
|
|
(kont-push (make-map-indexed-frame f (rest coll) (list) env) kont))))
|
|
|
|
(= ho-type "filter")
|
|
(let ((coll (nth ordered 1)))
|
|
(if (empty? coll)
|
|
(make-cek-value (list) env kont)
|
|
(continue-with-call f (list (first coll)) env (list)
|
|
(kont-push (make-filter-frame f (rest coll) (list) (first coll) env) kont))))
|
|
|
|
(= ho-type "reduce")
|
|
(let ((init (nth ordered 1))
|
|
(coll (nth ordered 2)))
|
|
(if (empty? coll)
|
|
(make-cek-value init env kont)
|
|
(continue-with-call f (list init (first coll)) env (list)
|
|
(kont-push (make-reduce-frame f (rest coll) env) kont))))
|
|
|
|
(= ho-type "some")
|
|
(let ((coll (nth ordered 1)))
|
|
(if (empty? coll)
|
|
(make-cek-value false env kont)
|
|
(continue-with-call f (list (first coll)) env (list)
|
|
(kont-push (make-some-frame f (rest coll) env) kont))))
|
|
|
|
(= ho-type "every")
|
|
(let ((coll (nth ordered 1)))
|
|
(if (empty? coll)
|
|
(make-cek-value true env kont)
|
|
(continue-with-call f (list (first coll)) env (list)
|
|
(kont-push (make-every-frame f (rest coll) env) kont))))
|
|
|
|
(= ho-type "for-each")
|
|
(let ((coll (nth ordered 1)))
|
|
(if (empty? coll)
|
|
(make-cek-value nil env kont)
|
|
(continue-with-call f (list (first coll)) env (list)
|
|
(kont-push (make-for-each-frame f (rest coll) env) kont))))
|
|
|
|
:else (error (str "Unknown HO type: " ho-type)))))))
|
|
|
|
(define step-ho-map
|
|
(fn (args env kont)
|
|
(make-cek-state (first args) env
|
|
(kont-push (make-ho-setup-frame "map" (rest args) (list) env) kont))))
|
|
|
|
(define step-ho-map-indexed
|
|
(fn (args env kont)
|
|
(make-cek-state (first args) env
|
|
(kont-push (make-ho-setup-frame "map-indexed" (rest args) (list) env) kont))))
|
|
|
|
(define step-ho-filter
|
|
(fn (args env kont)
|
|
(make-cek-state (first args) env
|
|
(kont-push (make-ho-setup-frame "filter" (rest args) (list) env) kont))))
|
|
|
|
(define step-ho-reduce
|
|
(fn (args env kont)
|
|
(make-cek-state (first args) env
|
|
(kont-push (make-ho-setup-frame "reduce" (rest args) (list) env) kont))))
|
|
|
|
(define step-ho-some
|
|
(fn (args env kont)
|
|
(make-cek-state (first args) env
|
|
(kont-push (make-ho-setup-frame "some" (rest args) (list) env) kont))))
|
|
|
|
(define step-ho-every
|
|
(fn (args env kont)
|
|
(make-cek-state (first args) env
|
|
(kont-push (make-ho-setup-frame "every" (rest args) (list) env) kont))))
|
|
|
|
(define step-ho-for-each
|
|
(fn (args env kont)
|
|
(make-cek-state (first args) env
|
|
(kont-push (make-ho-setup-frame "for-each" (rest args) (list) 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-bind! 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-bind! 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-bind! 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))
|
|
(new-kont (if (empty? (rest remaining)) rest-k
|
|
(kont-push (make-thread-frame (rest remaining) fenv) rest-k))))
|
|
;; Check if form is a HO call like (map fn)
|
|
(if (and (= (type-of form) "list")
|
|
(not (empty? form))
|
|
(= (type-of (first form)) "symbol")
|
|
(ho-form-name? (symbol-name (first form))))
|
|
;; HO form — splice value as quoted arg, dispatch via CEK
|
|
(make-cek-state
|
|
(cons (first form) (cons (list 'quote value) (rest form)))
|
|
fenv new-kont)
|
|
;; Normal: tree-walk eval + apply
|
|
(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"))
|
|
(hname (get frame "head-name")))
|
|
(if (nil? f)
|
|
;; Head just evaluated — value is the function
|
|
(do
|
|
;; Strict mode: check arg types for named primitives
|
|
(when (and *strict* hname)
|
|
(strict-check-args hname (list)))
|
|
(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 hname)
|
|
rest-k))))
|
|
;; An arg was evaluated — accumulate
|
|
(let ((new-evaled (append evaled (list value))))
|
|
(if (empty? remaining)
|
|
;; All args evaluated — strict check then call
|
|
(do
|
|
(when (and *strict* hname)
|
|
(strict-check-args hname new-evaled))
|
|
(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 hname)
|
|
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))))))
|
|
|
|
;; --- HoSetupFrame: evaluating HO form arguments ---
|
|
(= ft "ho-setup")
|
|
(let ((ho-type (get frame "ho-type"))
|
|
(remaining (get frame "remaining"))
|
|
(evaled (append (get frame "evaled") (list value)))
|
|
(fenv (get frame "env")))
|
|
(if (empty? remaining)
|
|
;; All args evaluated — dispatch to iteration
|
|
(ho-setup-dispatch ho-type evaled fenv rest-k)
|
|
;; More args to evaluate
|
|
(make-cek-state
|
|
(first remaining) fenv
|
|
(kont-push
|
|
(make-ho-setup-frame ho-type (rest remaining) evaled fenv)
|
|
rest-k))))
|
|
|
|
;; --- ResetFrame: body evaluated normally (no shift) ---
|
|
(= ft "reset")
|
|
(make-cek-value value env rest-k)
|
|
|
|
;; --- DerefFrame: deref argument evaluated ---
|
|
(= ft "deref")
|
|
(let ((val value)
|
|
(fenv (get frame "env")))
|
|
(if (not (signal? val))
|
|
;; Not a signal: pass through
|
|
(make-cek-value val fenv rest-k)
|
|
;; Signal: check for ReactiveResetFrame
|
|
(if (has-reactive-reset-frame? rest-k)
|
|
;; Perform reactive shift
|
|
(reactive-shift-deref val fenv rest-k)
|
|
;; No reactive-reset: normal deref (scope-based tracking)
|
|
(do
|
|
(let ((ctx (context "sx-reactive" nil)))
|
|
(when ctx
|
|
(let ((dep-list (get ctx "deps"))
|
|
(notify-fn (get ctx "notify")))
|
|
(when (not (contains? dep-list val))
|
|
(append! dep-list val)
|
|
(signal-add-sub! val notify-fn)))))
|
|
(make-cek-value (signal-value val) fenv rest-k)))))
|
|
|
|
;; --- ReactiveResetFrame: expression completed ---
|
|
(= ft "reactive-reset")
|
|
(let ((update-fn (get frame "update-fn"))
|
|
(first? (get frame "first-render")))
|
|
;; On re-render (not first), call update-fn with new value
|
|
(when (and update-fn (not first?))
|
|
(cek-call update-fn (list value)))
|
|
(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))))
|
|
|
|
;; --- ProvideFrame: body expression evaluated ---
|
|
(= ft "provide")
|
|
(let ((remaining (get frame "remaining"))
|
|
(fenv (get frame "env")))
|
|
(if (empty? remaining)
|
|
;; Body done — return value, frame consumed
|
|
(make-cek-value value fenv rest-k)
|
|
;; More body expressions — keep frame on kont
|
|
(make-cek-state
|
|
(first remaining) fenv
|
|
(kont-push
|
|
(make-provide-frame
|
|
(get frame "name") (get frame "value")
|
|
(rest remaining) fenv)
|
|
rest-k))))
|
|
|
|
;; --- ScopeAccFrame: body expression evaluated ---
|
|
(= ft "scope-acc")
|
|
(let ((remaining (get frame "remaining"))
|
|
(fenv (get frame "env")))
|
|
(if (empty? remaining)
|
|
;; Body done — return value, frame consumed
|
|
(make-cek-value value fenv rest-k)
|
|
;; More body expressions — carry emitted list forward
|
|
(make-cek-state
|
|
(first remaining) fenv
|
|
(kont-push
|
|
(let ((new-frame (make-scope-acc-frame
|
|
(get frame "name") (get frame "value")
|
|
(rest remaining) fenv)))
|
|
;; Preserve accumulated emitted from current frame
|
|
(dict-set! new-frame "emitted" (get frame "emitted"))
|
|
new-frame)
|
|
rest-k))))
|
|
|
|
;; --- MapFrame: callback result for map/map-indexed ---
|
|
(= ft "map")
|
|
(let ((f (get frame "f"))
|
|
(remaining (get frame "remaining"))
|
|
(results (get frame "results"))
|
|
(indexed (get frame "indexed"))
|
|
(fenv (get frame "env")))
|
|
(let ((new-results (append results (list value))))
|
|
(if (empty? remaining)
|
|
(make-cek-value new-results fenv rest-k)
|
|
(let ((call-args (if indexed
|
|
(list (len new-results) (first remaining))
|
|
(list (first remaining))))
|
|
(next-frame (if indexed
|
|
(make-map-indexed-frame f (rest remaining) new-results fenv)
|
|
(make-map-frame f (rest remaining) new-results fenv))))
|
|
(continue-with-call f call-args fenv (list)
|
|
(kont-push next-frame rest-k))))))
|
|
|
|
;; --- FilterFrame: predicate result ---
|
|
(= ft "filter")
|
|
(let ((f (get frame "f"))
|
|
(remaining (get frame "remaining"))
|
|
(results (get frame "results"))
|
|
(current-item (get frame "current-item"))
|
|
(fenv (get frame "env")))
|
|
(let ((new-results (if value
|
|
(append results (list current-item))
|
|
results)))
|
|
(if (empty? remaining)
|
|
(make-cek-value new-results fenv rest-k)
|
|
(continue-with-call f (list (first remaining)) fenv (list)
|
|
(kont-push (make-filter-frame f (rest remaining) new-results (first remaining) fenv) rest-k)))))
|
|
|
|
;; --- ReduceFrame: accumulator step ---
|
|
(= ft "reduce")
|
|
(let ((f (get frame "f"))
|
|
(remaining (get frame "remaining"))
|
|
(fenv (get frame "env")))
|
|
(if (empty? remaining)
|
|
(make-cek-value value fenv rest-k)
|
|
(continue-with-call f (list value (first remaining)) fenv (list)
|
|
(kont-push (make-reduce-frame f (rest remaining) fenv) rest-k))))
|
|
|
|
;; --- ForEachFrame: side effect, discard result ---
|
|
(= ft "for-each")
|
|
(let ((f (get frame "f"))
|
|
(remaining (get frame "remaining"))
|
|
(fenv (get frame "env")))
|
|
(if (empty? remaining)
|
|
(make-cek-value nil fenv rest-k)
|
|
(continue-with-call f (list (first remaining)) fenv (list)
|
|
(kont-push (make-for-each-frame f (rest remaining) fenv) rest-k))))
|
|
|
|
;; --- SomeFrame: short-circuit on first truthy ---
|
|
(= ft "some")
|
|
(let ((f (get frame "f"))
|
|
(remaining (get frame "remaining"))
|
|
(fenv (get frame "env")))
|
|
(if value
|
|
(make-cek-value value fenv rest-k)
|
|
(if (empty? remaining)
|
|
(make-cek-value false fenv rest-k)
|
|
(continue-with-call f (list (first remaining)) fenv (list)
|
|
(kont-push (make-some-frame f (rest remaining) fenv) rest-k)))))
|
|
|
|
;; --- EveryFrame: short-circuit on first falsy ---
|
|
(= ft "every")
|
|
(let ((f (get frame "f"))
|
|
(remaining (get frame "remaining"))
|
|
(fenv (get frame "env")))
|
|
(if (not value)
|
|
(make-cek-value false fenv rest-k)
|
|
(if (empty? remaining)
|
|
(make-cek-value true fenv rest-k)
|
|
(continue-with-call f (list (first remaining)) fenv (list)
|
|
(kont-push (make-every-frame f (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 — run captured delimited continuation, return result to caller.
|
|
;; Multi-shot: each invocation runs captured frames to completion via nested
|
|
;; cek-run, then returns the result to the caller's kont.
|
|
(continuation? f)
|
|
(let ((arg (if (empty? args) nil (first args)))
|
|
(cont-data (continuation-data f)))
|
|
(let ((captured (get cont-data "captured")))
|
|
;; Run ONLY the captured frames (delimited by reset).
|
|
;; Empty kont after captured = the continuation terminates and returns.
|
|
(let ((result (cek-run (make-cek-value arg env captured))))
|
|
(make-cek-value result env kont))))
|
|
|
|
;; 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-bind! local (first pair) (nth pair 1)))
|
|
(zip params args))
|
|
(for-each
|
|
(fn (p) (env-bind! 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-bind! local p (or (dict-get kwargs p) nil)))
|
|
(component-params f))
|
|
(when (component-has-children? f)
|
|
(env-bind! 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)))
|
|
|
|
|
|
|
|
;; --------------------------------------------------------------------------
|
|
;; 13. Freeze scopes — named serializable state boundaries
|
|
;; --------------------------------------------------------------------------
|
|
;;
|
|
;; A freeze scope collects signals registered within it. On freeze,
|
|
;; their current values are serialized to SX. On thaw, values are
|
|
;; restored. Multiple named scopes can coexist independently.
|
|
;;
|
|
;; Uses the scoped effects system: scope-push!/scope-pop!/context.
|
|
;;
|
|
;; Usage:
|
|
;; (freeze-scope "editor"
|
|
;; (let ((doc (signal "hello")))
|
|
;; (freeze-signal "doc" doc)
|
|
;; ...))
|
|
;;
|
|
;; (cek-freeze-scope "editor") → {:name "editor" :signals {:doc "hello"}}
|
|
;; (cek-thaw-scope "editor" frozen-data) → restores signal values
|
|
|
|
;; Registry of freeze scopes: name → list of {name signal} entries
|
|
(define freeze-registry (dict))
|
|
|
|
;; Register a signal in the current freeze scope
|
|
(define freeze-signal :effects [mutation]
|
|
(fn (name sig)
|
|
(let ((scope-name (context "sx-freeze-scope" nil)))
|
|
(when scope-name
|
|
(let ((entries (or (get freeze-registry scope-name) (list))))
|
|
(append! entries (dict "name" name "signal" sig))
|
|
(dict-set! freeze-registry scope-name entries))))))
|
|
|
|
;; Freeze scope delimiter — collects signals registered within body
|
|
(define freeze-scope :effects [mutation]
|
|
(fn (name body-fn)
|
|
(scope-push! "sx-freeze-scope" name)
|
|
;; Initialize empty entry list for this scope
|
|
(dict-set! freeze-registry name (list))
|
|
(cek-call body-fn nil)
|
|
(scope-pop! "sx-freeze-scope")
|
|
nil))
|
|
|
|
;; Freeze a named scope → SX dict of signal values
|
|
(define cek-freeze-scope :effects []
|
|
(fn (name)
|
|
(let ((entries (or (get freeze-registry name) (list)))
|
|
(signals-dict (dict)))
|
|
(for-each (fn (entry)
|
|
(dict-set! signals-dict
|
|
(get entry "name")
|
|
(signal-value (get entry "signal"))))
|
|
entries)
|
|
(dict "name" name "signals" signals-dict))))
|
|
|
|
;; Freeze all scopes
|
|
(define cek-freeze-all :effects []
|
|
(fn ()
|
|
(map (fn (name) (cek-freeze-scope name))
|
|
(keys freeze-registry))))
|
|
|
|
;; Thaw a named scope — restore signal values from frozen data
|
|
(define cek-thaw-scope :effects [mutation]
|
|
(fn (name frozen)
|
|
(let ((entries (or (get freeze-registry name) (list)))
|
|
(values (get frozen "signals")))
|
|
(when values
|
|
(for-each (fn (entry)
|
|
(let ((sig-name (get entry "name"))
|
|
(sig (get entry "signal"))
|
|
(val (get values sig-name)))
|
|
(when (not (nil? val))
|
|
(reset! sig val))))
|
|
entries)))))
|
|
|
|
;; Thaw all scopes from a list of frozen scope dicts
|
|
(define cek-thaw-all :effects [mutation]
|
|
(fn (frozen-list)
|
|
(for-each (fn (frozen)
|
|
(cek-thaw-scope (get frozen "name") frozen))
|
|
frozen-list)))
|
|
|
|
;; Serialize a frozen scope to SX text
|
|
(define freeze-to-sx :effects []
|
|
(fn (name)
|
|
(sx-serialize (cek-freeze-scope name))))
|
|
|
|
;; Restore from SX text
|
|
(define thaw-from-sx :effects [mutation]
|
|
(fn (sx-text)
|
|
(let ((parsed (sx-parse sx-text)))
|
|
(when (not (empty? parsed))
|
|
(let ((frozen (first parsed)))
|
|
(cek-thaw-scope (get frozen "name") frozen))))))
|
|
|
|
|
|
|
|
|
|
;; --------------------------------------------------------------------------
|
|
;; 14. Content-addressed computation
|
|
;; --------------------------------------------------------------------------
|
|
;;
|
|
;; Hash frozen SX to a content identifier. Store and retrieve by CID.
|
|
;; The content IS the address — same SX always produces the same CID.
|
|
;;
|
|
;; Uses an in-memory content store. Applications can persist to
|
|
;; localStorage or IPFS by providing their own store backend.
|
|
|
|
(define content-store (dict))
|
|
|
|
(define content-hash :effects []
|
|
(fn (sx-text)
|
|
;; djb2 hash → hex string. Simple, deterministic, fast.
|
|
;; Real deployment would use SHA-256 / multihash.
|
|
(let ((hash 5381))
|
|
(for-each (fn (i)
|
|
(set! hash (mod (+ (* hash 33) (char-code-at sx-text i)) 4294967296)))
|
|
(range 0 (len sx-text)))
|
|
(to-hex hash))))
|
|
|
|
(define content-put :effects [mutation]
|
|
(fn (sx-text)
|
|
(let ((cid (content-hash sx-text)))
|
|
(dict-set! content-store cid sx-text)
|
|
cid)))
|
|
|
|
(define content-get :effects []
|
|
(fn (cid)
|
|
(get content-store cid)))
|
|
|
|
;; Freeze a scope → store → return CID
|
|
(define freeze-to-cid :effects [mutation]
|
|
(fn (scope-name)
|
|
(let ((sx-text (freeze-to-sx scope-name)))
|
|
(content-put sx-text))))
|
|
|
|
;; Thaw from CID → look up → restore
|
|
(define thaw-from-cid :effects [mutation]
|
|
(fn (cid)
|
|
(let ((sx-text (content-get cid)))
|
|
(when sx-text
|
|
(thaw-from-sx sx-text)
|
|
true))))
|
|
|
|
|
|
;; **************************************************************************
|
|
;; eval-expr / trampoline — canonical definitions (after cek-run is defined)
|
|
;; **************************************************************************
|
|
;;
|
|
;; These override the forward declarations from Part 2. All evaluation
|
|
;; goes through the CEK machine. The CEK fixups in the host platform
|
|
;; may further override these (e.g., to make cek-run iterative).
|
|
|
|
(define eval-expr
|
|
(fn (expr (env :as dict))
|
|
(cek-run (make-cek-state expr env (list)))))
|
|
|
|
(define trampoline
|
|
(fn (val)
|
|
(if (thunk? val)
|
|
(eval-expr (thunk-expr val) (thunk-env val))
|
|
val)))
|