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