giles
c82941d93c
Take HEAD's updated typed-sx content (deftype, effect system details) with main's /etc/plans/ path prefix. Take main's newer sx-browser.js timestamp. Co-Authored-By: Claude Opus 4.6 <noreply@anthropic.com>
1017 lines
38 KiB
Plaintext
1017 lines
38 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)
|
|
;; 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)))))
|
|
|
|
|
|
;; --------------------------------------------------------------------------
|
|
;; 3. Core evaluator
|
|
;; --------------------------------------------------------------------------
|
|
|
|
(define eval-expr
|
|
(fn (expr env)
|
|
(case (type-of expr)
|
|
|
|
;; --- literals pass through ---
|
|
"number" expr
|
|
"string" expr
|
|
"boolean" expr
|
|
"nil" nil
|
|
|
|
;; --- symbol lookup ---
|
|
"symbol"
|
|
(let ((name (symbol-name expr)))
|
|
(cond
|
|
(env-has? env name) (env-get env name)
|
|
(primitive? name) (get-primitive name)
|
|
(= name "true") true
|
|
(= name "false") false
|
|
(= name "nil") nil
|
|
:else (do (debug-log "Undefined symbol:" name "primitive?:" (primitive? name))
|
|
(error (str "Undefined symbol: " name)))))
|
|
|
|
;; --- keyword → its string name ---
|
|
"keyword" (keyword-name expr)
|
|
|
|
;; --- dict literal ---
|
|
"dict"
|
|
(map-dict (fn (k v) (trampoline (eval-expr v env))) expr)
|
|
|
|
;; --- list = call or special form ---
|
|
"list"
|
|
(if (empty? expr)
|
|
(list)
|
|
(eval-list expr env))
|
|
|
|
;; --- anything else passes through ---
|
|
:else expr)))
|
|
|
|
|
|
;; --------------------------------------------------------------------------
|
|
;; 4. List evaluation — dispatch on head
|
|
;; --------------------------------------------------------------------------
|
|
|
|
(define eval-list
|
|
(fn (expr env)
|
|
(let ((head (first expr))
|
|
(args (rest expr)))
|
|
|
|
;; If head isn't a symbol, lambda, or list → treat as data list
|
|
(if (not (or (= (type-of head) "symbol")
|
|
(= (type-of head) "lambda")
|
|
(= (type-of head) "list")))
|
|
(map (fn (x) (trampoline (eval-expr x env))) expr)
|
|
|
|
;; Head is a symbol — check special forms, then function call
|
|
(if (= (type-of head) "symbol")
|
|
(let ((name (symbol-name head)))
|
|
(cond
|
|
;; Special forms
|
|
(= name "if") (sf-if args env)
|
|
(= name "when") (sf-when args env)
|
|
(= name "cond") (sf-cond args env)
|
|
(= name "case") (sf-case args env)
|
|
(= name "and") (sf-and args env)
|
|
(= name "or") (sf-or args env)
|
|
(= name "let") (sf-let args env)
|
|
(= name "let*") (sf-let args env)
|
|
(= name "letrec") (sf-letrec args env)
|
|
(= name "lambda") (sf-lambda args env)
|
|
(= name "fn") (sf-lambda args env)
|
|
(= name "define") (sf-define args env)
|
|
(= name "defcomp") (sf-defcomp args env)
|
|
(= name "defisland") (sf-defisland args env)
|
|
(= name "defmacro") (sf-defmacro args env)
|
|
(= name "defstyle") (sf-defstyle args env)
|
|
(= name "defhandler") (sf-defhandler args env)
|
|
(= name "defpage") (sf-defpage args env)
|
|
(= name "defquery") (sf-defquery args env)
|
|
(= name "defaction") (sf-defaction args env)
|
|
(= name "begin") (sf-begin args env)
|
|
(= name "do") (sf-begin args env)
|
|
(= name "quote") (sf-quote args env)
|
|
(= name "quasiquote") (sf-quasiquote args env)
|
|
(= name "->") (sf-thread-first args env)
|
|
(= name "set!") (sf-set! args env)
|
|
(= name "reset") (sf-reset args env)
|
|
(= name "shift") (sf-shift args env)
|
|
(= name "dynamic-wind") (sf-dynamic-wind args env)
|
|
|
|
;; Higher-order forms
|
|
(= name "map") (ho-map args env)
|
|
(= name "map-indexed") (ho-map-indexed args env)
|
|
(= name "filter") (ho-filter args env)
|
|
(= name "reduce") (ho-reduce args env)
|
|
(= name "some") (ho-some args env)
|
|
(= name "every?") (ho-every args env)
|
|
(= name "for-each") (ho-for-each args env)
|
|
|
|
;; Macro expansion
|
|
(and (env-has? env name) (macro? (env-get env name)))
|
|
(let ((mac (env-get env name)))
|
|
(make-thunk (expand-macro mac args env) env))
|
|
|
|
;; Render expression — delegate to active adapter (only when rendering).
|
|
(and (render-active?) (is-render-expr? expr))
|
|
(render-expr expr env)
|
|
|
|
;; Fall through to function call
|
|
:else (eval-call head args env)))
|
|
|
|
;; Head is lambda or list — evaluate as function call
|
|
(eval-call head args env))))))
|
|
|
|
|
|
;; --------------------------------------------------------------------------
|
|
;; 5. Function / lambda / component call
|
|
;; --------------------------------------------------------------------------
|
|
|
|
(define eval-call
|
|
(fn (head args env)
|
|
(let ((f (trampoline (eval-expr head env)))
|
|
(evaluated-args (map (fn (a) (trampoline (eval-expr a env))) args)))
|
|
(cond
|
|
;; Native callable (primitive function)
|
|
(and (callable? f) (not (lambda? f)) (not (component? f)) (not (island? f)))
|
|
(apply f evaluated-args)
|
|
|
|
;; Lambda
|
|
(lambda? f)
|
|
(call-lambda f evaluated-args env)
|
|
|
|
;; Component
|
|
(component? f)
|
|
(call-component f args env)
|
|
|
|
;; Island (reactive component) — same calling convention
|
|
(island? f)
|
|
(call-component f args env)
|
|
|
|
:else (error (str "Not callable: " (inspect f)))))))
|
|
|
|
|
|
(define call-lambda
|
|
(fn (f args caller-env)
|
|
(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-set! local (first pair) (nth pair 1)))
|
|
(zip params args))
|
|
(for-each
|
|
(fn (p) (env-set! local p nil))
|
|
(slice params (len args)))
|
|
;; Return thunk for TCO
|
|
(make-thunk (lambda-body f) local))))))
|
|
|
|
|
|
(define call-component
|
|
(fn (comp raw-args env)
|
|
;; 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-set! local p (or (dict-get kwargs p) nil)))
|
|
(component-params comp))
|
|
;; Bind children if component accepts them
|
|
(when (component-has-children? comp)
|
|
(env-set! local "children" children))
|
|
;; Return thunk — body evaluated in local env
|
|
(make-thunk (component-body comp) local))))
|
|
|
|
|
|
(define parse-keyword-args
|
|
(fn (raw-args env)
|
|
;; 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
|
|
;; --------------------------------------------------------------------------
|
|
|
|
(define sf-if
|
|
(fn (args env)
|
|
(let ((condition (trampoline (eval-expr (first args) env))))
|
|
(if (and condition (not (nil? condition)))
|
|
(make-thunk (nth args 1) env)
|
|
(if (> (len args) 2)
|
|
(make-thunk (nth args 2) env)
|
|
nil)))))
|
|
|
|
|
|
(define sf-when
|
|
(fn (args env)
|
|
(let ((condition (trampoline (eval-expr (first args) env))))
|
|
(if (and condition (not (nil? condition)))
|
|
(do
|
|
;; Evaluate all but last for side effects
|
|
(for-each
|
|
(fn (e) (trampoline (eval-expr e env)))
|
|
(slice args 1 (dec (len args))))
|
|
;; Last is tail position
|
|
(make-thunk (last args) env))
|
|
nil))))
|
|
|
|
|
|
;; cond-scheme? — check if ALL clauses are 2-element lists (scheme-style).
|
|
;; Checking only the first arg is ambiguous — (nil? x) is a 2-element
|
|
;; function call, not a scheme clause ((test body)).
|
|
(define cond-scheme?
|
|
(fn (clauses)
|
|
(every? (fn (c) (and (= (type-of c) "list") (= (len c) 2)))
|
|
clauses)))
|
|
|
|
(define sf-cond
|
|
(fn (args env)
|
|
(if (cond-scheme? args)
|
|
(sf-cond-scheme args env)
|
|
(sf-cond-clojure args env))))
|
|
|
|
(define sf-cond-scheme
|
|
(fn (clauses env)
|
|
(if (empty? clauses)
|
|
nil
|
|
(let ((clause (first clauses))
|
|
(test (first clause))
|
|
(body (nth clause 1)))
|
|
(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-thunk body env)
|
|
(if (trampoline (eval-expr test env))
|
|
(make-thunk body env)
|
|
(sf-cond-scheme (rest clauses) env)))))))
|
|
|
|
(define sf-cond-clojure
|
|
(fn (clauses env)
|
|
(if (< (len clauses) 2)
|
|
nil
|
|
(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-thunk body env)
|
|
(if (trampoline (eval-expr test env))
|
|
(make-thunk body env)
|
|
(sf-cond-clojure (slice clauses 2) env)))))))
|
|
|
|
|
|
(define sf-case
|
|
(fn (args env)
|
|
(let ((match-val (trampoline (eval-expr (first args) env)))
|
|
(clauses (rest args)))
|
|
(sf-case-loop match-val clauses env))))
|
|
|
|
(define sf-case-loop
|
|
(fn (match-val clauses env)
|
|
(if (< (len clauses) 2)
|
|
nil
|
|
(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-thunk body env)
|
|
(if (= match-val (trampoline (eval-expr test env)))
|
|
(make-thunk body env)
|
|
(sf-case-loop match-val (slice clauses 2) env)))))))
|
|
|
|
|
|
(define sf-and
|
|
(fn (args env)
|
|
(if (empty? args)
|
|
true
|
|
(let ((val (trampoline (eval-expr (first args) env))))
|
|
(if (not val)
|
|
val
|
|
(if (= (len args) 1)
|
|
val
|
|
(sf-and (rest args) env)))))))
|
|
|
|
|
|
(define sf-or
|
|
(fn (args env)
|
|
(if (empty? args)
|
|
false
|
|
(let ((val (trampoline (eval-expr (first args) env))))
|
|
(if val
|
|
val
|
|
(sf-or (rest args) env))))))
|
|
|
|
|
|
(define sf-let
|
|
(fn (args env)
|
|
;; Detect named let: (let name ((x 0) ...) body)
|
|
;; If first arg is a symbol, delegate to sf-named-let.
|
|
(if (= (type-of (first args)) "symbol")
|
|
(sf-named-let args env)
|
|
(let ((bindings (first args))
|
|
(body (rest args))
|
|
(local (env-extend env)))
|
|
;; Parse bindings — support both ((name val) ...) and (name val name val ...)
|
|
(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))))
|
|
(env-set! local vname (trampoline (eval-expr (nth binding 1) local)))))
|
|
bindings)
|
|
;; Clojure-style
|
|
(let ((i 0))
|
|
(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)))))
|
|
(env-set! local vname (trampoline (eval-expr val-expr local)))))
|
|
nil
|
|
(range 0 (/ (len bindings) 2)))))
|
|
;; Evaluate body — last expression in tail position
|
|
(for-each
|
|
(fn (e) (trampoline (eval-expr e local)))
|
|
(slice body 0 (dec (len body))))
|
|
(make-thunk (last body) local)))))
|
|
|
|
|
|
;; 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 env)
|
|
(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-set! (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 env)
|
|
(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)
|
|
(if (= (type-of p) "symbol")
|
|
(symbol-name p)
|
|
p))
|
|
params-expr)))
|
|
(make-lambda param-names body env))))
|
|
|
|
|
|
(define sf-define
|
|
(fn (args env)
|
|
(let ((name-sym (first args))
|
|
(value (trampoline (eval-expr (nth args 1) env))))
|
|
(when (and (lambda? value) (nil? (lambda-name value)))
|
|
(set-lambda-name! value (symbol-name name-sym)))
|
|
(env-set! env (symbol-name name-sym) value)
|
|
value)))
|
|
|
|
|
|
(define sf-defcomp
|
|
(fn (args env)
|
|
;; (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)))
|
|
;; 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))
|
|
(env-set! env (symbol-name name-sym) comp)
|
|
comp))))
|
|
|
|
(define defcomp-kwarg
|
|
(fn (args key 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)
|
|
;; 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 env)
|
|
;; (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-set! env (symbol-name name-sym) island)
|
|
island))))
|
|
|
|
|
|
(define sf-defmacro
|
|
(fn (args env)
|
|
(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-set! env (symbol-name name-sym) mac)
|
|
mac))))
|
|
|
|
(define parse-macro-params
|
|
(fn (params-expr)
|
|
;; 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 env)
|
|
;; (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-set! env (symbol-name name-sym) value)
|
|
value)))
|
|
|
|
|
|
(define sf-begin
|
|
(fn (args env)
|
|
(if (empty? args)
|
|
nil
|
|
(do
|
|
(for-each
|
|
(fn (e) (trampoline (eval-expr e env)))
|
|
(slice args 0 (dec (len args))))
|
|
(make-thunk (last args) env)))))
|
|
|
|
|
|
(define sf-quote
|
|
(fn (args env)
|
|
(if (empty? args) nil (first args))))
|
|
|
|
|
|
(define sf-quasiquote
|
|
(fn (args env)
|
|
(qq-expand (first args) env)))
|
|
|
|
(define qq-expand
|
|
(fn (template env)
|
|
(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)))))))
|
|
|
|
|
|
(define sf-thread-first
|
|
(fn (args env)
|
|
(let ((val (trampoline (eval-expr (first args) env))))
|
|
(reduce
|
|
(fn (result form)
|
|
(if (= (type-of form) "list")
|
|
(let ((f (trampoline (eval-expr (first form) env)))
|
|
(rest-args (map (fn (a) (trampoline (eval-expr a env)))
|
|
(rest form)))
|
|
(all-args (cons result rest-args)))
|
|
(cond
|
|
(and (callable? f) (not (lambda? f)))
|
|
(apply f all-args)
|
|
(lambda? f)
|
|
(trampoline (call-lambda f all-args env))
|
|
:else (error (str "-> form not callable: " (inspect f)))))
|
|
(let ((f (trampoline (eval-expr form env))))
|
|
(cond
|
|
(and (callable? f) (not (lambda? f)))
|
|
(f result)
|
|
(lambda? f)
|
|
(trampoline (call-lambda f (list result) env))
|
|
:else (error (str "-> form not callable: " (inspect f)))))))
|
|
val
|
|
(rest args)))))
|
|
|
|
|
|
(define sf-set!
|
|
(fn (args env)
|
|
(let ((name (symbol-name (first args)))
|
|
(value (trampoline (eval-expr (nth args 1) env))))
|
|
(env-set! env name value)
|
|
value)))
|
|
|
|
|
|
;; --------------------------------------------------------------------------
|
|
;; 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 env)
|
|
(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-set! 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-set! 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-set! 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-set! (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 env)
|
|
(let ((before (trampoline (eval-expr (first args) env)))
|
|
(body (trampoline (eval-expr (nth args 1) env)))
|
|
(after (trampoline (eval-expr (nth args 2) env))))
|
|
;; Call entry thunk
|
|
(call-thunk before env)
|
|
;; Push wind record, run body, pop, call exit
|
|
(push-wind! before after)
|
|
(let ((result (call-thunk body env)))
|
|
(pop-wind!)
|
|
(call-thunk after env)
|
|
result))))
|
|
|
|
|
|
;; --------------------------------------------------------------------------
|
|
;; 6b. Macro expansion
|
|
;; --------------------------------------------------------------------------
|
|
|
|
(define expand-macro
|
|
(fn (mac raw-args env)
|
|
(let ((local (env-merge (macro-closure mac) env)))
|
|
;; Bind positional params (unevaluated)
|
|
(for-each
|
|
(fn (pair)
|
|
(env-set! 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-set! local (macro-rest-param mac)
|
|
(slice raw-args (len (macro-params mac)))))
|
|
;; Evaluate body → new AST
|
|
(trampoline (eval-expr (macro-body mac) local)))))
|
|
|
|
|
|
;; --------------------------------------------------------------------------
|
|
;; 7. Higher-order forms
|
|
;; --------------------------------------------------------------------------
|
|
|
|
;; call-fn: unified caller for HO forms — handles both Lambda and native callable
|
|
(define call-fn
|
|
(fn (f args env)
|
|
(cond
|
|
(lambda? f) (trampoline (call-lambda f args env))
|
|
(callable? f) (apply f args)
|
|
:else (error (str "Not callable in HO form: " (inspect f))))))
|
|
|
|
(define ho-map
|
|
(fn (args env)
|
|
(let ((f (trampoline (eval-expr (first args) env)))
|
|
(coll (trampoline (eval-expr (nth args 1) env))))
|
|
(map (fn (item) (call-fn f (list item) env)) coll))))
|
|
|
|
(define ho-map-indexed
|
|
(fn (args env)
|
|
(let ((f (trampoline (eval-expr (first args) env)))
|
|
(coll (trampoline (eval-expr (nth args 1) env))))
|
|
(map-indexed
|
|
(fn (i item) (call-fn f (list i item) env))
|
|
coll))))
|
|
|
|
(define ho-filter
|
|
(fn (args env)
|
|
(let ((f (trampoline (eval-expr (first args) env)))
|
|
(coll (trampoline (eval-expr (nth args 1) env))))
|
|
(filter
|
|
(fn (item) (call-fn f (list item) env))
|
|
coll))))
|
|
|
|
(define ho-reduce
|
|
(fn (args env)
|
|
(let ((f (trampoline (eval-expr (first args) env)))
|
|
(init (trampoline (eval-expr (nth args 1) env)))
|
|
(coll (trampoline (eval-expr (nth args 2) env))))
|
|
(reduce
|
|
(fn (acc item) (call-fn f (list acc item) env))
|
|
init
|
|
coll))))
|
|
|
|
(define ho-some
|
|
(fn (args env)
|
|
(let ((f (trampoline (eval-expr (first args) env)))
|
|
(coll (trampoline (eval-expr (nth args 1) env))))
|
|
(some
|
|
(fn (item) (call-fn f (list item) env))
|
|
coll))))
|
|
|
|
(define ho-every
|
|
(fn (args env)
|
|
(let ((f (trampoline (eval-expr (first args) env)))
|
|
(coll (trampoline (eval-expr (nth args 1) env))))
|
|
(every?
|
|
(fn (item) (call-fn f (list item) env))
|
|
coll))))
|
|
|
|
|
|
(define ho-for-each
|
|
(fn (args env)
|
|
(let ((f (trampoline (eval-expr (first args) env)))
|
|
(coll (trampoline (eval-expr (nth args 1) env))))
|
|
(for-each
|
|
(fn (item) (call-fn f (list item) env))
|
|
coll))))
|
|
|
|
|
|
;; --------------------------------------------------------------------------
|
|
;; 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"
|
|
;; (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.
|
|
;;
|
|
;; (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-set! env name val) → void (mutating)
|
|
;; (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)
|
|
;; --------------------------------------------------------------------------
|