coop/rose-ash
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Move stdlib out of spec — clean spec/library boundary

Browse Source 
spec/ now contains only the language definition (5 files):
  evaluator.sx, parser.sx, primitives.sx, render.sx, special-forms.sx

lib/ contains code written IN the language (8 files):
  stdlib.sx, types.sx, freeze.sx, content.sx,
  bytecode.sx, compiler.sx, vm.sx, callcc.sx

Test files follow source: spec/tests/ for core language tests,
lib/tests/ for library tests (continuations, freeze, types, vm).

Updated all consumers:
- JS/Python/OCaml bootstrappers: added lib/ to source search paths
- OCaml bridge: spec_dir for parser/render, lib_dir for compiler/freeze
- JS test runner: scans spec/tests/ (always) + lib/tests/ (--full)
- OCaml test runner: scans spec/tests/, lib tests via explicit request
- Docker dev mounts: added ./lib:/app/lib:ro

Tests: 1041 JS standard, 1322 JS full, 1101 OCaml — all pass

Co-Authored-By: Claude Opus 4.6 (1M context) <noreply@anthropic.com>
This commit is contained in:
giles
2026-03-24 23:18:30 +00:00
parent 50871780a3
commit f3f70cc00b
26 changed files with 109 additions and 64 deletions
Download Patch File Download Diff File Expand all files Collapse all files

163
lib/bytecode.sx Normal file
View File

@@ -0,0 +1,163 @@
;; ==========================================================================
;; bytecode.sx — SX bytecode format definition
;;
;; Universal bytecode for SX evaluation. Produced by compiler.sx,
;; executed by platform-native VMs (OCaml, JS, WASM).
;;
;; Design principles:
;; - One byte per opcode (~65 ops, fits in u8)
;; - Variable-length encoding (1-5 bytes per instruction)
;; - Lexical scope resolved at compile time (no hash lookups)
;; - Tail calls detected statically (no thunks/trampoline)
;; - Control flow via jumps (no continuation frames for if/when/etc.)
;; - Content-addressable (deterministic binary for CID)
;; ==========================================================================
;; --------------------------------------------------------------------------
;; Opcode constants
;; --------------------------------------------------------------------------
;; Stack / Constants
(define OP_CONST 1) ;; u16 pool_idx — push constant
(define OP_NIL 2) ;; push nil
(define OP_TRUE 3) ;; push true
(define OP_FALSE 4) ;; push false
(define OP_POP 5) ;; discard TOS
(define OP_DUP 6) ;; duplicate TOS
;; Variable access (resolved at compile time)
(define OP_LOCAL_GET 16) ;; u8 slot
(define OP_LOCAL_SET 17) ;; u8 slot
(define OP_UPVALUE_GET 18) ;; u8 idx
(define OP_UPVALUE_SET 19) ;; u8 idx
(define OP_GLOBAL_GET 20) ;; u16 name_idx
(define OP_GLOBAL_SET 21) ;; u16 name_idx
;; Control flow (replaces if/when/cond/and/or frames)
(define OP_JUMP 32) ;; i16 offset
(define OP_JUMP_IF_FALSE 33) ;; i16 offset
(define OP_JUMP_IF_TRUE 34) ;; i16 offset
;; Function operations
(define OP_CALL 48) ;; u8 argc
(define OP_TAIL_CALL 49) ;; u8 argc — reuse frame (TCO)
(define OP_RETURN 50) ;; return TOS
(define OP_CLOSURE 51) ;; u16 code_idx — create closure
(define OP_CALL_PRIM 52) ;; u16 name_idx, u8 argc — direct primitive
(define OP_APPLY 53) ;; (apply f args-list)
;; Collection construction
(define OP_LIST 64) ;; u16 count — build list from stack
(define OP_DICT 65) ;; u16 count — build dict from stack pairs
(define OP_APPEND_BANG 66) ;; (append! TOS-1 TOS)
;; Higher-order forms (inlined loop)
(define OP_ITER_INIT 80) ;; init iterator on TOS list
(define OP_ITER_NEXT 81) ;; i16 end_offset — push next or jump
(define OP_MAP_OPEN 82) ;; push empty accumulator
(define OP_MAP_APPEND 83) ;; append TOS to accumulator
(define OP_MAP_CLOSE 84) ;; pop accumulator as list
(define OP_FILTER_TEST 85) ;; i16 skip — if falsy jump (skip append)
;; HO fallback (dynamic callback)
(define OP_HO_MAP 88) ;; (map fn coll)
(define OP_HO_FILTER 89) ;; (filter fn coll)
(define OP_HO_REDUCE 90) ;; (reduce fn init coll)
(define OP_HO_FOR_EACH 91) ;; (for-each fn coll)
(define OP_HO_SOME 92) ;; (some fn coll)
(define OP_HO_EVERY 93) ;; (every? fn coll)
;; Scope / dynamic binding
(define OP_SCOPE_PUSH 96) ;; TOS = name
(define OP_SCOPE_POP 97)
(define OP_PROVIDE_PUSH 98) ;; TOS-1 = name, TOS = value
(define OP_PROVIDE_POP 99)
(define OP_CONTEXT 100) ;; TOS = name → push value
(define OP_EMIT 101) ;; TOS-1 = name, TOS = value
(define OP_EMITTED 102) ;; TOS = name → push collected
;; Continuations
(define OP_RESET 112) ;; i16 body_len — push delimiter
(define OP_SHIFT 113) ;; u8 k_slot, i16 body_len — capture k
;; Define / component
(define OP_DEFINE 128) ;; u16 name_idx — bind TOS to name
(define OP_DEFCOMP 129) ;; u16 template_idx
(define OP_DEFISLAND 130) ;; u16 template_idx
(define OP_DEFMACRO 131) ;; u16 template_idx
(define OP_EXPAND_MACRO 132) ;; u8 argc — runtime macro expansion
;; String / serialize (hot path)
(define OP_STR_CONCAT 144) ;; u8 count — concat N values as strings
(define OP_STR_JOIN 145) ;; (join sep list)
(define OP_SERIALIZE 146) ;; serialize TOS to SX string
;; Inline primitives (hot path — no hashtable lookup)
(define OP_ADD 160) ;; TOS-1 + TOS → push
(define OP_SUB 161) ;; TOS-1 - TOS → push
(define OP_MUL 162) ;; TOS-1 * TOS → push
(define OP_DIV 163) ;; TOS-1 / TOS → push
(define OP_EQ 164) ;; TOS-1 = TOS → push bool
(define OP_LT 165) ;; TOS-1 < TOS → push bool
(define OP_GT 166) ;; TOS-1 > TOS → push bool
(define OP_NOT 167) ;; !TOS → push bool
(define OP_LEN 168) ;; len(TOS) → push number
(define OP_FIRST 169) ;; first(TOS) → push
(define OP_REST 170) ;; rest(TOS) → push list
(define OP_NTH 171) ;; nth(TOS-1, TOS) → push
(define OP_CONS 172) ;; cons(TOS-1, TOS) → push list
(define OP_NEG 173) ;; negate TOS → push number
(define OP_INC 174) ;; TOS + 1 → push
(define OP_DEC 175) ;; TOS - 1 → push
;; Aser specialization (optional, 224-239 reserved)
(define OP_ASER_TAG 224) ;; u16 tag_name_idx — serialize HTML tag
(define OP_ASER_FRAG 225) ;; u8 child_count — serialize fragment
;; --------------------------------------------------------------------------
;; Bytecode module structure
;; --------------------------------------------------------------------------
;; A module contains:
;; magic: "SXBC" (4 bytes)
;; version: u16
;; pool_count: u32
;; pool: constant pool entries (self-describing tagged values)
;; code_count: u32
;; codes: code objects
;; entry: u32 (index of entry-point code object)
(define BYTECODE_MAGIC "SXBC")
(define BYTECODE_VERSION 1)
;; Constant pool tags
(define CONST_NUMBER 1)
(define CONST_STRING 2)
(define CONST_BOOL 3)
(define CONST_NIL 4)
(define CONST_SYMBOL 5)
(define CONST_KEYWORD 6)
(define CONST_LIST 7)
(define CONST_DICT 8)
(define CONST_CODE 9)
;; --------------------------------------------------------------------------
;; Disassembler
;; --------------------------------------------------------------------------
(define opcode-name
(fn (op)
(cond
(= op 1) "CONST" (= op 2) "NIL"
(= op 3) "TRUE" (= op 4) "FALSE"
(= op 5) "POP" (= op 6) "DUP"
(= op 16) "LOCAL_GET" (= op 17) "LOCAL_SET"
(= op 20) "GLOBAL_GET" (= op 21) "GLOBAL_SET"
(= op 32) "JUMP" (= op 33) "JUMP_IF_FALSE"
(= op 48) "CALL" (= op 49) "TAIL_CALL"
(= op 50) "RETURN" (= op 52) "CALL_PRIM"
(= op 128) "DEFINE" (= op 144) "STR_CONCAT"
:else (str "OP_" op))))

245
lib/callcc.sx Normal file
View File

@@ -0,0 +1,245 @@
;; ==========================================================================
;; callcc.sx — Full first-class continuations (call/cc)
;;
;; OPTIONAL EXTENSION — not required by the core evaluator.
;; Bootstrappers include this only when the target supports it naturally.
;;
;; Full call/cc (call-with-current-continuation) captures the ENTIRE
;; remaining computation as a first-class function — not just up to a
;; delimiter, but all the way to the top level. Invoking a continuation
;; captured by call/cc abandons the current computation entirely and
;; resumes from where the continuation was captured.
;;
;; This is strictly more powerful than delimited continuations (shift/reset)
;; but harder to implement in targets that don't support it natively.
;; Recommended only for targets where it's natural:
;; - Scheme/Racket (native call/cc)
;; - Haskell (ContT monad transformer)
;;
;; For targets like Python, JavaScript, and Rust, delimited continuations
;; (continuations.sx) are more practical and cover the same use cases
;; without requiring a global CPS transform.
;;
;; One new special form:
;; (call/cc f) — call f with the current continuation
;;
;; One new type:
;; continuation — same type as in continuations.sx
;;
;; If both extensions are loaded, the continuation type is shared.
;; Delimited and undelimited continuations are the same type —
;; the difference is in how they are captured, not what they are.
;;
;; Platform requirements:
;; (make-continuation fn) — wrap a function as a continuation value
;; (continuation? x) — type predicate
;; (type-of continuation) → "continuation"
;; (call-with-cc f env) — target-specific call/cc implementation
;; ==========================================================================
;; --------------------------------------------------------------------------
;; 1. Semantics
;; --------------------------------------------------------------------------
;;
;; (call/cc f)
;;
;; Evaluates f (which must be a function of one argument), passing it the
;; current continuation as a continuation value. f can:
;;
;; a) Return normally — call/cc returns whatever f returns
;; b) Invoke the continuation — abandons f's computation, call/cc
;; "returns" the value passed to the continuation
;; c) Store the continuation — invoke it later, possibly multiple times
;;
;; Key difference from shift/reset: invoking an undelimited continuation
;; NEVER RETURNS to the caller. It abandons the current computation and
;; jumps back to where call/cc was originally called.
;;
;; ;; Delimited (shift/reset) — k returns a value:
;; (reset (+ 1 (shift k (+ (k 10) (k 20)))))
;; ;; (k 10) → 11, returns to the (+ ... (k 20)) expression
;; ;; (k 20) → 21, returns to the (+ 11 ...) expression
;; ;; result: 32
;;
;; ;; Undelimited (call/cc) — k does NOT return:
;; (+ 1 (call/cc (fn (k)
;; (+ (k 10) (k 20)))))
;; ;; (k 10) abandons (+ (k 10) (k 20)) entirely
;; ;; jumps back to (+ 1 _) with 10
;; ;; result: 11
;; ;; (k 20) is never reached
;;
;; --------------------------------------------------------------------------
;; --------------------------------------------------------------------------
;; 2. call/cc — call with current continuation
;; --------------------------------------------------------------------------
(define sf-callcc
(fn (args env)
;; Single argument: a function to call with the current continuation.
(let ((f-expr (first args))
(f (trampoline (eval-expr f-expr env))))
(call-with-cc f env))))
;; --------------------------------------------------------------------------
;; 3. Derived forms
;; --------------------------------------------------------------------------
;;
;; With call/cc available, several patterns become expressible:
;;
;; --- Early return ---
;;
;; (define find-first
;; (fn (pred items)
;; (call/cc (fn (return)
;; (for-each (fn (item)
;; (when (pred item)
;; (return item)))
;; items)
;; nil))))
;;
;; --- Exception-like flow ---
;;
;; (define try-catch
;; (fn (body handler)
;; (call/cc (fn (throw)
;; (body throw)))))
;;
;; (try-catch
;; (fn (throw)
;; (let ((result (dangerous-operation)))
;; (when (not result) (throw "failed"))
;; result))
;; (fn (error) (str "Caught: " error)))
;;
;; --- Coroutines ---
;;
;; Two call/cc captures that alternate control between two
;; computations. Each captures its own continuation, then invokes
;; the other's. This gives cooperative multitasking without threads.
;;
;; --- Undo ---
;;
;; (define with-undo
;; (fn (action)
;; (call/cc (fn (restore)
;; (action)
;; restore))))
;;
;; ;; (let ((undo (with-undo (fn () (delete-item 42)))))
;; ;; (undo "anything")) → item 42 is back
;;
;; --------------------------------------------------------------------------
;; --------------------------------------------------------------------------
;; 4. Interaction with delimited continuations
;; --------------------------------------------------------------------------
;;
;; If both callcc.sx and continuations.sx are loaded:
;;
;; - The continuation type is shared. (continuation? k) returns true
;; for both delimited and undelimited continuations.
;;
;; - shift inside a call/cc body captures up to the nearest reset,
;; not up to the call/cc. The two mechanisms compose.
;;
;; - call/cc inside a reset body captures the entire continuation
;; (past the reset). This is the expected behavior — call/cc is
;; undelimited by definition.
;;
;; - A delimited continuation (from shift) returns a value when invoked.
;; An undelimited continuation (from call/cc) does not return.
;; Both are callable with the same syntax: (k value).
;; The caller cannot distinguish them by type — only by behavior.
;;
;; --------------------------------------------------------------------------
;; --------------------------------------------------------------------------
;; 5. Interaction with I/O and state
;; --------------------------------------------------------------------------
;;
;; Full call/cc has well-known interactions with side effects:
;;
;; Re-entry:
;; Invoking a saved continuation re-enters a completed computation.
;; If that computation mutated state (set!, I/O writes), the mutations
;; are NOT undone. The continuation resumes in the current state,
;; not the state at the time of capture.
;;
;; I/O:
;; Same as delimited continuations — I/O executes at invocation time.
;; A continuation containing (current-user) will call current-user
;; when invoked, in whatever request context exists then.
;;
;; Dynamic extent:
;; call/cc captures the continuation, not the dynamic environment.
;; Host-language context (Python's Quart request context, JavaScript's
;; async context) may not be valid when a saved continuation is invoked
;; later. Typed targets can enforce this; dynamic targets fail at runtime.
;;
;; Recommendation:
;; Use call/cc for pure control flow (early return, coroutines,
;; backtracking). Use delimited continuations for effectful patterns
;; (suspense, cooperative scheduling) where the delimiter provides
;; a natural boundary.
;;
;; --------------------------------------------------------------------------
;; --------------------------------------------------------------------------
;; 6. Implementation notes per target
;; --------------------------------------------------------------------------
;;
;; Scheme / Racket:
;; Native call/cc. Zero implementation effort.
;;
;; Haskell:
;; ContT monad transformer. The evaluator runs in ContT, and call/cc
;; is callCC from Control.Monad.Cont. Natural and type-safe.
;;
;; Python:
;; Requires full CPS transform of the evaluator, or greenlet-based
;; stack capture. Significantly more invasive than delimited
;; continuations. NOT RECOMMENDED — use continuations.sx instead.
;;
;; JavaScript:
;; Requires full CPS transform. Cannot be implemented with generators
;; alone (generators only support delimited yield, not full escape).
;; NOT RECOMMENDED — use continuations.sx instead.
;;
;; Rust:
;; Full CPS transform at compile time. Possible but adds significant
;; complexity. Delimited continuations are more natural (enum-based).
;; Consider only if the target genuinely needs undelimited escape.
;;
;; --------------------------------------------------------------------------
;; --------------------------------------------------------------------------
;; 7. Platform interface — what each target must provide
;; --------------------------------------------------------------------------
;;
;; (call-with-cc f env)
;; Call f with the current continuation. f is a function of one
;; argument (the continuation). If f returns normally, call-with-cc
;; returns f's result. If f invokes the continuation, the computation
;; jumps to the call-with-cc call site with the provided value.
;;
;; (make-continuation fn)
;; Wrap a native function as a continuation value.
;; (Shared with continuations.sx if both are loaded.)
;;
;; (continuation? x)
;; Type predicate.
;; (Shared with continuations.sx if both are loaded.)
;;
;; Continuations must be callable via the standard function-call
;; dispatch in eval-list (same path as lambda calls).
;;
;; --------------------------------------------------------------------------

826
lib/compiler.sx Normal file
View File

@@ -0,0 +1,826 @@
;; ==========================================================================
;; compiler.sx — SX bytecode compiler
;;
;; Compiles SX AST to bytecode for the platform-native VM.
;; Written in SX — runs on any platform with an SX evaluator.
;;
;; Architecture:
;; Pass 1: Scope analysis — resolve variables, detect tail positions
;; Pass 2: Code generation — emit bytecode
;;
;; The compiler produces Code objects (bytecode + constant pool).
;; The VM executes them with a stack machine model.
;; ==========================================================================
;; --------------------------------------------------------------------------
;; Constant pool builder
;; --------------------------------------------------------------------------
(define make-pool
(fn ()
{:entries (if (primitive? "mutable-list") (mutable-list) (list))
:index {:_count 0}}))
(define pool-add
(fn (pool value)
"Add a value to the constant pool, return its index. Deduplicates."
(let ((key (serialize value))
(idx-map (get pool "index")))
(if (has-key? idx-map key)
(get idx-map key)
(let ((idx (get idx-map "_count")))
(dict-set! idx-map key idx)
(dict-set! idx-map "_count" (+ idx 1))
(append! (get pool "entries") value)
idx)))))
;; --------------------------------------------------------------------------
;; Scope analysis
;; --------------------------------------------------------------------------
(define make-scope
(fn (parent)
{:locals (list) ;; list of {name, slot, mutable?}
:upvalues (list) ;; list of {name, is-local, index}
:parent parent
:is-function false ;; true for fn/lambda scopes (create frames)
:next-slot 0}))
(define scope-define-local
(fn (scope name)
"Add a local variable, return its slot index.
Idempotent: if name already has a slot, return it."
(let ((existing (first (filter (fn (l) (= (get l "name") name))
(get scope "locals")))))
(if existing
(get existing "slot")
(let ((slot (get scope "next-slot")))
(append! (get scope "locals")
{:name name :slot slot :mutable false})
(dict-set! scope "next-slot" (+ slot 1))
slot)))))
(define scope-resolve
(fn (scope name)
"Resolve a variable name. Returns {:type \"local\"|\"upvalue\"|\"global\", :index N}.
Upvalue captures only happen at function boundaries (is-function=true).
Let scopes share the enclosing function's frame — their locals are
accessed directly without upvalue indirection."
(if (nil? scope)
{:type "global" :index name}
;; Check locals in this scope
(let ((locals (get scope "locals"))
(found (some (fn (l) (= (get l "name") name)) locals)))
(if found
(let ((local (first (filter (fn (l) (= (get l "name") name)) locals))))
{:type "local" :index (get local "slot")})
;; Check upvalues already captured at this scope
(let ((upvals (get scope "upvalues"))
(uv-found (some (fn (u) (= (get u "name") name)) upvals)))
(if uv-found
(let ((uv (first (filter (fn (u) (= (get u "name") name)) upvals))))
{:type "upvalue" :index (get uv "uv-index")})
;; Look in parent
(let ((parent (get scope "parent")))
(if (nil? parent)
{:type "global" :index name}
(let ((parent-result (scope-resolve parent name)))
(if (= (get parent-result "type") "global")
parent-result
;; Found in parent. Capture as upvalue only at function boundaries.
(if (get scope "is-function")
;; Function boundary — create upvalue capture
(let ((uv-idx (len (get scope "upvalues"))))
(append! (get scope "upvalues")
{:name name
:is-local (= (get parent-result "type") "local")
:index (get parent-result "index")
:uv-index uv-idx})
{:type "upvalue" :index uv-idx})
;; Let scope — pass through (same frame)
parent-result))))))))))))
;; --------------------------------------------------------------------------
;; Code emitter
;; --------------------------------------------------------------------------
(define make-emitter
(fn ()
{:bytecode (if (primitive? "mutable-list") (mutable-list) (list))
:pool (make-pool)}))
(define emit-byte
(fn (em byte)
(append! (get em "bytecode") byte)))
(define emit-u16
(fn (em value)
(emit-byte em (mod value 256))
(emit-byte em (mod (floor (/ value 256)) 256))))
(define emit-i16
(fn (em value)
(let ((v (if (< value 0) (+ value 65536) value)))
(emit-u16 em v))))
(define emit-op
(fn (em opcode)
(emit-byte em opcode)))
(define emit-const
(fn (em value)
(let ((idx (pool-add (get em "pool") value)))
(emit-op em 1) ;; OP_CONST
(emit-u16 em idx))))
(define current-offset
(fn (em)
(len (get em "bytecode"))))
(define patch-i16
(fn (em offset value)
"Patch a previously emitted i16 at the given bytecode offset."
(let ((v (if (< value 0) (+ value 65536) value))
(bc (get em "bytecode")))
;; Direct mutation of bytecode list at offset
(set-nth! bc offset (mod v 256))
(set-nth! bc (+ offset 1) (mod (floor (/ v 256)) 256)))))
;; --------------------------------------------------------------------------
;; Compilation — expression dispatch
;; --------------------------------------------------------------------------
(define compile-expr
(fn (em expr scope tail?)
"Compile an expression. tail? indicates tail position for TCO."
(cond
;; Nil
(nil? expr)
(emit-op em 2) ;; OP_NIL
;; Number
(= (type-of expr) "number")
(emit-const em expr)
;; String
(= (type-of expr) "string")
(emit-const em expr)
;; Boolean
(= (type-of expr) "boolean")
(emit-op em (if expr 3 4)) ;; OP_TRUE / OP_FALSE
;; Keyword
(= (type-of expr) "keyword")
(emit-const em (keyword-name expr))
;; Symbol — resolve to local/upvalue/global
(= (type-of expr) "symbol")
(compile-symbol em (symbol-name expr) scope)
;; List — dispatch on head
(= (type-of expr) "list")
(if (empty? expr)
(do (emit-op em 64) (emit-u16 em 0)) ;; OP_LIST 0
(compile-list em expr scope tail?))
;; Dict literal
(= (type-of expr) "dict")
(compile-dict em expr scope)
;; Fallback
:else
(emit-const em expr))))
(define compile-symbol
(fn (em name scope)
(let ((resolved (scope-resolve scope name)))
(cond
(= (get resolved "type") "local")
(do (emit-op em 16) ;; OP_LOCAL_GET
(emit-byte em (get resolved "index")))
(= (get resolved "type") "upvalue")
(do (emit-op em 18) ;; OP_UPVALUE_GET
(emit-byte em (get resolved "index")))
:else
;; Global or primitive
(let ((idx (pool-add (get em "pool") name)))
(emit-op em 20) ;; OP_GLOBAL_GET
(emit-u16 em idx))))))
(define compile-dict
(fn (em expr scope)
(let ((ks (keys expr))
(count (len ks)))
(for-each (fn (k)
(emit-const em k)
(compile-expr em (get expr k) scope false))
ks)
(emit-op em 65) ;; OP_DICT
(emit-u16 em count))))
;; --------------------------------------------------------------------------
;; List compilation — special forms, calls
;; --------------------------------------------------------------------------
(define compile-list
(fn (em expr scope tail?)
(let ((head (first expr))
(args (rest expr)))
(if (not (= (type-of head) "symbol"))
;; Non-symbol head — compile as call
(compile-call em head args scope tail?)
;; Symbol head — check for special forms
(let ((name (symbol-name head)))
(cond
(= name "if") (compile-if em args scope tail?)
(= name "when") (compile-when em args scope tail?)
(= name "and") (compile-and em args scope tail?)
(= name "or") (compile-or em args scope tail?)
(= name "let") (compile-let em args scope tail?)
(= name "let*") (compile-let em args scope tail?)
(= name "begin") (compile-begin em args scope tail?)
(= name "do") (compile-begin em args scope tail?)
(= name "lambda") (compile-lambda em args scope)
(= name "fn") (compile-lambda em args scope)
(= name "define") (compile-define em args scope)
(= name "set!") (compile-set em args scope)
(= name "quote") (compile-quote em args)
(= name "cond") (compile-cond em args scope tail?)
(= name "case") (compile-case em args scope tail?)
(= name "->") (compile-thread em args scope tail?)
(= name "defcomp") (compile-defcomp em args scope)
(= name "defisland") (compile-defcomp em args scope)
(= name "defmacro") (compile-defmacro em args scope)
(= name "defstyle") (emit-op em 2) ;; defstyle → nil (no-op at runtime)
(= name "defhandler") (emit-op em 2) ;; no-op
(= name "defpage") (emit-op em 2) ;; handled by page loader
(= name "defquery") (emit-op em 2)
(= name "defaction") (emit-op em 2)
(= name "defrelation") (emit-op em 2)
(= name "deftype") (emit-op em 2)
(= name "defeffect") (emit-op em 2)
(= name "defisland") (compile-defcomp em args scope)
(= name "quasiquote") (compile-quasiquote em (first args) scope)
(= name "letrec") (compile-letrec em args scope tail?)
;; Default — function call
:else
(compile-call em head args scope tail?)))))))
;; --------------------------------------------------------------------------
;; Special form compilation
;; --------------------------------------------------------------------------
(define compile-if
(fn (em args scope tail?)
(let ((test (first args))
(then-expr (nth args 1))
(else-expr (if (> (len args) 2) (nth args 2) nil)))
;; Compile test
(compile-expr em test scope false)
;; Jump if false to else
(emit-op em 33) ;; OP_JUMP_IF_FALSE
(let ((else-jump (current-offset em)))
(emit-i16 em 0) ;; placeholder
;; Compile then (in tail position if if is)
(compile-expr em then-expr scope tail?)
;; Jump over else
(emit-op em 32) ;; OP_JUMP
(let ((end-jump (current-offset em)))
(emit-i16 em 0) ;; placeholder
;; Patch else jump
(patch-i16 em else-jump (- (current-offset em) (+ else-jump 2)))
;; Compile else
(if (nil? else-expr)
(emit-op em 2) ;; OP_NIL
(compile-expr em else-expr scope tail?))
;; Patch end jump
(patch-i16 em end-jump (- (current-offset em) (+ end-jump 2))))))))
(define compile-when
(fn (em args scope tail?)
(let ((test (first args))
(body (rest args)))
(compile-expr em test scope false)
(emit-op em 33) ;; OP_JUMP_IF_FALSE
(let ((skip-jump (current-offset em)))
(emit-i16 em 0)
(compile-begin em body scope tail?)
(emit-op em 32) ;; OP_JUMP
(let ((end-jump (current-offset em)))
(emit-i16 em 0)
(patch-i16 em skip-jump (- (current-offset em) (+ skip-jump 2)))
(emit-op em 2) ;; OP_NIL
(patch-i16 em end-jump (- (current-offset em) (+ end-jump 2))))))))
(define compile-and
(fn (em args scope tail?)
(if (empty? args)
(emit-op em 3) ;; OP_TRUE
(if (= (len args) 1)
(compile-expr em (first args) scope tail?)
(do
(compile-expr em (first args) scope false)
(emit-op em 6) ;; OP_DUP
(emit-op em 33) ;; OP_JUMP_IF_FALSE
(let ((skip (current-offset em)))
(emit-i16 em 0)
(emit-op em 5) ;; OP_POP (discard duplicated truthy)
(compile-and em (rest args) scope tail?)
(patch-i16 em skip (- (current-offset em) (+ skip 2)))))))))
(define compile-or
(fn (em args scope tail?)
(if (empty? args)
(emit-op em 4) ;; OP_FALSE
(if (= (len args) 1)
(compile-expr em (first args) scope tail?)
(do
(compile-expr em (first args) scope false)
(emit-op em 6) ;; OP_DUP
(emit-op em 34) ;; OP_JUMP_IF_TRUE
(let ((skip (current-offset em)))
(emit-i16 em 0)
(emit-op em 5) ;; OP_POP
(compile-or em (rest args) scope tail?)
(patch-i16 em skip (- (current-offset em) (+ skip 2)))))))))
(define compile-begin
(fn (em exprs scope tail?)
;; Hoist: pre-allocate local slots for all define forms in this block.
;; Enables forward references between inner functions (e.g. sx-parse).
;; Only inside function bodies (scope has parent), not at top level.
(when (and (not (empty? exprs)) (not (nil? (get scope "parent"))))
(for-each (fn (expr)
(when (and (= (type-of expr) "list")
(>= (len expr) 2)
(= (type-of (first expr)) "symbol")
(= (symbol-name (first expr)) "define"))
(let ((name-expr (nth expr 1))
(name (if (= (type-of name-expr) "symbol")
(symbol-name name-expr)
name-expr)))
(scope-define-local scope name))))
exprs))
;; Compile expressions
(if (empty? exprs)
(emit-op em 2) ;; OP_NIL
(if (= (len exprs) 1)
(compile-expr em (first exprs) scope tail?)
(do
(compile-expr em (first exprs) scope false)
(emit-op em 5) ;; OP_POP
(compile-begin em (rest exprs) scope tail?))))))
(define compile-let
(fn (em args scope tail?)
;; Detect named let: (let loop ((x init) ...) body)
(if (= (type-of (first args)) "symbol")
;; Named let → desugar to letrec:
;; (letrec ((loop (fn (x ...) body))) (loop init ...))
(let ((loop-name (symbol-name (first args)))
(bindings (nth args 1))
(body (slice args 2))
(params (list))
(inits (list)))
(for-each (fn (binding)
(append! params (if (= (type-of (first binding)) "symbol")
(first binding)
(make-symbol (first binding))))
(append! inits (nth binding 1)))
bindings)
;; Compile as: (letrec ((loop (fn (params...) body...))) (loop inits...))
(let ((lambda-expr (concat (list (make-symbol "fn") params) body))
(letrec-bindings (list (list (make-symbol loop-name) lambda-expr)))
(call-expr (cons (make-symbol loop-name) inits)))
(compile-letrec em (list letrec-bindings call-expr) scope tail?)))
;; Normal let
(let ((bindings (first args))
(body (rest args))
(let-scope (make-scope scope)))
;; Let scopes share the enclosing function's frame.
;; Continue slot numbering from parent.
(dict-set! let-scope "next-slot" (get scope "next-slot"))
;; Compile each binding
(for-each (fn (binding)
(let ((name (if (= (type-of (first binding)) "symbol")
(symbol-name (first binding))
(first binding)))
(value (nth binding 1))
(slot (scope-define-local let-scope name)))
(compile-expr em value let-scope false)
(emit-op em 17) ;; OP_LOCAL_SET
(emit-byte em slot)))
bindings)
;; Compile body in let scope
(compile-begin em body let-scope tail?)))))
(define compile-letrec
(fn (em args scope tail?)
"Compile letrec: all names visible during value compilation.
1. Define all local slots (initialized to nil).
2. Compile each value and assign — names are already in scope
so mutually recursive functions can reference each other."
(let ((bindings (first args))
(body (rest args))
(let-scope (make-scope scope)))
(dict-set! let-scope "next-slot" (get scope "next-slot"))
;; Phase 1: define all slots (push nil for each)
(let ((slots (map (fn (binding)
(let ((name (if (= (type-of (first binding)) "symbol")
(symbol-name (first binding))
(first binding))))
(let ((slot (scope-define-local let-scope name)))
(emit-op em 2) ;; OP_NIL
(emit-op em 17) ;; OP_LOCAL_SET
(emit-byte em slot)
slot)))
bindings)))
;; Phase 2: compile values and assign (all names in scope)
(for-each (fn (pair)
(let ((binding (first pair))
(slot (nth pair 1)))
(compile-expr em (nth binding 1) let-scope false)
(emit-op em 17) ;; OP_LOCAL_SET
(emit-byte em slot)))
(map (fn (i) (list (nth bindings i) (nth slots i)))
(range 0 (len bindings)))))
;; Compile body
(compile-begin em body let-scope tail?))))
(define compile-lambda
(fn (em args scope)
(let ((params (first args))
(body (rest args))
(fn-scope (make-scope scope))
(fn-em (make-emitter)))
;; Mark as function boundary — upvalue captures happen here
(dict-set! fn-scope "is-function" true)
;; Define params as locals in fn scope.
;; Handle type annotations: (name :as type) → extract name
(for-each (fn (p)
(let ((name (cond
(= (type-of p) "symbol") (symbol-name p)
;; Type-annotated param: (name :as type)
(and (list? p) (not (empty? p))
(= (type-of (first p)) "symbol"))
(symbol-name (first p))
:else p)))
(when (and (not (= name "&key"))
(not (= name "&rest")))
(scope-define-local fn-scope name))))
params)
;; Compile body
(compile-begin fn-em body fn-scope true) ;; tail position
(emit-op fn-em 50) ;; OP_RETURN
;; Add code object to parent constant pool
(let ((upvals (get fn-scope "upvalues"))
(code {:arity (len (get fn-scope "locals"))
:bytecode (get fn-em "bytecode")
:constants (get (get fn-em "pool") "entries")
:upvalue-count (len upvals)})
(code-idx (pool-add (get em "pool") code)))
(emit-op em 51) ;; OP_CLOSURE
(emit-u16 em code-idx)
;; Emit upvalue descriptors: for each captured variable,
;; (is_local, index) — tells the VM where to find the value.
;; is_local=1: capture from enclosing frame's local slot
;; is_local=0: capture from enclosing frame's upvalue
(for-each (fn (uv)
(emit-byte em (if (get uv "is-local") 1 0))
(emit-byte em (get uv "index")))
upvals)))))
(define compile-define
(fn (em args scope)
(let ((name-expr (first args))
(name (if (= (type-of name-expr) "symbol")
(symbol-name name-expr)
name-expr))
;; Handle :effects annotation: (define name :effects [...] value)
;; Skip keyword-value pairs between name and body
(value (let ((rest-args (rest args)))
(if (and (not (empty? rest-args))
(= (type-of (first rest-args)) "keyword"))
;; Skip :keyword value pairs until we hit the body
(let ((skip-annotations
(fn (items)
(if (empty? items) nil
(if (= (type-of (first items)) "keyword")
(skip-annotations (rest (rest items)))
(first items))))))
(skip-annotations rest-args))
(first rest-args)))))
;; Inside a function body, define creates a LOCAL binding.
;; At top level (no enclosing function scope), define creates a global.
;; Local binding prevents recursive calls from overwriting
;; each other's defines in the flat globals hashtable.
(if (not (nil? (get scope "parent")))
;; Local define — allocate slot, compile value, set local
(let ((slot (scope-define-local scope name)))
(compile-expr em value scope false)
(emit-op em 17) ;; OP_LOCAL_SET
(emit-byte em slot))
;; Top-level define — global
(let ((name-idx (pool-add (get em "pool") name)))
(compile-expr em value scope false)
(emit-op em 128) ;; OP_DEFINE
(emit-u16 em name-idx))))))
(define compile-set
(fn (em args scope)
(let ((name (if (= (type-of (first args)) "symbol")
(symbol-name (first args))
(first args)))
(value (nth args 1))
(resolved (scope-resolve scope name)))
(compile-expr em value scope false)
(cond
(= (get resolved "type") "local")
(do (emit-op em 17) ;; OP_LOCAL_SET
(emit-byte em (get resolved "index")))
(= (get resolved "type") "upvalue")
(do (emit-op em 19) ;; OP_UPVALUE_SET
(emit-byte em (get resolved "index")))
:else
(let ((idx (pool-add (get em "pool") name)))
(emit-op em 21) ;; OP_GLOBAL_SET
(emit-u16 em idx))))))
(define compile-quote
(fn (em args)
(if (empty? args)
(emit-op em 2) ;; OP_NIL
(emit-const em (first args)))))
(define compile-cond
(fn (em args scope tail?)
"Compile (cond test1 body1 test2 body2 ... :else fallback)."
(if (< (len args) 2)
(emit-op em 2) ;; OP_NIL
(let ((test (first args))
(body (nth args 1))
(rest-clauses (if (> (len args) 2) (slice args 2) (list))))
(if (or (and (= (type-of test) "keyword") (= (keyword-name test) "else"))
(= test true))
;; else clause — just compile the body
(compile-expr em body scope tail?)
(do
(compile-expr em test scope false)
(emit-op em 33) ;; OP_JUMP_IF_FALSE
(let ((skip (current-offset em)))
(emit-i16 em 0)
(compile-expr em body scope tail?)
(emit-op em 32) ;; OP_JUMP
(let ((end-jump (current-offset em)))
(emit-i16 em 0)
(patch-i16 em skip (- (current-offset em) (+ skip 2)))
(compile-cond em rest-clauses scope tail?)
(patch-i16 em end-jump (- (current-offset em) (+ end-jump 2)))))))))))
(define compile-case
(fn (em args scope tail?)
"Compile (case expr val1 body1 val2 body2 ... :else fallback)."
;; Desugar to nested if: evaluate expr once, then compare
(compile-expr em (first args) scope false)
(let ((clauses (rest args)))
(compile-case-clauses em clauses scope tail?))))
(define compile-case-clauses
(fn (em clauses scope tail?)
(if (< (len clauses) 2)
(do (emit-op em 5) (emit-op em 2)) ;; POP match-val, push NIL
(let ((test (first clauses))
(body (nth clauses 1))
(rest-clauses (if (> (len clauses) 2) (slice clauses 2) (list))))
(if (or (and (= (type-of test) "keyword") (= (keyword-name test) "else"))
(= test true))
(do (emit-op em 5) ;; POP match-val
(compile-expr em body scope tail?))
(do
(emit-op em 6) ;; DUP match-val
(compile-expr em test scope false)
(let ((name-idx (pool-add (get em "pool") "=")))
(emit-op em 52) (emit-u16 em name-idx) (emit-byte em 2)) ;; CALL_PRIM "=" 2
(emit-op em 33) ;; JUMP_IF_FALSE
(let ((skip (current-offset em)))
(emit-i16 em 0)
(emit-op em 5) ;; POP match-val
(compile-expr em body scope tail?)
(emit-op em 32) ;; JUMP
(let ((end-jump (current-offset em)))
(emit-i16 em 0)
(patch-i16 em skip (- (current-offset em) (+ skip 2)))
(compile-case-clauses em rest-clauses scope tail?)
(patch-i16 em end-jump (- (current-offset em) (+ end-jump 2)))))))))))
(define compile-thread
(fn (em args scope tail?)
"Compile (-> val (f1 a) (f2 b)) by desugaring to nested calls."
(if (empty? args)
(emit-op em 2)
(if (= (len args) 1)
(compile-expr em (first args) scope tail?)
;; Desugar: (-> x (f a)) → (f x a)
(let ((val-expr (first args))
(forms (rest args)))
(compile-thread-step em val-expr forms scope tail?))))))
(define compile-thread-step
(fn (em val-expr forms scope tail?)
(if (empty? forms)
(compile-expr em val-expr scope tail?)
(let ((form (first forms))
(rest-forms (rest forms))
(is-tail (and tail? (empty? rest-forms))))
;; Build desugared call: (f val args...)
(let ((call-expr
(if (list? form)
;; (-> x (f a b)) → (f x a b)
(concat (list (first form) val-expr) (rest form))
;; (-> x f) → (f x)
(list form val-expr))))
(if (empty? rest-forms)
(compile-expr em call-expr scope is-tail)
(do
(compile-expr em call-expr scope false)
;; Thread result through remaining forms
;; Store in temp, compile next step
;; Actually, just compile sequentially — each step returns a value
(compile-thread-step em call-expr rest-forms scope tail?))))))))
(define compile-defcomp
(fn (em args scope)
"Compile defcomp/defisland — delegates to runtime via GLOBAL_GET + CALL."
(let ((name-idx (pool-add (get em "pool") "eval-defcomp")))
(emit-op em 20) (emit-u16 em name-idx)) ;; GLOBAL_GET fn
(emit-const em (concat (list (make-symbol "defcomp")) args))
(emit-op em 48) (emit-byte em 1))) ;; CALL 1
(define compile-defmacro
(fn (em args scope)
"Compile defmacro — delegates to runtime via GLOBAL_GET + CALL."
(let ((name-idx (pool-add (get em "pool") "eval-defmacro")))
(emit-op em 20) (emit-u16 em name-idx)) ;; GLOBAL_GET fn
(emit-const em (concat (list (make-symbol "defmacro")) args))
(emit-op em 48) (emit-byte em 1)))
(define compile-quasiquote
(fn (em expr scope)
"Compile quasiquote inline — walks the template at compile time,
emitting code that builds the structure at runtime. Unquoted
expressions are compiled normally (resolving locals/upvalues),
avoiding the qq-expand-runtime env-lookup limitation."
(compile-qq-expr em expr scope)))
(define compile-qq-expr
(fn (em expr scope)
"Compile a quasiquote sub-expression."
(if (not (= (type-of expr) "list"))
;; Atom — emit as constant
(emit-const em expr)
(if (empty? expr)
;; Empty list
(do (emit-op em 64) (emit-u16 em 0)) ;; OP_LIST 0
(let ((head (first expr)))
(if (and (= (type-of head) "symbol")
(= (symbol-name head) "unquote"))
;; (unquote expr) — compile the expression
(compile-expr em (nth expr 1) scope false)
;; List — compile elements, handling splice-unquote
(compile-qq-list em expr scope)))))))
(define compile-qq-list
(fn (em items scope)
"Compile a quasiquote list. Handles splice-unquote by building
segments and concatenating them."
(let ((has-splice (some (fn (item)
(and (= (type-of item) "list")
(>= (len item) 2)
(= (type-of (first item)) "symbol")
(= (symbol-name (first item)) "splice-unquote")))
items)))
(if (not has-splice)
;; No splicing — compile each element, then OP_LIST
(do
(for-each (fn (item) (compile-qq-expr em item scope)) items)
(emit-op em 64) (emit-u16 em (len items))) ;; OP_LIST N
;; Has splicing — build segments and concat
;; Strategy: accumulate non-spliced items into a pending list,
;; flush as OP_LIST when hitting a splice, concat all segments.
(let ((segment-count 0)
(pending 0))
(for-each
(fn (item)
(if (and (= (type-of item) "list")
(>= (len item) 2)
(= (type-of (first item)) "symbol")
(= (symbol-name (first item)) "splice-unquote"))
;; Splice-unquote: flush pending, compile spliced expr
(do
(when (> pending 0)
(emit-op em 64) (emit-u16 em pending) ;; OP_LIST for pending
(set! segment-count (+ segment-count 1))
(set! pending 0))
;; Compile the spliced expression
(compile-expr em (nth item 1) scope false)
(set! segment-count (+ segment-count 1)))
;; Normal element — compile and count as pending
(do
(compile-qq-expr em item scope)
(set! pending (+ pending 1)))))
items)
;; Flush remaining pending items
(when (> pending 0)
(emit-op em 64) (emit-u16 em pending)
(set! segment-count (+ segment-count 1)))
;; Concat all segments
(when (> segment-count 1)
(let ((concat-idx (pool-add (get em "pool") "concat")))
;; concat takes N args — call with all segments
(emit-op em 52) (emit-u16 em concat-idx)
(emit-byte em segment-count))))))))
;; --------------------------------------------------------------------------
;; Function call compilation
;; --------------------------------------------------------------------------
(define compile-call
(fn (em head args scope tail?)
;; Check for known primitives
(let ((is-prim (and (= (type-of head) "symbol")
(let ((name (symbol-name head)))
(and (not (= (get (scope-resolve scope name) "type") "local"))
(not (= (get (scope-resolve scope name) "type") "upvalue"))
(primitive? name))))))
(if is-prim
;; Direct primitive call via CALL_PRIM
(let ((name (symbol-name head))
(argc (len args))
(name-idx (pool-add (get em "pool") name)))
(for-each (fn (a) (compile-expr em a scope false)) args)
(emit-op em 52) ;; OP_CALL_PRIM
(emit-u16 em name-idx)
(emit-byte em argc))
;; General call
(do
(compile-expr em head scope false)
(for-each (fn (a) (compile-expr em a scope false)) args)
(if tail?
(do (emit-op em 49) ;; OP_TAIL_CALL
(emit-byte em (len args)))
(do (emit-op em 48) ;; OP_CALL
(emit-byte em (len args)))))))))
;; --------------------------------------------------------------------------
;; Top-level API
;; --------------------------------------------------------------------------
(define compile
(fn (expr)
"Compile a single SX expression to a bytecode module."
(let ((em (make-emitter))
(scope (make-scope nil)))
(compile-expr em expr scope false)
(emit-op em 50) ;; OP_RETURN
{:bytecode (get em "bytecode")
:constants (get (get em "pool") "entries")})))
(define compile-module
(fn (exprs)
"Compile a list of top-level expressions to a bytecode module."
(let ((em (make-emitter))
(scope (make-scope nil)))
(for-each (fn (expr)
(compile-expr em expr scope false)
(emit-op em 5)) ;; OP_POP between top-level exprs
(init exprs))
;; Last expression's value is the module result
(compile-expr em (last exprs) scope false)
(emit-op em 50) ;; OP_RETURN
{:bytecode (get em "bytecode")
:constants (get (get em "pool") "entries")})))

48
lib/content.sx Normal file
View File

@@ -0,0 +1,48 @@
;; ==========================================================================
;; content.sx — 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.
;;
;; This is a library built on top of freeze.sx. It is NOT part of the
;; core evaluator. Load order: evaluator.sx → freeze.sx → content.sx
;;
;; 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))))

94
lib/freeze.sx Normal file
View File

@@ -0,0 +1,94 @@
;; ==========================================================================
;; freeze.sx — Serializable state boundaries
;;
;; Freeze scopes collect signals registered within them. On freeze,
;; their current values are serialized to SX. On thaw, values are
;; restored. Multiple named scopes can coexist independently.
;;
;; This is a library built on top of the evaluator's scoped effects
;; (scope-push!/scope-pop!/context) and signal system. It is NOT
;; part of the core evaluator — it loads after evaluator.sx.
;;
;; 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))))))

275
lib/stdlib.sx Normal file
View File

@@ -0,0 +1,275 @@
;; ==========================================================================
;; stdlib.sx — Standard library functions
;;
;; Every function here is expressed in SX using the irreducible primitive
;; set. They are library functions — in band, auditable, portable.
;;
;; Depends on: evaluator.sx (special forms)
;; Must load before: render.sx, freeze.sx, types.sx, user code
;; ==========================================================================
;; Logic + comparison: not, !=, <=, >= stay as primitives.
;; Replacing them with SX lambdas changes behavior inside shift/reset
;; because the transpiled evaluator code uses them directly.
(define eq? (fn (a b) (= a b)))
(define eqv? (fn (a b) (= a b)))
(define equal? (fn (a b) (= a b)))
;; --------------------------------------------------------------------------
;; Type predicates
;; --------------------------------------------------------------------------
;; nil? stays as primitive — host's type-of uses it internally.
(define boolean?
(fn (x) (= (type-of x) "boolean")))
(define number?
(fn (x) (= (type-of x) "number")))
(define string?
(fn (x) (= (type-of x) "string")))
(define list?
(fn (x) (= (type-of x) "list")))
(define dict?
(fn (x) (= (type-of x) "dict")))
(define continuation?
(fn (x) (= (type-of x) "continuation")))
(define zero?
(fn (n) (= n 0)))
(define odd?
(fn (n) (= (mod n 2) 1)))
(define even?
(fn (n) (= (mod n 2) 0)))
(define empty?
(fn (coll) (or (nil? coll) (= (len coll) 0))))
;; --------------------------------------------------------------------------
;; Arithmetic
;; --------------------------------------------------------------------------
;; inc and dec stay as primitives — used inside continuation contexts.
(define abs
(fn (x) (if (< x 0) (- x) x)))
(define ceil
(fn (x)
(let ((f (floor x)))
(if (= x f) f (+ f 1)))))
(define round
(fn (x ndigits)
(if (nil? ndigits)
(floor (+ x 0.5))
(let ((f (pow 10 ndigits)))
(/ (floor (+ (* x f) 0.5)) f)))))
(define min
(fn (a b) (if (< a b) a b)))
(define max
(fn (a b) (if (> a b) a b)))
(define clamp
(fn (x lo hi) (max lo (min hi x))))
;; --------------------------------------------------------------------------
;; Collection accessors
;; --------------------------------------------------------------------------
(define first
(fn (coll)
(if (and coll (> (len coll) 0)) (get coll 0) nil)))
(define last
(fn (coll)
(if (and coll (> (len coll) 0))
(get coll (- (len coll) 1))
nil)))
(define rest
(fn (coll) (if coll (slice coll 1) (list))))
(define nth
(fn (coll n)
(if (and coll (>= n 0) (< n (len coll)))
(get coll n)
nil)))
(define cons
(fn (x coll) (concat (list x) (or coll (list)))))
(define append
(fn (coll x)
(if (list? x) (concat coll x) (concat coll (list x)))))
;; --------------------------------------------------------------------------
;; Collection transforms
;; --------------------------------------------------------------------------
(define reverse
(fn (coll)
(reduce (fn (acc x) (cons x acc)) (list) coll)))
(define flatten
(fn (coll)
(reduce
(fn (acc x)
(if (list? x) (concat acc x) (concat acc (list x))))
(list) coll)))
(define range
(fn (start end step)
(let ((s (if (nil? step) 1 step))
(result (list)))
(let loop ((i start))
(when (< i end)
(append! result i)
(loop (+ i s))))
result)))
(define chunk-every
(fn (coll n)
(let ((result (list))
(clen (len coll)))
(let loop ((i 0))
(when (< i clen)
(append! result (slice coll i (min (+ i n) clen)))
(loop (+ i n))))
result)))
(define zip-pairs
(fn (coll)
(let ((result (list))
(clen (len coll)))
(let loop ((i 0))
(when (< i (- clen 1))
(append! result (list (get coll i) (get coll (+ i 1))))
(loop (+ i 1))))
result)))
;; --------------------------------------------------------------------------
;; Dict operations
;; --------------------------------------------------------------------------
(define vals
(fn (d)
(map (fn (k) (get d k)) (keys d))))
(define has-key?
(fn (d key)
(some (fn (k) (= k key)) (keys d))))
(define assoc
(fn (d key val)
(let ((result (merge d (dict))))
(dict-set! result key val)
result)))
(define dissoc
(fn (d key)
(let ((result (dict)))
(for-each
(fn (k)
(when (!= k key)
(dict-set! result k (get d k))))
(keys d))
result)))
(define into
(fn (target coll)
(cond
(list? target)
(if (list? coll)
(concat coll (list))
(let ((result (list)))
(for-each (fn (k) (append! result (list k (get coll k)))) (keys coll))
result))
(dict? target)
(let ((result (dict)))
(for-each
(fn (pair)
(when (and (list? pair) (>= (len pair) 2))
(dict-set! result (get pair 0) (get pair 1))))
coll)
result)
:else target)))
;; --------------------------------------------------------------------------
;; String operations
;; --------------------------------------------------------------------------
(define upcase (fn (s) (upper s)))
(define downcase (fn (s) (lower s)))
(define string-length (fn (s) (len s)))
(define substring (fn (s start end) (slice s start end)))
(define string-contains?
(fn (s needle) (!= (index-of s needle) -1)))
(define starts-with?
(fn (s prefix) (= (index-of s prefix) 0)))
(define ends-with?
(fn (s suffix)
(let ((slen (len s))
(plen (len suffix)))
(if (< slen plen) false
(= (slice s (- slen plen)) suffix)))))
;; split, join, replace stay as primitives — the stdlib versions cause
;; stack overflows due to PRIMITIVES entry shadowing in the transpiled output.
(define contains?
(fn (coll key)
(cond
(string? coll) (!= (index-of coll (str key)) -1)
(dict? coll) (has-key? coll key)
(list? coll) (some (fn (x) (= x key)) coll)
:else false)))
;; --------------------------------------------------------------------------
;; Text utilities
;; --------------------------------------------------------------------------
(define pluralize
(fn (count singular plural)
(if (= count 1)
(or singular "")
(or plural "s"))))
(define escape
(fn (s)
(let ((r (str s)))
(set! r (replace r "&" "&amp;"))
(set! r (replace r "<" "&lt;"))
(set! r (replace r ">" "&gt;"))
(set! r (replace r "\"" "&quot;"))
(set! r (replace r "'" "&#x27;"))
r)))
(define parse-datetime
(fn (s) (if s (str s) nil)))
(define assert
(fn (condition message)
(when (not condition)
(error (or message "Assertion failed")))
true))

368
lib/tests/test-continuations-advanced.sx Normal file
View File

@@ -0,0 +1,368 @@
;; ==========================================================================
;; test-continuations-advanced.sx — Stress tests for multi-shot continuations
;; and frame-based dynamic scope
;;
;; Requires: test-framework.sx loaded, continuations + scope extensions enabled.
;;
;; Tests the CEK continuation + ProvideFrame/ScopeAccFrame system under:
;; - Multi-shot (k invoked 0, 1, 2, 3+ times)
;; - Continuation composition across nested resets
;; - provide/context: dynamic variable binding via kont walk
;; - provide values preserved across shift/resume
;; - scope/emit!/emitted: accumulator frames in kont
;; - Accumulator frames preserved across shift/resume
;; ==========================================================================
;; --------------------------------------------------------------------------
;; 1. Multi-shot continuations
;; --------------------------------------------------------------------------
(defsuite "multi-shot-continuations"
(deftest "k invoked 3 times returns list of results"
;; Each (k N) resumes (+ 1 N) independently.
;; Shift body collects all three results into a list.
(assert-equal (list 11 21 31)
(reset (+ 1 (shift k (list (k 10) (k 20) (k 30)))))))
(deftest "k invoked via map over input list"
;; map applies k to each element; each resume computes (+ 1 elem).
(assert-equal (list 11 21 31)
(reset (+ 1 (shift k (map k (list 10 20 30)))))))
(deftest "k invoked zero times — abort with plain value"
;; Shift body ignores k and returns 42 directly.
;; The outer (+ 1 ...) hole is never filled.
(assert-equal 42
(reset (+ 1 (shift k 42)))))
(deftest "k invoked conditionally — true branch calls k"
;; Only the true branch calls k; result is (+ 1 10) = 11.
(assert-equal 11
(reset (+ 1 (shift k (if true (k 10) 99))))))
(deftest "k invoked conditionally — false branch skips k"
;; False branch returns 99 directly without invoking k.
(assert-equal 99
(reset (+ 1 (shift k (if false (k 10) 99))))))
(deftest "k invoked inside let binding"
;; (k 5) = (+ 1 5) = 6; x is bound to 6; (* x 2) = 12.
(assert-equal 12
(reset (+ 1 (shift k (let ((x (k 5))) (* x 2)))))))
(deftest "nested shift — inner k2 called by outer k1"
;; k1 = (fn (v) (+ 1 v)), k2 = (fn (v) (+ 2 v))
;; (k2 3) = 5, (k1 5) = 6
;; inner reset returns 6 to shift-k1 body; (+ 10 6) = 16
;; outer reset returns 16
(assert-equal 16
(reset (+ 1 (shift k1 (+ 10 (reset (+ 2 (shift k2 (k1 (k2 3)))))))))))
(deftest "k called twice accumulates both results"
;; Two invocations in a list: (k 1) = 2, (k 2) = 3.
(assert-equal (list 2 3)
(reset (+ 1 (shift k (list (k 1) (k 2)))))))
(deftest "multi-shot k is idempotent — same arg gives same result"
;; Calling k with the same argument twice should yield equal values.
(let ((results (reset (+ 1 (shift k (list (k 5) (k 5)))))))
(assert-equal (nth results 0) (nth results 1)))))
;; --------------------------------------------------------------------------
;; 2. Continuation composition
;; --------------------------------------------------------------------------
(defsuite "continuation-composition"
(deftest "two independent resets have isolated continuations"
;; Each reset is entirely separate — the two k values are unrelated.
(let ((r1 (reset (+ 1 (shift k1 (k1 10)))))
(r2 (reset (+ 100 (shift k2 (k2 5))))))
(assert-equal 11 r1)
(assert-equal 105 r2)))
(deftest "continuation passed to helper function and invoked there"
;; apply-k is a plain lambda; it calls the continuation it receives.
(let ((apply-k (fn (k v) (k v))))
(assert-equal 15
(reset (+ 5 (shift k (apply-k k 10)))))))
(deftest "continuation stored in variable and invoked later"
;; reset returns k itself; we then invoke it outside the reset form.
(let ((k (reset (shift k k))))
;; k = identity continuation for (reset _), so (k v) = v
(assert-true (continuation? k))
(assert-equal 42 (k 42))
(assert-equal 7 (k 7))))
(deftest "continuation stored then called with multiple values"
;; k from (+ 1 hole); invoking k with different args gives different results.
(let ((k (reset (+ 1 (shift k k)))))
(assert-equal 11 (k 10))
(assert-equal 21 (k 20))
(assert-equal 31 (k 30))))
(deftest "continuation as argument to map — applied to a list"
;; k = (fn (v) (+ 10 v)); map applies it to each element.
(let ((k (reset (+ 10 (shift k k)))))
(assert-equal (list 11 12 13)
(map k (list 1 2 3)))))
(deftest "compose two continuations from nested resets"
;; k1 = (fn (v) (+ 1 v)), k2 = (fn (v) (+ 10 v))
;; (k2 0) = 10, (k1 10) = 11; outer reset returns 11.
(assert-equal 11
(reset (+ 1 (shift k1 (reset (+ 10 (shift k2 (k1 (k2 0))))))))))
(deftest "continuation predicate holds inside and after capture"
;; k captured inside shift is a continuation; so is one returned by reset.
(assert-true
(reset (shift k (continuation? k))))
(assert-true
(continuation? (reset (shift k k))))))
;; --------------------------------------------------------------------------
;; 3. provide / context — basic dynamic scope
;; --------------------------------------------------------------------------
(defsuite "provide-context-basic"
(deftest "simple provide and context"
;; (context \"x\") walks the kont and finds the ProvideFrame for \"x\".
(assert-equal 42
(provide "x" 42 (context "x"))))
(deftest "nested provide — inner shadows outer"
;; The nearest ProvideFrame wins when searching kont.
(assert-equal 2
(provide "x" 1
(provide "x" 2
(context "x")))))
(deftest "outer provide visible after inner scope exits"
;; After the inner provide's body finishes, its frame is gone.
;; The next (context \"x\") walks past it to the outer frame.
(assert-equal 1
(provide "x" 1
(do
(provide "x" 2 (context "x"))
(context "x")))))
(deftest "multiple provide names are independent"
;; Each name has its own ProvideFrame; they don't interfere.
(assert-equal 3
(provide "a" 1
(provide "b" 2
(+ (context "a") (context "b"))))))
(deftest "context with default — provider present returns provided value"
;; Second arg to context is the default; present provider overrides it.
(assert-equal 42
(provide "x" 42 (context "x" 0))))
(deftest "context with default — no provider returns default"
;; When no ProvideFrame exists for the name, the default is returned.
(assert-equal 0
(provide "y" 99 (context "x" 0))))
(deftest "provide with computed value"
;; The value expression is evaluated before pushing the frame.
(assert-equal 6
(provide "n" (* 2 3) (context "n"))))
(deftest "provide value is the exact bound value (no double-eval)"
;; Passing a list as the provided value should return that list.
(let ((result (provide "items" (list 1 2 3) (context "items"))))
(assert-equal (list 1 2 3) result))))
;; --------------------------------------------------------------------------
;; 4. provide across shift — scope survives continuation capture/resume
;; --------------------------------------------------------------------------
(defsuite "provide-across-shift"
(deftest "provide value preserved across shift and k invocation"
;; The ProvideFrame lives in the kont beyond the ResetFrame.
;; When k resumes, the frame is still there — context finds it.
(assert-equal "dark"
(reset
(provide "theme" "dark"
(+ 0 (shift k (k 0)))
(context "theme")))))
(deftest "two provides both preserved across shift"
;; Both ProvideFrames must survive the shift/resume round-trip.
(assert-equal 3
(reset
(provide "a" 1
(provide "b" 2
(+ 0 (shift k (k 0)))
(+ (context "a") (context "b")))))))
(deftest "context visible inside provide but not in shift body"
;; shift body runs OUTSIDE the reset boundary — provide is not in scope.
;; But context with a default should return the default.
(assert-equal "fallback"
(reset
(provide "theme" "light"
(shift k (context "theme" "fallback"))))))
(deftest "context after k invocation restores scope frame"
;; k was captured with the ProvideFrame in its saved kont.
;; After (k v) resumes, context finds the frame again.
(let ((result
(reset
(provide "color" "red"
(+ 0 (shift k (k 0)))
(context "color")))))
(assert-equal "red" result)))
(deftest "multi-shot: each k invocation reinstates captured ProvideFrame"
;; k captures the ProvideFrame for "n" (it's inside the reset delimiter).
;; Invoking k twice: each time (context "n") in the resumed body is valid.
;; The shift body collects (context "n") from each resumed branch.
(let ((readings
(reset
(provide "n" 10
(+ 0 (shift k
(list
(k 0)
(k 0))))
(context "n")))))
;; Each (k 0) resumes and returns (context "n") = 10.
(assert-equal (list 10 10) readings))))
;; --------------------------------------------------------------------------
;; 5. scope / emit! / emitted — accumulator frames
;; --------------------------------------------------------------------------
(defsuite "scope-emit-basic"
(deftest "simple scope: emit two items and read emitted list"
;; emit! appends to the nearest ScopeAccFrame; emitted returns the list.
(assert-equal (list "a" "b")
(scope "css"
(emit! "css" "a")
(emit! "css" "b")
(emitted "css"))))
(deftest "empty scope returns empty list for emitted"
;; No emit! calls means the accumulator stays empty.
(assert-equal (list)
(scope "css"
(emitted "css"))))
(deftest "emit! order is preserved"
;; Items appear in emission order, not reverse.
(assert-equal (list 1 2 3 4 5)
(scope "nums"
(emit! "nums" 1)
(emit! "nums" 2)
(emit! "nums" 3)
(emit! "nums" 4)
(emit! "nums" 5)
(emitted "nums"))))
(deftest "nested scopes: inner does not see outer's emitted"
;; The inner scope has its own ScopeAccFrame; kont-find-scope-acc
;; stops at the first matching name, so inner is fully isolated.
(let ((inner-emitted
(scope "css"
(emit! "css" "outer")
(scope "css"
(emit! "css" "inner")
(emitted "css")))))
(assert-equal (list "inner") inner-emitted)))
(deftest "two differently-named scopes are independent"
;; emit! to \"a\" must not appear in emitted \"b\" and vice versa.
(let ((result-a nil) (result-b nil))
(scope "a"
(scope "b"
(emit! "a" "for-a")
(emit! "b" "for-b")
(set! result-b (emitted "b")))
(set! result-a (emitted "a")))
(assert-equal (list "for-a") result-a)
(assert-equal (list "for-b") result-b)))
(deftest "scope body returns last expression value"
;; scope itself returns the last body expression, not the emitted list.
(assert-equal 42
(scope "x"
(emit! "x" "ignored")
42)))
(deftest "scope with :value acts as provide for context"
;; When :value is given, the ScopeAccFrame also carries the value.
;; context should be able to read it (if the evaluator searches scope-acc
;; frames the same way as provide frames).
;; NOTE: this tests the :value keyword path in step-sf-scope.
;; If context only walks ProvideFrames, use provide directly instead.
;; We verify at minimum that :value does not crash.
(let ((r (try-call (fn ()
(scope "x" :value 42
(emitted "x"))))))
(assert-true (get r "ok")))))
;; --------------------------------------------------------------------------
;; 6. scope / emit! across shift — accumulator frames survive continuation
;; --------------------------------------------------------------------------
(defsuite "scope-emit-across-shift"
(deftest "emit before and after shift both appear in emitted"
;; The ScopeAccFrame is in the kont beyond the ResetFrame.
;; After k resumes, the frame is still present; the second emit!
;; appends to it.
(assert-equal (list "a" "b")
(reset
(scope "acc"
(emit! "acc" "a")
(+ 0 (shift k (k 0)))
(emit! "acc" "b")
(emitted "acc")))))
(deftest "emit only before shift — one item in emitted"
;; emit! before shift commits to the frame; shift/resume preserves it.
(assert-equal (list "only")
(reset
(scope "log"
(emit! "log" "only")
(+ 0 (shift k (k 0)))
(emitted "log")))))
(deftest "emit only after shift — one item in emitted"
;; No emit! before shift; the frame starts empty; post-resume emit! adds one.
(assert-equal (list "after")
(reset
(scope "log"
(+ 0 (shift k (k 0)))
(emit! "log" "after")
(emitted "log")))))
(deftest "emits on both sides of single shift boundary"
;; Single shift/resume; emits before and after are preserved.
(assert-equal (list "a" "b")
(reset
(scope "trace"
(emit! "trace" "a")
(+ 0 (shift k (k 0)))
(emit! "trace" "b")
(emitted "trace")))))
(deftest "emitted inside shift body reads current accumulator"
;; kont in the shift body is rest-kont (outer kont beyond the reset).
;; The ScopeAccFrame should be present if it was installed before reset.
;; emit! and emitted inside shift body use that outer frame.
(let ((outer-acc nil))
(scope "outer"
(reset
(shift k
(do
(emit! "outer" "from-shift")
(set! outer-acc (emitted "outer")))))
nil)
(assert-equal (list "from-shift") outer-acc))))

140
lib/tests/test-continuations.sx Normal file
View File

@@ -0,0 +1,140 @@
;; ==========================================================================
;; test-continuations.sx — Tests for delimited continuations (shift/reset)
;;
;; Requires: test-framework.sx loaded, continuations extension enabled.
;; ==========================================================================
;; --------------------------------------------------------------------------
;; 1. Basic shift/reset
;; --------------------------------------------------------------------------
(defsuite "basic-shift-reset"
(deftest "reset passthrough"
(assert-equal 42 (reset 42)))
(deftest "reset evaluates expression"
(assert-equal 3 (reset (+ 1 2))))
(deftest "shift aborts to reset"
(assert-equal 42 (reset (+ 1 (shift k 42)))))
(deftest "shift with single invoke"
(assert-equal 11 (reset (+ 1 (shift k (k 10))))))
(deftest "shift with multiple invokes"
(assert-equal (list 11 21)
(reset (+ 1 (shift k (list (k 10) (k 20)))))))
(deftest "shift returns string"
(assert-equal "aborted"
(reset (+ 1 (shift k "aborted")))))
(deftest "shift returns nil"
(assert-nil (reset (+ 1 (shift k nil)))))
(deftest "nested expression with shift"
(assert-equal 16
(+ 1 (reset (+ 10 (shift k (k 5))))))))
;; --------------------------------------------------------------------------
;; 2. Continuation predicates
;; --------------------------------------------------------------------------
(defsuite "continuation-predicates"
(deftest "k is a continuation inside shift"
(assert-true
(reset (shift k (continuation? k)))))
(deftest "number is not a continuation"
(assert-false (continuation? 42)))
(deftest "function is not a continuation"
(assert-false (continuation? (fn (x) x))))
(deftest "nil is not a continuation"
(assert-false (continuation? nil)))
(deftest "string is not a continuation"
(assert-false (continuation? "hello"))))
;; --------------------------------------------------------------------------
;; 3. Continuation as value
;; --------------------------------------------------------------------------
(defsuite "continuation-as-value"
(deftest "k returned from reset"
;; shift body returns k itself — reset returns the continuation
(let ((k (reset (+ 1 (shift k k)))))
(assert-true (continuation? k))
(assert-equal 11 (k 10))))
(deftest "invoke returned k multiple times"
(let ((k (reset (+ 1 (shift k k)))))
(assert-equal 11 (k 10))
(assert-equal 21 (k 20))
(assert-equal 2 (k 1))))
(deftest "pass k to another function"
(let ((apply-k (fn (k v) (k v))))
(assert-equal 15
(reset (+ 5 (shift k (apply-k k 10)))))))
(deftest "k in data structure"
(let ((result (reset (+ 1 (shift k (list k 42))))))
(assert-equal 42 (nth result 1))
(assert-equal 100 ((first result) 99)))))
;; --------------------------------------------------------------------------
;; 4. Nested reset
;; --------------------------------------------------------------------------
(defsuite "nested-reset"
(deftest "inner reset captures independently"
(assert-equal 12
(reset (+ 1 (reset (+ 10 (shift k (k 1))))))))
(deftest "inner abort outer continues"
(assert-equal 43
(reset (+ 1 (reset (+ 10 (shift k 42)))))))
(deftest "outer shift captures outer reset"
(assert-equal 100
(reset (+ 1 (shift k (k 99)))))))
;; --------------------------------------------------------------------------
;; 5. Interaction with scoped effects
;; --------------------------------------------------------------------------
(defsuite "continuations-with-scopes"
(deftest "provide survives resume"
(assert-equal "dark"
(reset (provide "theme" "dark"
(+ 0 (shift k (k 0)))
(context "theme")))))
(deftest "scope and emit across shift"
(assert-equal (list "a")
(reset (scope "acc"
(emit! "acc" "a")
(+ 0 (shift k (k 0)))
(emitted "acc"))))))
;; --------------------------------------------------------------------------
;; 6. TCO interaction
;; --------------------------------------------------------------------------
(defsuite "tco-interaction"
(deftest "shift in tail position"
(assert-equal 42
(reset (if true (shift k (k 42)) 0))))
(deftest "shift in let body"
(assert-equal 10
(reset (let ((x 5))
(+ x (shift k (k 5))))))))

75
lib/tests/test-freeze.sx Normal file
View File

@@ -0,0 +1,75 @@
;; ==========================================================================
;; test-freeze.sx — Freeze scope and content addressing tests
;; ==========================================================================
(defsuite "freeze-scope"
(deftest "freeze captures signal values"
(let ((s (signal 42)))
(freeze-scope "t1" (fn ()
(freeze-signal "val" s)))
(let ((frozen (cek-freeze-scope "t1")))
(assert-equal "t1" (get frozen "name"))
(assert-equal 42 (get (get frozen "signals") "val")))))
(deftest "thaw restores signal values"
(let ((s (signal 10)))
(freeze-scope "t2" (fn ()
(freeze-signal "x" s)))
(let ((sx (freeze-to-sx "t2")))
(reset! s 999)
(assert-equal 999 (deref s))
(thaw-from-sx sx)
(assert-equal 10 (deref s)))))
(deftest "multiple signals in scope"
(let ((a (signal "hello"))
(b (signal 42))
(c (signal true)))
(freeze-scope "t3" (fn ()
(freeze-signal "a" a)
(freeze-signal "b" b)
(freeze-signal "c" c)))
(let ((frozen (cek-freeze-scope "t3")))
(assert-equal "hello" (get (get frozen "signals") "a"))
(assert-equal 42 (get (get frozen "signals") "b"))
(assert-equal true (get (get frozen "signals") "c")))))
(deftest "freeze-to-sx round trip"
(let ((s (signal "data")))
(freeze-scope "t4" (fn ()
(freeze-signal "s" s)))
(let ((sx (freeze-to-sx "t4")))
(assert-true (string? sx))
(assert-true (contains? sx "data"))
(reset! s "changed")
(thaw-from-sx sx)
(assert-equal "data" (deref s))))))
(defsuite "content-addressing"
(deftest "content-hash deterministic"
(assert-equal (content-hash "hello") (content-hash "hello")))
(deftest "content-hash different for different input"
(assert-false (= (content-hash "hello") (content-hash "world"))))
(deftest "content-put and get"
(let ((cid (content-put "test data")))
(assert-equal "test data" (content-get cid))))
(deftest "freeze-to-cid round trip"
(let ((s (signal 77)))
(freeze-scope "t5" (fn ()
(freeze-signal "v" s)))
(let ((cid (freeze-to-cid "t5")))
(assert-true (string? cid))
(reset! s 0)
(assert-true (thaw-from-cid cid))
(assert-equal 77 (deref s)))))
(deftest "same state same cid"
(let ((s (signal 42)))
(freeze-scope "t6" (fn ()
(freeze-signal "n" s)))
(let ((cid1 (freeze-to-cid "t6"))
(cid2 (freeze-to-cid "t6")))
(assert-equal cid1 cid2)))))

348
lib/tests/test-signals-advanced.sx Normal file
View File

@@ -0,0 +1,348 @@
;; ==========================================================================
;; test-signals-advanced.sx — Stress tests for the reactive signal system
;;
;; Requires: test-framework.sx loaded first.
;; Modules tested: signals.sx (signal, deref, reset!, swap!, computed,
;; effect, batch)
;;
;; Note: Multi-expression lambda bodies are wrapped in (do ...) for
;; compatibility with evaluators that support only single-expression bodies.
;; ==========================================================================
;; --------------------------------------------------------------------------
;; Signal basics extended
;; --------------------------------------------------------------------------
(defsuite "signal-basics-extended"
(deftest "signal with nil initial value"
(let ((s (signal nil)))
(assert-true (signal? s))
(assert-nil (deref s))))
(deftest "signal with list value"
(let ((s (signal (list 1 2 3))))
(assert-equal (list 1 2 3) (deref s))
(reset! s (list 4 5 6))
(assert-equal (list 4 5 6) (deref s))))
(deftest "signal with dict value"
(let ((s (signal {:name "alice" :score 42})))
(assert-equal "alice" (get (deref s) "name"))
(assert-equal 42 (get (deref s) "score"))))
(deftest "signal with lambda value"
(let ((fn-val (fn (x) (* x 2)))
(s (signal nil)))
(reset! s fn-val)
;; The stored lambda should be callable
(assert-equal 10 ((deref s) 5))))
(deftest "multiple signals independent of each other"
(let ((a (signal 1))
(b (signal 2))
(c (signal 3)))
(reset! a 10)
;; b and c must be unchanged
(assert-equal 10 (deref a))
(assert-equal 2 (deref b))
(assert-equal 3 (deref c))
(reset! b 20)
(assert-equal 10 (deref a))
(assert-equal 20 (deref b))
(assert-equal 3 (deref c))))
(deftest "deref returns current value not a stale snapshot"
(let ((s (signal "first")))
(let ((snap1 (deref s)))
(reset! s "second")
(let ((snap2 (deref s)))
;; snap1 holds the string "first" (immutable), snap2 is "second"
(assert-equal "first" snap1)
(assert-equal "second" snap2))))))
;; --------------------------------------------------------------------------
;; Computed chains
;; --------------------------------------------------------------------------
(defsuite "computed-chains"
(deftest "chain of three computed signals"
(let ((base (signal 2))
(doubled (computed (fn () (* 2 (deref base)))))
(tripled (computed (fn () (* 3 (deref doubled))))))
;; Initial: base=2 → doubled=4 → tripled=12
(assert-equal 4 (deref doubled))
(assert-equal 12 (deref tripled))
;; Update propagates through the entire chain
(reset! base 5)
(assert-equal 10 (deref doubled))
(assert-equal 30 (deref tripled))))
(deftest "computed depending on multiple signals"
(let ((x (signal 3))
(y (signal 4))
(hypo (computed (fn ()
;; sqrt(x^2 + y^2) — Pythagorean hypotenuse (integer approx)
(+ (* (deref x) (deref x))
(* (deref y) (deref y)))))))
(assert-equal 25 (deref hypo))
(reset! x 0)
(assert-equal 16 (deref hypo))
(reset! y 0)
(assert-equal 0 (deref hypo))))
(deftest "computed with conditional logic"
(let ((flag (signal true))
(a (signal 10))
(b (signal 99))
(result (computed (fn ()
(if (deref flag) (deref a) (deref b))))))
(assert-equal 10 (deref result))
(reset! flag false)
(assert-equal 99 (deref result))
(reset! b 42)
(assert-equal 42 (deref result))
(reset! flag true)
(assert-equal 10 (deref result))))
(deftest "diamond dependency: A->B, A->C, B+C->D"
;; A change in A must propagate via both B and C to D,
;; but D must still hold a coherent (not intermediate) value.
(let ((A (signal 1))
(B (computed (fn () (* 2 (deref A)))))
(C (computed (fn () (* 3 (deref A)))))
(D (computed (fn () (+ (deref B) (deref C))))))
;; A=1 → B=2, C=3 → D=5
(assert-equal 2 (deref B))
(assert-equal 3 (deref C))
(assert-equal 5 (deref D))
;; A=4 → B=8, C=12 → D=20
(reset! A 4)
(assert-equal 8 (deref B))
(assert-equal 12 (deref C))
(assert-equal 20 (deref D))))
(deftest "computed returns nil when source signal is nil"
(let ((s (signal nil))
(c (computed (fn ()
(let ((v (deref s)))
(when (not (nil? v)) (* v 2)))))))
(assert-nil (deref c))
(reset! s 7)
(assert-equal 14 (deref c))
(reset! s nil)
(assert-nil (deref c)))))
;; --------------------------------------------------------------------------
;; Effect patterns
;; --------------------------------------------------------------------------
(defsuite "effect-patterns"
(deftest "effect runs immediately on creation"
(let ((ran (signal false)))
(effect (fn () (reset! ran true)))
(assert-true (deref ran))))
(deftest "effect re-runs when dependency changes"
(let ((n (signal 0))
(calls (signal 0)))
(effect (fn () (do (deref n) (swap! calls inc))))
;; Initial run counts as 1
(assert-equal 1 (deref calls))
(reset! n 1)
(assert-equal 2 (deref calls))
(reset! n 2)
(assert-equal 3 (deref calls))))
(deftest "effect with multiple dependencies"
(let ((a (signal "x"))
(b (signal "y"))
(calls (signal 0)))
(effect (fn () (do (deref a) (deref b) (swap! calls inc))))
(assert-equal 1 (deref calls))
;; Changing a triggers re-run
(reset! a "x2")
(assert-equal 2 (deref calls))
;; Changing b also triggers re-run
(reset! b "y2")
(assert-equal 3 (deref calls))))
(deftest "effect cleanup function called on re-run"
(let ((trigger (signal 0))
(cleanups (signal 0)))
(effect (fn () (do
(deref trigger)
;; Return a cleanup function
(fn () (swap! cleanups inc)))))
;; First run — no previous cleanup to call
(assert-equal 0 (deref cleanups))
;; Second run — previous cleanup fires first
(reset! trigger 1)
(assert-equal 1 (deref cleanups))
;; Third run — second cleanup fires
(reset! trigger 2)
(assert-equal 2 (deref cleanups))))
(deftest "effect tracks only actually-deref'd signals"
;; An effect that conditionally reads signal B should only re-run
;; for B changes when B is actually read (flag=true).
(let ((flag (signal true))
(b (signal 0))
(calls (signal 0)))
(effect (fn () (do
(deref flag)
(when (deref flag) (deref b))
(swap! calls inc))))
;; Initial run reads both flag and b
(assert-equal 1 (deref calls))
;; flip flag to false — re-run, but now b is NOT deref'd
(reset! flag false)
(assert-equal 2 (deref calls))
;; Changing b should NOT trigger another run (b wasn't deref'd last time)
(reset! b 99)
(assert-equal 2 (deref calls)))))
;; --------------------------------------------------------------------------
;; Batch behavior
;; --------------------------------------------------------------------------
(defsuite "batch-behavior"
(deftest "batch coalesces multiple signal updates into one effect run"
(let ((a (signal 0))
(b (signal 0))
(run-count (signal 0)))
(effect (fn () (do (deref a) (deref b) (swap! run-count inc))))
;; Initial run
(assert-equal 1 (deref run-count))
;; Two writes inside a single batch → one effect run, not two
(batch (fn () (do
(reset! a 1)
(reset! b 2))))
(assert-equal 2 (deref run-count))))
(deftest "nested batch — inner batch does not flush, outer batch does"
(let ((s (signal 0))
(run-count (signal 0)))
(effect (fn () (do (deref s) (swap! run-count inc))))
(assert-equal 1 (deref run-count))
(batch (fn ()
(batch (fn ()
(reset! s 1)))
;; Still inside outer batch — should not have fired yet
(reset! s 2)))
;; Outer batch ends → exactly one more run
(assert-equal 2 (deref run-count))
;; Final value is the last write
(assert-equal 2 (deref s))))
(deftest "batch with computed — computed updates once not per signal write"
(let ((x (signal 0))
(y (signal 0))
(sum (computed (fn () (+ (deref x) (deref y)))))
(recomps (signal 0)))
;; Track recomputations by wrapping via an effect
(effect (fn () (do (deref sum) (swap! recomps inc))))
;; Initial: effect + computed both ran once
(assert-equal 1 (deref recomps))
(batch (fn () (do
(reset! x 10)
(reset! y 20))))
;; sum must reflect both changes
(assert-equal 30 (deref sum))
;; effect re-ran at most once more (not twice)
(assert-equal 2 (deref recomps))))
(deftest "batch executes the thunk"
;; batch runs the thunk for side effects; return value is implementation-defined
(let ((s (signal 0)))
(batch (fn () (reset! s 42)))
(assert-equal 42 (deref s)))))
;; --------------------------------------------------------------------------
;; Swap patterns
;; --------------------------------------------------------------------------
(defsuite "swap-patterns"
(deftest "swap! with increment function"
(let ((n (signal 0)))
(swap! n inc)
(assert-equal 1 (deref n))
(swap! n inc)
(assert-equal 2 (deref n))))
(deftest "swap! with list append"
(let ((items (signal (list))))
(swap! items (fn (l) (append l "a")))
(swap! items (fn (l) (append l "b")))
(swap! items (fn (l) (append l "c")))
(assert-equal (list "a" "b" "c") (deref items))))
(deftest "swap! with dict assoc"
(let ((store (signal {})))
(swap! store (fn (d) (assoc d "x" 1)))
(swap! store (fn (d) (assoc d "y" 2)))
(assert-equal 1 (get (deref store) "x"))
(assert-equal 2 (get (deref store) "y"))))
(deftest "multiple swap! in sequence build up correct value"
(let ((acc (signal 0)))
(swap! acc + 10)
(swap! acc + 5)
(swap! acc - 3)
(assert-equal 12 (deref acc)))))
;; --------------------------------------------------------------------------
;; call-lambda + trampoline — event handler pattern
;; --------------------------------------------------------------------------
;;
;; Regression: dom-on wraps Lambda event handlers in JS functions that
;; call callLambda. callLambda returns a Thunk (TCO), but the wrapper
;; never trampolined it, so the handler body (swap!, reset!, etc.)
;; never executed. Buttons rendered but clicks had no effect.
;;
;; These tests verify the pattern that dom-on uses:
;; (trampoline (call-lambda handler (list arg)))
;; must resolve thunks and execute side effects.
(defsuite "call-lambda-trampoline-handlers"
(deftest "call-lambda + trampoline executes signal mutation"
(let ((count (signal 0))
(handler (fn () (swap! count + 1))))
(trampoline (call-lambda handler (list)))
(assert-equal 1 (deref count))))
(deftest "call-lambda + trampoline with event arg"
(let ((last-val (signal nil))
(handler (fn (e) (reset! last-val e))))
(trampoline (call-lambda handler (list "click-event")))
(assert-equal "click-event" (deref last-val))))
(deftest "call-lambda + trampoline executes multi-statement body"
(let ((a (signal 0))
(b (signal 0))
(handler (fn ()
(reset! a 10)
(reset! b 20))))
(trampoline (call-lambda handler (list)))
(assert-equal 10 (deref a))
(assert-equal 20 (deref b))))
(deftest "repeated call-lambda accumulates side effects"
(let ((count (signal 0))
(handler (fn () (swap! count + 1))))
(trampoline (call-lambda handler (list)))
(trampoline (call-lambda handler (list)))
(trampoline (call-lambda handler (list)))
(assert-equal 3 (deref count))))
(deftest "call-lambda handler calling another lambda"
(let ((log (signal (list)))
(inner (fn (msg) (reset! log (append (deref log) (list msg)))))
(outer (fn () (inner "hello") (inner "world"))))
(trampoline (call-lambda outer (list)))
(assert-equal (list "hello" "world") (deref log)))))

649
lib/tests/test-types.sx Normal file
View File

@@ -0,0 +1,649 @@
;; ==========================================================================
;; test-types.sx — Tests for the SX gradual type system
;;
;; Requires: test-framework.sx loaded first.
;; Modules tested: types.sx (subtype?, infer-type, check-component, etc.)
;;
;; Platform functions required (beyond test framework):
;; All type system functions from types.sx must be loaded.
;; test-prim-types — a dict of primitive return types for testing.
;; ==========================================================================
;; --------------------------------------------------------------------------
;; Subtype checking
;; --------------------------------------------------------------------------
(defsuite "subtype-basics"
(deftest "any accepts everything"
(assert-true (subtype? "number" "any"))
(assert-true (subtype? "string" "any"))
(assert-true (subtype? "nil" "any"))
(assert-true (subtype? "boolean" "any"))
(assert-true (subtype? "any" "any")))
(deftest "never is subtype of everything"
(assert-true (subtype? "never" "number"))
(assert-true (subtype? "never" "string"))
(assert-true (subtype? "never" "any"))
(assert-true (subtype? "never" "nil")))
(deftest "identical types"
(assert-true (subtype? "number" "number"))
(assert-true (subtype? "string" "string"))
(assert-true (subtype? "boolean" "boolean"))
(assert-true (subtype? "nil" "nil")))
(deftest "different base types are not subtypes"
(assert-false (subtype? "number" "string"))
(assert-false (subtype? "string" "number"))
(assert-false (subtype? "boolean" "number"))
(assert-false (subtype? "string" "boolean")))
(deftest "any is not subtype of specific type"
(assert-false (subtype? "any" "number"))
(assert-false (subtype? "any" "string"))))
(defsuite "subtype-nullable"
(deftest "nil is subtype of nullable types"
(assert-true (subtype? "nil" "string?"))
(assert-true (subtype? "nil" "number?"))
(assert-true (subtype? "nil" "dict?"))
(assert-true (subtype? "nil" "boolean?")))
(deftest "base is subtype of its nullable"
(assert-true (subtype? "string" "string?"))
(assert-true (subtype? "number" "number?"))
(assert-true (subtype? "dict" "dict?")))
(deftest "nullable is not subtype of base"
(assert-false (subtype? "string?" "string"))
(assert-false (subtype? "number?" "number")))
(deftest "different nullable types are not subtypes"
(assert-false (subtype? "number" "string?"))
(assert-false (subtype? "string" "number?"))))
(defsuite "subtype-unions"
(deftest "member is subtype of union"
(assert-true (subtype? "number" (list "or" "number" "string")))
(assert-true (subtype? "string" (list "or" "number" "string"))))
(deftest "non-member is not subtype of union"
(assert-false (subtype? "boolean" (list "or" "number" "string"))))
(deftest "union is subtype if all members are"
(assert-true (subtype? (list "or" "number" "string")
(list "or" "number" "string" "boolean")))
(assert-true (subtype? (list "or" "number" "string") "any")))
(deftest "union is not subtype if any member is not"
(assert-false (subtype? (list "or" "number" "string") "number"))))
(defsuite "subtype-list-of"
(deftest "list-of covariance"
(assert-true (subtype? (list "list-of" "number") (list "list-of" "number")))
(assert-true (subtype? (list "list-of" "number") (list "list-of" "any"))))
(deftest "list-of is subtype of list"
(assert-true (subtype? (list "list-of" "number") "list")))
(deftest "list is subtype of list-of any"
(assert-true (subtype? "list" (list "list-of" "any")))))
;; --------------------------------------------------------------------------
;; Type union
;; --------------------------------------------------------------------------
(defsuite "type-union"
(deftest "same types"
(assert-equal "number" (type-union "number" "number"))
(assert-equal "string" (type-union "string" "string")))
(deftest "any absorbs"
(assert-equal "any" (type-union "any" "number"))
(assert-equal "any" (type-union "number" "any")))
(deftest "never is identity"
(assert-equal "number" (type-union "never" "number"))
(assert-equal "string" (type-union "string" "never")))
(deftest "nil + base creates nullable"
(assert-equal "string?" (type-union "nil" "string"))
(assert-equal "number?" (type-union "number" "nil")))
(deftest "subtype collapses"
(assert-equal "string?" (type-union "string" "string?"))
(assert-equal "string?" (type-union "string?" "string")))
(deftest "incompatible creates union"
(let ((result (type-union "number" "string")))
(assert-true (= (type-of result) "list"))
(assert-equal "or" (first result))
(assert-true (contains? result "number"))
(assert-true (contains? result "string")))))
;; --------------------------------------------------------------------------
;; Type narrowing
;; --------------------------------------------------------------------------
(defsuite "type-narrowing"
(deftest "nil? narrows to nil in then branch"
(let ((result (narrow-type "string?" "nil?")))
(assert-equal "nil" (first result))
(assert-equal "string" (nth result 1))))
(deftest "nil? narrows any stays any"
(let ((result (narrow-type "any" "nil?")))
(assert-equal "nil" (first result))
(assert-equal "any" (nth result 1))))
(deftest "string? narrows to string in then branch"
(let ((result (narrow-type "any" "string?")))
(assert-equal "string" (first result))
;; else branch — can't narrow any
(assert-equal "any" (nth result 1))))
(deftest "nil? on nil type narrows to never in else"
(let ((result (narrow-type "nil" "nil?")))
(assert-equal "nil" (first result))
(assert-equal "never" (nth result 1)))))
;; --------------------------------------------------------------------------
;; Type inference
;; --------------------------------------------------------------------------
(defsuite "infer-literals"
(deftest "number literal"
(assert-equal "number" (infer-type 42 (dict) (test-prim-types))))
(deftest "string literal"
(assert-equal "string" (infer-type "hello" (dict) (test-prim-types))))
(deftest "boolean literal"
(assert-equal "boolean" (infer-type true (dict) (test-prim-types))))
(deftest "nil"
(assert-equal "nil" (infer-type nil (dict) (test-prim-types)))))
(defsuite "infer-calls"
(deftest "known primitive return type"
;; (+ 1 2) → number
(let ((expr (sx-parse "(+ 1 2)")))
(assert-equal "number"
(infer-type (first expr) (dict) (test-prim-types)))))
(deftest "str returns string"
(let ((expr (sx-parse "(str 1 2)")))
(assert-equal "string"
(infer-type (first expr) (dict) (test-prim-types)))))
(deftest "comparison returns boolean"
(let ((expr (sx-parse "(= 1 2)")))
(assert-equal "boolean"
(infer-type (first expr) (dict) (test-prim-types)))))
(deftest "component call returns element"
(let ((expr (sx-parse "(~card :title \"hi\")")))
(assert-equal "element"
(infer-type (first expr) (dict) (test-prim-types)))))
(deftest "unknown function returns any"
(let ((expr (sx-parse "(unknown-fn 1 2)")))
(assert-equal "any"
(infer-type (first expr) (dict) (test-prim-types))))))
(defsuite "infer-special-forms"
(deftest "if produces union of branches"
(let ((expr (sx-parse "(if true 42 \"hello\")")))
(let ((t (infer-type (first expr) (dict) (test-prim-types))))
;; number | string — should be a union
(assert-true (or (equal? t (list "or" "number" "string"))
(= t "any"))))))
(deftest "if with no else includes nil"
(let ((expr (sx-parse "(if true 42)")))
(let ((t (infer-type (first expr) (dict) (test-prim-types))))
(assert-equal "number?" t))))
(deftest "when includes nil"
(let ((expr (sx-parse "(when true 42)")))
(let ((t (infer-type (first expr) (dict) (test-prim-types))))
(assert-equal "number?" t))))
(deftest "do returns last type"
(let ((expr (sx-parse "(do 1 2 \"hello\")")))
(assert-equal "string"
(infer-type (first expr) (dict) (test-prim-types)))))
(deftest "let infers binding types"
(let ((expr (sx-parse "(let ((x 42)) x)")))
(assert-equal "number"
(infer-type (first expr) (dict) (test-prim-types)))))
(deftest "lambda returns lambda"
(let ((expr (sx-parse "(fn (x) (+ x 1))")))
(assert-equal "lambda"
(infer-type (first expr) (dict) (test-prim-types))))))
;; --------------------------------------------------------------------------
;; Component call checking
;; --------------------------------------------------------------------------
(defsuite "check-component-calls"
(deftest "type mismatch produces error"
;; Create a component with typed params, then check a bad call
(let ((env (test-env)))
;; Define a typed component
(do
(define dummy-env env)
(defcomp ~typed-card (&key title price) (div title price))
(component-set-param-types! ~typed-card
{:title "string" :price "number"}))
;; Check a call with wrong type
(let ((diagnostics
(check-component-call "~typed-card" ~typed-card
(rest (first (sx-parse "(~typed-card :title 42 :price \"bad\")")))
(dict) (test-prim-types))))
(assert-true (> (len diagnostics) 0))
(assert-equal "error" (dict-get (first diagnostics) "level")))))
(deftest "correct call produces no errors"
(let ((env (test-env)))
(do
(define dummy-env env)
(defcomp ~ok-card (&key title price) (div title price))
(component-set-param-types! ~ok-card
{:title "string" :price "number"}))
(let ((diagnostics
(check-component-call "~ok-card" ~ok-card
(rest (first (sx-parse "(~ok-card :title \"hi\" :price 42)")))
(dict) (test-prim-types))))
(assert-equal 0 (len diagnostics)))))
(deftest "unknown kwarg produces warning"
(let ((env (test-env)))
(do
(define dummy-env env)
(defcomp ~warn-card (&key title) (div title))
(component-set-param-types! ~warn-card
{:title "string"}))
(let ((diagnostics
(check-component-call "~warn-card" ~warn-card
(rest (first (sx-parse "(~warn-card :title \"hi\" :colour \"red\")")))
(dict) (test-prim-types))))
(assert-true (> (len diagnostics) 0))
(assert-equal "warning" (dict-get (first diagnostics) "level"))))))
;; --------------------------------------------------------------------------
;; Annotation syntax: (name :as type) in defcomp params
;; --------------------------------------------------------------------------
(defsuite "typed-defcomp"
(deftest "typed params are parsed and stored"
(let ((env (test-env)))
(defcomp ~typed-widget (&key (title :as string) (count :as number)) (div title count))
(let ((pt (component-param-types ~typed-widget)))
(assert-true (not (nil? pt)))
(assert-equal "string" (dict-get pt "title"))
(assert-equal "number" (dict-get pt "count")))))
(deftest "mixed typed and untyped params"
(let ((env (test-env)))
(defcomp ~mixed-widget (&key (title :as string) subtitle) (div title subtitle))
(let ((pt (component-param-types ~mixed-widget)))
(assert-true (not (nil? pt)))
(assert-equal "string" (dict-get pt "title"))
;; subtitle has no annotation — should not be in param-types
(assert-false (has-key? pt "subtitle")))))
(deftest "untyped defcomp has nil param-types"
(let ((env (test-env)))
(defcomp ~plain-widget (&key title subtitle) (div title subtitle))
(assert-true (nil? (component-param-types ~plain-widget)))))
(deftest "typed component catches type error on call"
(let ((env (test-env)))
(defcomp ~strict-card (&key (title :as string) (price :as number)) (div title price))
;; Call with wrong types
(let ((diagnostics
(check-component-call "~strict-card" ~strict-card
(rest (first (sx-parse "(~strict-card :title 42 :price \"bad\")")))
(dict) (test-prim-types))))
;; Should have errors for both wrong-type args
(assert-true (>= (len diagnostics) 1))
(assert-equal "error" (dict-get (first diagnostics) "level")))))
(deftest "typed component passes correct call"
(let ((env (test-env)))
(defcomp ~ok-widget (&key (name :as string) (age :as number)) (div name age))
(let ((diagnostics
(check-component-call "~ok-widget" ~ok-widget
(rest (first (sx-parse "(~ok-widget :name \"Alice\" :age 30)")))
(dict) (test-prim-types))))
(assert-equal 0 (len diagnostics)))))
(deftest "nullable type accepts nil"
(let ((env (test-env)))
(defcomp ~nullable-widget (&key (title :as string) (subtitle :as string?)) (div title subtitle))
;; Passing nil for nullable param should be fine
(let ((diagnostics
(check-component-call "~nullable-widget" ~nullable-widget
(rest (first (sx-parse "(~nullable-widget :title \"hi\" :subtitle nil)")))
(dict) (test-prim-types))))
(assert-equal 0 (len diagnostics))))))
;; --------------------------------------------------------------------------
;; Primitive call checking (Phase 5)
;; --------------------------------------------------------------------------
(defsuite "check-primitive-calls"
(deftest "correct types produce no errors"
(let ((ppt (test-prim-param-types)))
(let ((diagnostics
(check-primitive-call "+" (rest (first (sx-parse "(+ 1 2 3)")))
(dict) (test-prim-types) ppt nil)))
(assert-equal 0 (len diagnostics)))))
(deftest "string arg to numeric primitive produces error"
(let ((ppt (test-prim-param-types)))
(let ((diagnostics
(check-primitive-call "+" (rest (first (sx-parse "(+ 1 \"hello\")")))
(dict) (test-prim-types) ppt nil)))
(assert-true (> (len diagnostics) 0))
(assert-equal "error" (get (first diagnostics) "level")))))
(deftest "number arg to string primitive produces error"
(let ((ppt (test-prim-param-types)))
(let ((diagnostics
(check-primitive-call "upper" (rest (first (sx-parse "(upper 42)")))
(dict) (test-prim-types) ppt nil)))
(assert-true (> (len diagnostics) 0))
(assert-equal "error" (get (first diagnostics) "level")))))
(deftest "positional and rest params both checked"
;; (- "bad" 1) — first positional arg is string, expects number
(let ((ppt (test-prim-param-types)))
(let ((diagnostics
(check-primitive-call "-" (rest (first (sx-parse "(- \"bad\" 1)")))
(dict) (test-prim-types) ppt nil)))
(assert-true (> (len diagnostics) 0)))))
(deftest "dict arg to keys is valid"
(let ((ppt (test-prim-param-types)))
(let ((diagnostics
(check-primitive-call "keys" (rest (first (sx-parse "(keys {:a 1})")))
(dict) (test-prim-types) ppt nil)))
(assert-equal 0 (len diagnostics)))))
(deftest "number arg to keys produces error"
(let ((ppt (test-prim-param-types)))
(let ((diagnostics
(check-primitive-call "keys" (rest (first (sx-parse "(keys 42)")))
(dict) (test-prim-types) ppt nil)))
(assert-true (> (len diagnostics) 0)))))
(deftest "variable with known type passes check"
;; Variable n is known to be number in type-env
(let ((ppt (test-prim-param-types))
(tenv {"n" "number"}))
(let ((diagnostics
(check-primitive-call "inc" (rest (first (sx-parse "(inc n)")))
tenv (test-prim-types) ppt nil)))
(assert-equal 0 (len diagnostics)))))
(deftest "variable with wrong type fails check"
;; Variable s is known to be string in type-env
(let ((ppt (test-prim-param-types))
(tenv {"s" "string"}))
(let ((diagnostics
(check-primitive-call "inc" (rest (first (sx-parse "(inc s)")))
tenv (test-prim-types) ppt nil)))
(assert-true (> (len diagnostics) 0)))))
(deftest "any-typed variable skips check"
;; Variable x has type any — should not produce errors
(let ((ppt (test-prim-param-types))
(tenv {"x" "any"}))
(let ((diagnostics
(check-primitive-call "upper" (rest (first (sx-parse "(upper x)")))
tenv (test-prim-types) ppt nil)))
(assert-equal 0 (len diagnostics)))))
(deftest "body-walk catches primitive errors in component"
;; Manually build a component and check it via check-body-walk directly
(let ((ppt (test-prim-param-types))
(body (first (sx-parse "(div (+ name 1))")))
(type-env {"name" "string"})
(diagnostics (list)))
(check-body-walk body "~bad-math" type-env (test-prim-types) ppt (test-env) diagnostics nil nil)
(assert-true (> (len diagnostics) 0))
(assert-equal "error" (get (first diagnostics) "level")))))
;; --------------------------------------------------------------------------
;; deftype — type aliases
;; --------------------------------------------------------------------------
(defsuite "deftype-alias"
(deftest "simple alias resolves"
(let ((registry {"price" {:name "price" :params () :body "number"}}))
(assert-equal "number" (resolve-type "price" registry))))
(deftest "alias chain resolves"
(let ((registry {"price" {:name "price" :params () :body "number"}
"cost" {:name "cost" :params () :body "price"}}))
(assert-equal "number" (resolve-type "cost" registry))))
(deftest "unknown type passes through"
(let ((registry {"price" {:name "price" :params () :body "number"}}))
(assert-equal "string" (resolve-type "string" registry))))
(deftest "subtype-resolved? works through alias"
(let ((registry {"price" {:name "price" :params () :body "number"}}))
(assert-true (subtype-resolved? "price" "number" registry))
(assert-true (subtype-resolved? "number" "price" registry)))))
;; --------------------------------------------------------------------------
;; deftype — union types
;; --------------------------------------------------------------------------
(defsuite "deftype-union"
(deftest "union resolves"
(let ((registry {"status" {:name "status" :params (list) :body (list "or" "string" "number")}}))
(let ((resolved (resolve-type "status" registry)))
(assert-true (= (type-of resolved) "list"))
(assert-equal "or" (first resolved)))))
(deftest "subtype through named union"
(let ((registry {"status" {:name "status" :params (list) :body (list "or" "string" "number")}}))
(assert-true (subtype-resolved? "string" "status" registry))
(assert-true (subtype-resolved? "number" "status" registry))
(assert-false (subtype-resolved? "boolean" "status" registry)))))
;; --------------------------------------------------------------------------
;; deftype — record types
;; --------------------------------------------------------------------------
(defsuite "deftype-record"
(deftest "record resolves to dict"
(let ((registry {"card-props" {:name "card-props" :params ()
:body {"title" "string" "price" "number"}}}))
(let ((resolved (resolve-type "card-props" registry)))
(assert-equal "dict" (type-of resolved))
(assert-equal "string" (get resolved "title"))
(assert-equal "number" (get resolved "price")))))
(deftest "record structural subtyping"
(let ((registry {"card-props" {:name "card-props" :params ()
:body {"title" "string" "price" "number"}}
"titled" {:name "titled" :params ()
:body {"title" "string"}}}))
;; card-props has title+price, titled has just title
;; card-props <: titled (has all required fields)
(assert-true (subtype-resolved? "card-props" "titled" registry))))
(deftest "get infers field type from record"
(let ((registry {"card-props" {:name "card-props" :params (list)
:body {"title" "string" "price" "number"}}})
(type-env {"d" "card-props"})
(expr (first (sx-parse "(get d :title)"))))
(assert-equal "string"
(infer-type expr type-env (test-prim-types) registry)))))
;; --------------------------------------------------------------------------
;; deftype — parameterized types
;; --------------------------------------------------------------------------
(defsuite "deftype-parameterized"
(deftest "maybe instantiation"
(let ((registry {"maybe" {:name "maybe" :params (list "a")
:body (list "or" "a" "nil")}}))
(let ((resolved (resolve-type (list "maybe" "string") registry)))
(assert-true (= (type-of resolved) "list"))
(assert-equal "or" (first resolved))
(assert-true (contains? resolved "string"))
(assert-true (contains? resolved "nil")))))
(deftest "subtype through parameterized type"
(let ((registry {"maybe" {:name "maybe" :params (list "a")
:body (list "or" "a" "nil")}}))
(assert-true (subtype-resolved? "string" (list "maybe" "string") registry))
(assert-true (subtype-resolved? "nil" (list "maybe" "string") registry))
(assert-false (subtype-resolved? "number" (list "maybe" "string") registry))))
(deftest "substitute-type-vars works"
(let ((result (substitute-type-vars (list "or" "a" "nil") (list "a") (list "number"))))
(assert-equal "or" (first result))
(assert-true (contains? result "number"))
(assert-true (contains? result "nil")))))
;; --------------------------------------------------------------------------
;; defeffect — effect basics
;; --------------------------------------------------------------------------
(defsuite "defeffect-basics"
(deftest "get-effects returns nil for unannotated"
(let ((anns {"fetch" ("io")}))
(assert-true (nil? (get-effects "unknown" anns)))))
(deftest "get-effects returns effects for annotated"
(let ((anns {"fetch" ("io")}))
(assert-equal (list "io") (get-effects "fetch" anns))))
(deftest "nil annotations returns nil"
(assert-true (nil? (get-effects "anything" nil)))))
;; --------------------------------------------------------------------------
;; defeffect — effect checking
;; --------------------------------------------------------------------------
(defsuite "effect-checking"
(deftest "pure cannot call io"
(let ((anns {"~pure-comp" () "fetch" ("io")}))
(let ((diagnostics (check-effect-call "fetch" (list) anns "~pure-comp")))
(assert-true (> (len diagnostics) 0))
(assert-equal "error" (get (first diagnostics) "level")))))
(deftest "io context allows io"
(let ((anns {"~io-comp" ("io") "fetch" ("io")}))
(let ((diagnostics (check-effect-call "fetch" (list "io") anns "~io-comp")))
(assert-equal 0 (len diagnostics)))))
(deftest "unannotated caller allows everything"
(let ((anns {"fetch" ("io")}))
(let ((diagnostics (check-effect-call "fetch" nil anns "~unknown")))
(assert-equal 0 (len diagnostics)))))
(deftest "unannotated callee skips check"
(let ((anns {"~pure-comp" ()}))
(let ((diagnostics (check-effect-call "unknown-fn" (list) anns "~pure-comp")))
(assert-equal 0 (len diagnostics))))))
;; --------------------------------------------------------------------------
;; defeffect — subset checking
;; --------------------------------------------------------------------------
(defsuite "effect-subset"
(deftest "empty is subset of anything"
(assert-true (effects-subset? (list) (list "io")))
(assert-true (effects-subset? (list) (list))))
(deftest "io is subset of io"
(assert-true (effects-subset? (list "io") (list "io" "async"))))
(deftest "io is not subset of pure"
(assert-false (effects-subset? (list "io") (list))))
(deftest "nil callee skips check"
(assert-true (effects-subset? nil (list))))
(deftest "nil caller allows all"
(assert-true (effects-subset? (list "io") nil))))
;; --------------------------------------------------------------------------
;; build-effect-annotations
;; --------------------------------------------------------------------------
(defsuite "build-effect-annotations"
(deftest "builds annotations from io declarations"
(let ((decls (list {"name" "fetch"} {"name" "save!"}))
(anns (build-effect-annotations decls)))
(assert-equal (list "io") (get anns "fetch"))
(assert-equal (list "io") (get anns "save!"))))
(deftest "skips entries without name"
(let ((decls (list {"name" "fetch"} {"other" "x"}))
(anns (build-effect-annotations decls)))
(assert-true (has-key? anns "fetch"))
(assert-false (has-key? anns "other"))))
(deftest "empty declarations produce empty dict"
(let ((anns (build-effect-annotations (list))))
(assert-equal 0 (len (keys anns))))))
;; --------------------------------------------------------------------------
;; check-component-effects
;; --------------------------------------------------------------------------
(defsuite "check-component-effects"
(deftest "pure component calling io produces diagnostic"
;; Define component in a local env so check-component-effects can find it
(let ((e (env-extend (test-env))))
(eval-expr-cek (sx-parse-one "(defcomp ~eff-pure-card () :effects [] (div (fetch \"url\")))") e)
(let ((anns {"~eff-pure-card" () "fetch" ("io")})
(diagnostics (check-component-effects "~eff-pure-card" e anns)))
(assert-true (> (len diagnostics) 0)))))
(deftest "io component calling io produces no diagnostic"
(let ((e (env-extend (test-env))))
(eval-expr-cek (sx-parse-one "(defcomp ~eff-io-card () :effects [io] (div (fetch \"url\")))") e)
(let ((anns {"~eff-io-card" ("io") "fetch" ("io")})
(diagnostics (check-component-effects "~eff-io-card" e anns)))
(assert-equal 0 (len diagnostics)))))
(deftest "unannotated component skips check"
(let ((e (env-extend (test-env))))
(eval-expr-cek (sx-parse-one "(defcomp ~eff-unannot-card () (div (fetch \"url\")))") e)
(let ((anns {"fetch" ("io")})
(diagnostics (check-component-effects "~eff-unannot-card" e anns)))
(assert-equal 0 (len diagnostics))))))

244
lib/tests/test-vm-closures.sx Normal file
View File

@@ -0,0 +1,244 @@
;; ==========================================================================
;; test-vm-closures.sx — Tests for inner closure recursion patterns
;;
;; Requires: test-framework.sx loaded first.
;;
;; These tests exercise patterns where inner closures recurse deeply
;; while sharing mutable state via upvalues. This is the sx-parse
;; pattern: many inner functions close over a mutable cursor variable.
;; Without proper VM closure support, each recursive call would
;; allocate a fresh VM — blowing the stack or hanging.
;; ==========================================================================
;; --------------------------------------------------------------------------
;; Inner closure recursion with mutable upvalues
;; --------------------------------------------------------------------------
(defsuite "inner-closure-recursion"
(deftest "self-recursive inner closure with set! on captured variable"
;; Pattern: closure mutates captured var on each recursive call.
;; This is the core pattern in skip-ws, read-str-loop, etc.
(let ((counter 0))
(define count-up
(fn (n)
(when (> n 0)
(set! counter (+ counter 1))
(count-up (- n 1)))))
(count-up 100)
(assert-equal 100 counter)))
(deftest "deep inner closure recursion (500 iterations)"
;; Stress test: 500 recursive calls through an inner closure
;; mutating a shared upvalue. Would stack-overflow without TCO.
(let ((acc 0))
(define sum-up
(fn (n)
(if (<= n 0)
acc
(do (set! acc (+ acc n))
(sum-up (- n 1))))))
(assert-equal 125250 (sum-up 500))))
(deftest "inner closure reading captured variable updated by another"
;; Two closures: one writes, one reads, sharing the same binding.
(let ((pos 0))
(define advance! (fn () (set! pos (+ pos 1))))
(define current (fn () pos))
(advance!)
(advance!)
(advance!)
(assert-equal 3 (current))))
(deftest "recursive closure with multiple mutable upvalues"
;; Like sx-parse: multiple cursor variables mutated during recursion.
(let ((pos 0)
(count 0))
(define scan
(fn (source)
(when (< pos (len source))
(set! count (+ count 1))
(set! pos (+ pos 1))
(scan source))))
(scan "hello world")
(assert-equal 11 pos)
(assert-equal 11 count))))
;; --------------------------------------------------------------------------
;; Mutual recursion between inner closures
;; --------------------------------------------------------------------------
(defsuite "mutual-inner-closures"
(deftest "two inner closures calling each other"
;; Pattern: read-expr calls read-list, read-list calls read-expr.
(let ((result (list)))
(define process-a
(fn (items)
(when (not (empty? items))
(append! result (str "a:" (first items)))
(process-b (rest items)))))
(define process-b
(fn (items)
(when (not (empty? items))
(append! result (str "b:" (first items)))
(process-a (rest items)))))
(process-a (list 1 2 3 4))
(assert-equal 4 (len result))
(assert-equal "a:1" (nth result 0))
(assert-equal "b:2" (nth result 1))
(assert-equal "a:3" (nth result 2))
(assert-equal "b:4" (nth result 3))))
(deftest "mutual recursion with shared mutable state"
;; Both closures read and write the same captured variable.
(let ((pos 0)
(source "aAbBcC"))
(define skip-lower
(fn ()
(when (and (< pos (len source))
(>= (nth source pos) "a")
(<= (nth source pos) "z"))
(set! pos (+ pos 1))
(skip-upper))))
(define skip-upper
(fn ()
(when (and (< pos (len source))
(>= (nth source pos) "A")
(<= (nth source pos) "Z"))
(set! pos (+ pos 1))
(skip-lower))))
(skip-lower)
(assert-equal 6 pos)))
(deftest "three-way mutual recursion"
(let ((n 30)
(result nil))
(define step-a
(fn (i)
(if (>= i n)
(set! result "done")
(step-b (+ i 1)))))
(define step-b
(fn (i)
(step-c (+ i 1))))
(define step-c
(fn (i)
(step-a (+ i 1))))
(step-a 0)
(assert-equal "done" result))))
;; --------------------------------------------------------------------------
;; Parser-like patterns (the sx-parse structure)
;; --------------------------------------------------------------------------
(defsuite "parser-pattern"
(deftest "mini-parser: tokenize digits from string"
;; Simplified sx-parse pattern: closure over pos + source,
;; multiple inner functions sharing the mutable cursor.
(let ((pos 0)
(source "12 34 56")
(len-src 8))
(define skip-ws
(fn ()
(when (and (< pos len-src) (= (nth source pos) " "))
(set! pos (+ pos 1))
(skip-ws))))
(define read-digits
(fn ()
(let ((start pos))
(define digit-loop
(fn ()
(when (and (< pos len-src)
(>= (nth source pos) "0")
(<= (nth source pos) "9"))
(set! pos (+ pos 1))
(digit-loop))))
(digit-loop)
(slice source start pos))))
(define read-all
(fn ()
(let ((tokens (list)))
(define parse-loop
(fn ()
(skip-ws)
(when (< pos len-src)
(append! tokens (read-digits))
(parse-loop))))
(parse-loop)
tokens)))
(let ((tokens (read-all)))
(assert-equal 3 (len tokens))
(assert-equal "12" (nth tokens 0))
(assert-equal "34" (nth tokens 1))
(assert-equal "56" (nth tokens 2)))))
(deftest "nested inner closures with upvalue chain"
;; Inner function defines its own inner function,
;; both closing over the outer mutable variable.
(let ((total 0))
(define outer-fn
(fn (items)
(for-each
(fn (item)
(let ((sub-total 0))
(define inner-loop
(fn (n)
(when (> n 0)
(set! sub-total (+ sub-total 1))
(set! total (+ total 1))
(inner-loop (- n 1)))))
(inner-loop item)))
items)))
(outer-fn (list 3 2 1))
(assert-equal 6 total)))
(deftest "closure returning accumulated list via append!"
;; Pattern from read-list: loop appends to mutable list, returns it.
(let ((items (list)))
(define collect
(fn (source pos)
(if (>= pos (len source))
items
(do (append! items (nth source pos))
(collect source (+ pos 1))))))
(let ((result (collect (list "a" "b" "c" "d") 0)))
(assert-equal 4 (len result))
(assert-equal "a" (first result))
(assert-equal "d" (last result))))))
;; --------------------------------------------------------------------------
;; Closures as callbacks to higher-order functions
;; --------------------------------------------------------------------------
(defsuite "closure-ho-callbacks"
(deftest "map with closure that mutates captured variable"
(let ((running-total 0))
(let ((results (map (fn (x)
(set! running-total (+ running-total x))
running-total)
(list 1 2 3 4))))
(assert-equal (list 1 3 6 10) results)
(assert-equal 10 running-total))))
(deftest "reduce with closure over external state"
(let ((call-count 0))
(let ((sum (reduce (fn (acc x)
(set! call-count (+ call-count 1))
(+ acc x))
0
(list 10 20 30))))
(assert-equal 60 sum)
(assert-equal 3 call-count))))
(deftest "filter with closure reading shared state"
(let ((threshold 3))
(let ((result (filter (fn (x) (> x threshold))
(list 1 2 3 4 5))))
(assert-equal (list 4 5) result)))))

495
lib/tests/test-vm.sx Normal file
View File

@@ -0,0 +1,495 @@
;; ==========================================================================
;; test-vm.sx — Tests for the bytecode VM (spec/vm.sx)
;;
;; Requires: test-framework.sx, compiler.sx, vm.sx loaded.
;; Tests the compile → bytecode → VM execution pipeline.
;; ==========================================================================
;; Helper: compile an SX expression and execute it on the VM.
;; Returns the result value.
(define vm-eval
(fn (expr)
(let ((code (compile expr)))
(vm-execute-module
(code-from-value code)
{}))))
;; Helper: compile and run with a pre-populated globals dict.
(define vm-eval-with
(fn (expr globals)
(let ((code (compile expr)))
(vm-execute-module (code-from-value code) globals))))
;; --------------------------------------------------------------------------
;; Constants and literals
;; --------------------------------------------------------------------------
(defsuite "vm-constants"
(deftest "number constant"
(assert-equal 42 (vm-eval 42)))
(deftest "string constant"
(assert-equal "hello" (vm-eval "hello")))
(deftest "boolean true"
(assert-equal true (vm-eval true)))
(deftest "boolean false"
(assert-equal false (vm-eval false)))
(deftest "nil constant"
(assert-nil (vm-eval nil)))
(deftest "negative number"
(assert-equal -7 (vm-eval -7)))
(deftest "float constant"
(assert-equal 3.14 (vm-eval 3.14))))
;; --------------------------------------------------------------------------
;; Arithmetic via primitives
;; --------------------------------------------------------------------------
(defsuite "vm-arithmetic"
(deftest "addition"
(assert-equal 5 (vm-eval '(+ 2 3))))
(deftest "subtraction"
(assert-equal 7 (vm-eval '(- 10 3))))
(deftest "multiplication"
(assert-equal 24 (vm-eval '(* 6 4))))
(deftest "division"
(assert-equal 5 (vm-eval '(/ 10 2))))
(deftest "nested arithmetic"
(assert-equal 14 (vm-eval '(+ (* 3 4) 2))))
(deftest "three-arg addition"
(assert-equal 15 (vm-eval '(+ 5 4 6)))))
;; --------------------------------------------------------------------------
;; Comparison and logic
;; --------------------------------------------------------------------------
(defsuite "vm-comparison"
(deftest "equal numbers"
(assert-equal true (vm-eval '(= 1 1))))
(deftest "unequal numbers"
(assert-equal false (vm-eval '(= 1 2))))
(deftest "less than"
(assert-equal true (vm-eval '(< 1 2))))
(deftest "greater than"
(assert-equal true (vm-eval '(> 5 3))))
(deftest "not"
(assert-equal true (vm-eval '(not false))))
(deftest "not truthy"
(assert-equal false (vm-eval '(not 42)))))
;; --------------------------------------------------------------------------
;; Control flow — if, when, cond, and, or
;; --------------------------------------------------------------------------
(defsuite "vm-control-flow"
(deftest "if true branch"
(assert-equal 1 (vm-eval '(if true 1 2))))
(deftest "if false branch"
(assert-equal 2 (vm-eval '(if false 1 2))))
(deftest "if without else returns nil"
(assert-nil (vm-eval '(if false 1))))
(deftest "when true evaluates body"
(assert-equal 42 (vm-eval '(when true 42))))
(deftest "when false returns nil"
(assert-nil (vm-eval '(when false 42))))
(deftest "and short-circuits on false"
(assert-equal false (vm-eval '(and true false 42))))
(deftest "and returns last truthy"
(assert-equal 3 (vm-eval '(and 1 2 3))))
(deftest "or short-circuits on true"
(assert-equal 1 (vm-eval '(or 1 false 2))))
(deftest "or returns false when all falsy"
(assert-equal false (vm-eval '(or false false false))))
(deftest "cond first match"
(assert-equal "one" (vm-eval '(cond (= 1 1) "one" (= 2 2) "two"))))
(deftest "cond else clause"
(assert-equal "none" (vm-eval '(cond (= 1 2) "one" :else "none"))))
(deftest "case match"
(assert-equal "two" (vm-eval '(case 2 1 "one" 2 "two" :else "other"))))
(deftest "case else"
(assert-equal "other" (vm-eval '(case 99 1 "one" 2 "two" :else "other")))))
;; --------------------------------------------------------------------------
;; Let bindings
;; --------------------------------------------------------------------------
(defsuite "vm-let"
(deftest "single binding"
(assert-equal 10 (vm-eval '(let ((x 10)) x))))
(deftest "multiple bindings"
(assert-equal 30 (vm-eval '(let ((x 10) (y 20)) (+ x y)))))
(deftest "bindings are sequential"
(assert-equal 11 (vm-eval '(let ((x 10) (y (+ x 1))) y))))
(deftest "nested let"
(assert-equal 3 (vm-eval '(let ((x 1)) (let ((y 2)) (+ x y))))))
(deftest "inner let shadows outer"
(assert-equal 99 (vm-eval '(let ((x 1)) (let ((x 99)) x)))))
(deftest "let body returns last expression"
(assert-equal 3 (vm-eval '(let ((x 1)) 1 2 3)))))
;; --------------------------------------------------------------------------
;; Lambda and function calls
;; --------------------------------------------------------------------------
(defsuite "vm-lambda"
(deftest "lambda call"
(assert-equal 7 (vm-eval '(let ((f (fn (x) (+ x 2)))) (f 5)))))
(deftest "lambda with multiple params"
(assert-equal 11 (vm-eval '(let ((add (fn (a b) (+ a b)))) (add 5 6)))))
(deftest "higher-order: pass lambda to lambda"
(assert-equal 10
(vm-eval '(let ((apply-fn (fn (f x) (f x)))
(double (fn (n) (* n 2))))
(apply-fn double 5)))))
(deftest "lambda returns lambda"
(assert-equal 15
(vm-eval '(let ((make-adder (fn (n) (fn (x) (+ n x)))))
(let ((add10 (make-adder 10)))
(add10 5))))))
(deftest "immediately invoked lambda"
(assert-equal 42 (vm-eval '((fn (x) (* x 2)) 21)))))
;; --------------------------------------------------------------------------
;; Closures and upvalues
;; --------------------------------------------------------------------------
(defsuite "vm-closures"
(deftest "closure captures local"
(assert-equal 10
(vm-eval '(let ((x 10))
(let ((f (fn () x)))
(f))))))
(deftest "closure captures through two levels"
(assert-equal 30
(vm-eval '(let ((x 10))
(let ((y 20))
(let ((f (fn () (+ x y))))
(f)))))))
(deftest "two closures share upvalue"
(assert-equal 42
(vm-eval '(let ((x 0))
(let ((set-x (fn (v) (set! x v)))
(get-x (fn () x)))
(set-x 42)
(get-x))))))
(deftest "closure mutation visible to sibling"
(assert-equal 3
(vm-eval '(let ((counter 0))
(let ((inc! (fn () (set! counter (+ counter 1)))))
(inc!)
(inc!)
(inc!)
counter))))))
;; --------------------------------------------------------------------------
;; Tail call optimization
;; --------------------------------------------------------------------------
(defsuite "vm-tco"
(deftest "tail-recursive loop doesn't overflow"
;; Count down from 10000 — would overflow without TCO
(assert-equal 0
(vm-eval '(let ((loop (fn (n)
(if (<= n 0) 0
(loop (- n 1))))))
(loop 10000)))))
(deftest "tail-recursive accumulator"
(assert-equal 5050
(vm-eval '(let ((sum (fn (n acc)
(if (<= n 0) acc
(sum (- n 1) (+ acc n))))))
(sum 100 0))))))
;; --------------------------------------------------------------------------
;; Collections
;; --------------------------------------------------------------------------
(defsuite "vm-collections"
(deftest "list construction"
(assert-equal (list 1 2 3) (vm-eval '(list 1 2 3))))
(deftest "empty list"
(assert-equal (list) (vm-eval '(list))))
(deftest "dict construction"
(let ((d (vm-eval '{:a 1 :b 2})))
(assert-equal 1 (get d "a"))
(assert-equal 2 (get d "b"))))
(deftest "list operations"
(assert-equal 1 (vm-eval '(first (list 1 2 3))))
(assert-equal 3 (vm-eval '(len (list 1 2 3)))))
(deftest "nested list"
(assert-equal (list 1 (list 2 3))
(vm-eval '(list 1 (list 2 3))))))
;; --------------------------------------------------------------------------
;; String operations
;; --------------------------------------------------------------------------
(defsuite "vm-strings"
(deftest "str concat"
(assert-equal "hello world" (vm-eval '(str "hello" " " "world"))))
(deftest "string-length"
(assert-equal 5 (vm-eval '(string-length "hello"))))
(deftest "str coerces numbers"
(assert-equal "42" (vm-eval '(str 42)))))
;; --------------------------------------------------------------------------
;; Define — top-level and local
;; --------------------------------------------------------------------------
(defsuite "vm-define"
(deftest "top-level define"
(assert-equal 42
(vm-eval '(do (define x 42) x))))
(deftest "define function then call"
(assert-equal 10
(vm-eval '(do
(define double (fn (n) (* n 2)))
(double 5)))))
(deftest "local define inside fn"
(assert-equal 30
(vm-eval '(let ((f (fn (x)
(define y (* x 2))
(+ x y))))
(f 10)))))
(deftest "define with forward reference"
(assert-equal 120
(vm-eval '(do
(define fact (fn (n)
(if (<= n 1) 1 (* n (fact (- n 1))))))
(fact 5))))))
;; --------------------------------------------------------------------------
;; Letrec — mutual recursion
;; --------------------------------------------------------------------------
(defsuite "vm-letrec"
(deftest "letrec self-recursion"
(assert-equal 55
(vm-eval '(letrec ((sum-to (fn (n)
(if (<= n 0) 0
(+ n (sum-to (- n 1)))))))
(sum-to 10)))))
(deftest "letrec mutual recursion"
(assert-equal true
(vm-eval '(letrec ((my-even? (fn (n)
(if (= n 0) true (my-odd? (- n 1)))))
(my-odd? (fn (n)
(if (= n 0) false (my-even? (- n 1))))))
(my-even? 10))))))
;; --------------------------------------------------------------------------
;; Quasiquote
;; --------------------------------------------------------------------------
(defsuite "vm-quasiquote"
(deftest "simple quasiquote"
(assert-equal (list 1 2 3)
(vm-eval '(let ((x 2)) `(1 ,x 3)))))
(deftest "quasiquote with splice"
(assert-equal (list 1 2 3 4)
(vm-eval '(let ((xs (list 2 3))) `(1 ,@xs 4))))))
;; --------------------------------------------------------------------------
;; Thread macro
;; --------------------------------------------------------------------------
(defsuite "vm-threading"
(deftest "thread-first"
(assert-equal 7
(vm-eval '(-> 5 (+ 2)))))
(deftest "thread-first chain"
(assert-equal 12
(vm-eval '(-> 10 (+ 5) (- 3))))))
;; --------------------------------------------------------------------------
;; Integration: compile then execute
;; --------------------------------------------------------------------------
(defsuite "vm-integration"
(deftest "fibonacci"
(assert-equal 55
(vm-eval '(do
(define fib (fn (n)
(if (<= n 1) n
(+ (fib (- n 1)) (fib (- n 2))))))
(fib 10)))))
(deftest "map via recursive define"
(assert-equal (list 2 4 6)
(vm-eval '(do
(define my-map (fn (f lst)
(if (empty? lst) (list)
(cons (f (first lst)) (my-map f (rest lst))))))
(my-map (fn (x) (* x 2)) (list 1 2 3))))))
(deftest "filter via recursive define"
(assert-equal (list 2 4)
(vm-eval '(do
(define my-filter (fn (pred lst)
(if (empty? lst) (list)
(if (pred (first lst))
(cons (first lst) (my-filter pred (rest lst)))
(my-filter pred (rest lst))))))
(my-filter (fn (x) (even? x)) (list 1 2 3 4 5))))))
(deftest "reduce via recursive define"
(assert-equal 15
(vm-eval '(do
(define my-reduce (fn (f acc lst)
(if (empty? lst) acc
(my-reduce f (f acc (first lst)) (rest lst)))))
(my-reduce (fn (acc x) (+ acc x)) 0 (list 1 2 3 4 5))))))
(deftest "nested function calls"
(assert-equal 42
(vm-eval '(do
(define compose (fn (f g) (fn (x) (f (g x)))))
(define inc (fn (x) (+ x 1)))
(define double (fn (x) (* x 2)))
(let ((inc-then-double (compose double inc)))
(inc-then-double 20)))))))
;; --------------------------------------------------------------------------
;; VM recursive mutation — closure capture must preserve mutable references
;; --------------------------------------------------------------------------
;;
;; Regression: recursive functions that append! to a shared mutable list
;; lost mutations after the first call under JIT. The stepper island's
;; split-tag function produced 1 step instead of 16, breaking SSR.
(defsuite "vm-recursive-mutation"
(deftest "recursive append! to shared list"
(assert-equal 3
(vm-eval '(do
(define walk (fn (items result)
(when (not (empty? items))
(append! result (first items))
(walk (rest items) result))))
(let ((result (list)))
(walk (list "a" "b" "c") result)
(len result))))))
(deftest "recursive tree walk with append!"
(assert-equal 7
(vm-eval '(do
(define walk-children (fn (items result walk-fn)
(when (not (empty? items))
(walk-fn (first items) result)
(walk-children (rest items) result walk-fn))))
(define walk (fn (expr result)
(cond
(not (list? expr))
(append! result "leaf")
(empty? expr) nil
:else
(do (append! result "open")
(walk-children (rest expr) result walk)
(append! result "close")))))
(let ((tree (first (sx-parse "(div \"a\" (span \"b\") \"c\")")))
(result (list)))
(walk tree result)
(len result))))))
(deftest "recursive walk matching stepper split-tag pattern"
(assert-equal 16
(vm-eval '(do
(define walk-each (fn (items result walk-fn)
(when (not (empty? items))
(walk-fn (first items) result)
(walk-each (rest items) result walk-fn))))
(define collect-children (fn (items cch)
(when (not (empty? items))
(let ((a (first items)))
(if (and (list? a) (not (empty? a))
(= (type-of (first a)) "symbol")
(starts-with? (symbol-name (first a)) "~"))
nil ;; skip component spreads
(append! cch a))
(collect-children (rest items) cch)))))
(define split-tag (fn (expr result)
(cond
(not (list? expr))
(append! result "leaf")
(empty? expr) nil
(not (= (type-of (first expr)) "symbol"))
(append! result "leaf")
(is-html-tag? (symbol-name (first expr)))
(let ((cch (list)))
(collect-children (rest expr) cch)
(append! result "open")
(walk-each cch result split-tag)
(append! result "close"))
:else
(append! result "expr"))))
(let ((parsed (sx-parse "(div (~cssx/tw :tokens \"text-center\")\n (h1 (~cssx/tw :tokens \"text-3xl font-bold mb-2\")\n (span (~cssx/tw :tokens \"text-rose-500\") \"the \")\n (span (~cssx/tw :tokens \"text-amber-500\") \"joy \")\n (span (~cssx/tw :tokens \"text-emerald-500\") \"of \")\n (span (~cssx/tw :tokens \"text-violet-600 text-4xl\") \"sx\")))"))
(result (list)))
(split-tag (first parsed) result)
(len result)))))))

117
lib/tests/vm-inline.sx Normal file
View File

@@ -0,0 +1,117 @@
;; vm-inline.sx — Tests for inline VM opcodes (OP_ADD, OP_EQ, etc.)
;;
;; These verify that the JIT-compiled inline opcodes produce
;; identical results to the CALL_PRIM fallback.
;; --------------------------------------------------------------------------
;; Arithmetic
;; --------------------------------------------------------------------------
(test "inline + integers" (= (+ 3 4) 7))
(test "inline + floats" (= (+ 1.5 2.5) 4.0))
(test "inline + string concat" (= (+ "hello" " world") "hello world"))
(test "inline - integers" (= (- 10 3) 7))
(test "inline - negative" (= (- 3 10) -7))
(test "inline * integers" (= (* 6 7) 42))
(test "inline * float" (= (* 2.5 4.0) 10.0))
(test "inline / integers" (= (/ 10 2) 5))
(test "inline / float" (= (/ 7.0 2.0) 3.5))
(test "inline inc" (= (inc 5) 6))
(test "inline dec" (= (dec 5) 4))
(test "inline inc float" (= (inc 2.5) 3.5))
(test "inline dec zero" (= (dec 0) -1))
;; --------------------------------------------------------------------------
;; Comparison
;; --------------------------------------------------------------------------
(test "inline = numbers" (= 5 5))
(test "inline = strings" (= "hello" "hello"))
(test "inline = false" (not (= 5 6)))
(test "inline = nil" (= nil nil))
(test "inline = mixed false" (not (= 5 "5")))
(test "inline < numbers" (< 3 5))
(test "inline < false" (not (< 5 3)))
(test "inline < equal" (not (< 5 5)))
(test "inline < strings" (< "abc" "def"))
(test "inline > numbers" (> 5 3))
(test "inline > false" (not (> 3 5)))
(test "inline > equal" (not (> 5 5)))
(test "inline not true" (= (not true) false))
(test "inline not false" (= (not false) true))
(test "inline not nil" (= (not nil) true))
(test "inline not number" (= (not 0) true))
(test "inline not string" (= (not "") true))
(test "inline not nonempty" (= (not "x") false))
;; --------------------------------------------------------------------------
;; Collection ops
;; --------------------------------------------------------------------------
(test "inline len list" (= (len (list 1 2 3)) 3))
(test "inline len string" (= (len "hello") 5))
(test "inline len empty" (= (len (list)) 0))
(test "inline len nil" (= (len nil) 0))
(test "inline first" (= (first (list 10 20 30)) 10))
(test "inline first empty" (= (first (list)) nil))
(test "inline rest" (= (rest (list 1 2 3)) (list 2 3)))
(test "inline rest single" (= (rest (list 1)) (list)))
(test "inline nth" (= (nth (list 10 20 30) 1) 20))
(test "inline nth zero" (= (nth (list 10 20 30) 0) 10))
(test "inline nth out of bounds" (= (nth (list 1 2) 5) nil))
(test "inline cons" (= (cons 1 (list 2 3)) (list 1 2 3)))
(test "inline cons to empty" (= (cons 1 (list)) (list 1)))
(test "inline cons to nil" (= (cons 1 nil) (list 1)))
;; --------------------------------------------------------------------------
;; Composition — inline ops in expressions
;; --------------------------------------------------------------------------
(test "nested arithmetic" (= (+ (* 3 4) (- 10 5)) 17))
(test "comparison in if" (if (< 3 5) "yes" "no") (= "yes"))
(test "len in condition" (if (> (len (list 1 2 3)) 2) true false))
(test "inc in loop" (= (let ((x 0)) (for-each (fn (_) (set! x (inc x))) (list 1 2 3)) x) 3))
(test "first + rest roundtrip" (= (cons (first (list 1 2 3)) (rest (list 1 2 3))) (list 1 2 3)))
(test "nested comparison" (= (and (< 1 2) (> 3 0) (= 5 5)) true))
;; --------------------------------------------------------------------------
;; Edge cases
;; --------------------------------------------------------------------------
(test "+ with nil" (= (+ 5 nil) 5))
(test "len of dict" (= (len {:a 1 :b 2}) 2))
(test "= with booleans" (= (= true true) true))
(test "= with keywords" (= (= :foo :foo) true))
(test "not with list" (= (not (list 1)) false))
;; --------------------------------------------------------------------------
;; Recursive mutation — VM closure capture must preserve mutable state
;; --------------------------------------------------------------------------
;;
;; Regression: recursive functions that append! to a shared mutable list
;; lost mutations after the first call under JIT. The VM closure capture
;; was copying the list value instead of sharing the mutable reference.
(test "recursive append! to shared list"
(let ((walk (fn (items result)
(when (not (empty? items))
(append! result (first items))
(walk (rest items) result)))))
(let ((result (list)))
(walk (list "a" "b" "c") result)
(= (len result) 3))))
(test "recursive tree walk with append!"
(let ((walk (fn (expr result)
(cond
(not (list? expr))
(append! result "leaf")
(empty? expr) nil
:else
(do (append! result "open")
(for-each (fn (c) (walk c result)) (rest expr))
(append! result "close"))))))
(let ((tree (first (sx-parse "(div \"a\" (span \"b\") \"c\")")))
(result (list)))
(walk tree result)
(= (len result) 7))))

927
lib/types.sx Normal file
View File

@@ -0,0 +1,927 @@
;; ==========================================================================
;; types.sx — Gradual type system for SX
;;
;; Registration-time type checking: zero runtime cost.
;; Annotations are optional — unannotated code defaults to `any`.
;;
;; This is an optional spec module — NOT part of the core evaluator.
;; It registers deftype and defeffect via register-special-form! at load time.
;;
;; Depends on: evaluator.sx (type-of, component accessors, env ops)
;; primitives.sx, boundary.sx (return type declarations)
;;
;; Platform interface (from evaluator.sx, already provided):
;; (type-of x) → type string
;; (symbol-name s) → string
;; (keyword-name k) → string
;; (component-body c) → AST
;; (component-params c) → list of param name strings
;; (component-has-children c) → boolean
;; (env-get env k) → value or nil
;;
;; New platform functions for types.sx:
;; (component-param-types c) → dict {param-name → type} or nil
;; (component-set-param-types! c d) → store param types on component
;; ==========================================================================
;; --------------------------------------------------------------------------
;; NOTE: deftype and defeffect definition forms have moved to web/web-forms.sx
;; (alongside defhandler, defpage, etc.) — they are domain forms, not core.
;; The type system below uses them but does not define them.
;; --------------------------------------------------------------------------
;; --------------------------------------------------------------------------
;; 1. Type representation
;; --------------------------------------------------------------------------
;; Types are plain SX values:
;; - Strings for base types: "number", "string", "boolean", "nil",
;; "symbol", "keyword", "element", "any", "never"
;; - Nullable shorthand: "string?", "number?", "dict?", "boolean?"
;; → equivalent to (or string nil) etc.
;; - Lists for compound types:
;; (or t1 t2 ...) — union
;; (list-of t) — homogeneous list
;; (dict-of tk tv) — typed dict
;; (-> t1 t2 ... treturn) — function type (last is return)
;; Base type names
(define base-types
(list "number" "string" "boolean" "nil" "symbol" "keyword"
"element" "any" "never" "list" "dict"
"lambda" "component" "island" "macro" "signal"))
;; --------------------------------------------------------------------------
;; 2. Type predicates
;; --------------------------------------------------------------------------
(define type-any?
(fn (t) (= t "any")))
(define type-never?
(fn (t) (= t "never")))
(define type-nullable?
(fn (t)
;; A type is nullable if it's "any", "nil", a "?" shorthand, or
;; a union containing "nil".
(if (= t "any") true
(if (= t "nil") true
(if (and (= (type-of t) "string") (ends-with? t "?")) true
(if (and (= (type-of t) "list")
(not (empty? t))
(= (first t) "or"))
(contains? (rest t) "nil")
false))))))
(define nullable-base
(fn (t)
;; Strip "?" from nullable shorthand: "string?" → "string"
(if (and (= (type-of t) "string")
(ends-with? t "?")
(not (= t "?")))
(slice t 0 (- (string-length t) 1))
t)))
;; --------------------------------------------------------------------------
;; 3. Subtype checking
;; --------------------------------------------------------------------------
;; subtype?(a, b) — is type `a` assignable to type `b`?
(define subtype?
(fn (a b)
;; any accepts everything
(if (type-any? b) true
;; never is subtype of everything
(if (type-never? a) true
;; any is not a subtype of a specific type
(if (type-any? a) false
;; identical types
(if (= a b) true
;; nil is subtype of nullable types
(if (= a "nil")
(type-nullable? b)
;; nullable shorthand: "string?" = (or string nil)
(if (and (= (type-of b) "string") (ends-with? b "?"))
(let ((base (nullable-base b)))
(or (= a base) (= a "nil")))
;; a is a union: (or t1 t2 ...) <: b if ALL members <: b
;; Must check before b-union — (or A B) <: (or A B C) needs
;; each member of a checked against the full union b.
(if (and (= (type-of a) "list")
(not (empty? a))
(= (first a) "or"))
(every? (fn (member) (subtype? member b)) (rest a))
;; union: a <: (or t1 t2 ...) if a <: any member
(if (and (= (type-of b) "list")
(not (empty? b))
(= (first b) "or"))
(some (fn (member) (subtype? a member)) (rest b))
;; list-of covariance
(if (and (= (type-of a) "list") (= (type-of b) "list")
(= (len a) 2) (= (len b) 2)
(= (first a) "list-of") (= (first b) "list-of"))
(subtype? (nth a 1) (nth b 1))
;; "list" <: (list-of any)
(if (and (= a "list")
(= (type-of b) "list")
(= (len b) 2)
(= (first b) "list-of"))
(type-any? (nth b 1))
;; (list-of t) <: "list"
(if (and (= (type-of a) "list")
(= (len a) 2)
(= (first a) "list-of")
(= b "list"))
true
;; "element" is subtype of "string?" (rendered HTML)
false)))))))))))))
;; --------------------------------------------------------------------------
;; 4. Type union
;; --------------------------------------------------------------------------
(define type-union
(fn (a b)
;; Compute the smallest type that encompasses both a and b.
(if (= a b) a
(if (type-any? a) "any"
(if (type-any? b) "any"
(if (type-never? a) b
(if (type-never? b) a
(if (subtype? a b) b
(if (subtype? b a) a
;; neither is subtype — create a union
(if (= a "nil")
;; nil + string → string?
(if (and (= (type-of b) "string")
(not (ends-with? b "?")))
(str b "?")
(list "or" a b))
(if (= b "nil")
(if (and (= (type-of a) "string")
(not (ends-with? a "?")))
(str a "?")
(list "or" a b))
(list "or" a b))))))))))))
;; --------------------------------------------------------------------------
;; 5. Type narrowing
;; --------------------------------------------------------------------------
(define narrow-type
(fn (t (predicate-name :as string))
;; Narrow type based on a predicate test in a truthy branch.
;; (if (nil? x) ..then.. ..else..) → in else, x excludes nil.
;; Returns (narrowed-then narrowed-else).
(if (= predicate-name "nil?")
(list "nil" (narrow-exclude-nil t))
(if (= predicate-name "string?")
(list "string" (narrow-exclude t "string"))
(if (= predicate-name "number?")
(list "number" (narrow-exclude t "number"))
(if (= predicate-name "list?")
(list "list" (narrow-exclude t "list"))
(if (= predicate-name "dict?")
(list "dict" (narrow-exclude t "dict"))
(if (= predicate-name "boolean?")
(list "boolean" (narrow-exclude t "boolean"))
;; Unknown predicate — no narrowing
(list t t)))))))))
(define narrow-exclude-nil
(fn (t)
;; Remove nil from a type.
(if (= t "nil") "never"
(if (= t "any") "any" ;; can't narrow any
(if (and (= (type-of t) "string") (ends-with? t "?"))
(nullable-base t)
(if (and (= (type-of t) "list")
(not (empty? t))
(= (first t) "or"))
(let ((members (filter (fn (m) (not (= m "nil"))) (rest t))))
(if (= (len members) 1) (first members)
(if (empty? members) "never"
(cons "or" members))))
t))))))
(define narrow-exclude
(fn (t excluded)
;; Remove a specific type from a union.
(if (= t excluded) "never"
(if (= t "any") "any"
(if (and (= (type-of t) "list")
(not (empty? t))
(= (first t) "or"))
(let ((members (filter (fn (m) (not (= m excluded))) (rest t))))
(if (= (len members) 1) (first members)
(if (empty? members) "never"
(cons "or" members))))
t)))))
;; --------------------------------------------------------------------------
;; 6. Type inference
;; --------------------------------------------------------------------------
;; infer-type walks an AST node and returns its inferred type.
;; type-env is a dict mapping variable names → types.
(define infer-type
(fn (node (type-env :as dict) (prim-types :as dict) type-registry)
(let ((kind (type-of node)))
(if (= kind "number") "number"
(if (= kind "string") "string"
(if (= kind "boolean") "boolean"
(if (nil? node) "nil"
(if (= kind "keyword") "keyword"
(if (= kind "symbol")
(let ((name (symbol-name node)))
;; Look up in type env
(if (has-key? type-env name)
(get type-env name)
;; Builtins
(if (= name "true") "boolean"
(if (= name "false") "boolean"
(if (= name "nil") "nil"
;; Check primitive return types
(if (has-key? prim-types name)
(get prim-types name)
"any"))))))
(if (= kind "dict") "dict"
(if (= kind "list")
(infer-list-type node type-env prim-types type-registry)
"any")))))))))))
(define infer-list-type
(fn (node (type-env :as dict) (prim-types :as dict) type-registry)
;; Infer type of a list expression (function call, special form, etc.)
(if (empty? node) "list"
(let ((head (first node))
(args (rest node)))
(if (not (= (type-of head) "symbol"))
"any" ;; complex head — can't infer
(let ((name (symbol-name head)))
;; Special forms
(if (= name "if")
(infer-if-type args type-env prim-types type-registry)
(if (= name "when")
(if (>= (len args) 2)
(type-union (infer-type (last args) type-env prim-types type-registry) "nil")
"nil")
(if (or (= name "cond") (= name "case"))
"any" ;; complex — could be refined later
(if (= name "let")
(infer-let-type args type-env prim-types type-registry)
(if (or (= name "do") (= name "begin"))
(if (empty? args) "nil"
(infer-type (last args) type-env prim-types type-registry))
(if (or (= name "lambda") (= name "fn"))
"lambda"
(if (= name "and")
(if (empty? args) "boolean"
(infer-type (last args) type-env prim-types type-registry))
(if (= name "or")
(if (empty? args) "boolean"
;; or returns first truthy — union of all args
(reduce type-union "never"
(map (fn (a) (infer-type a type-env prim-types type-registry)) args)))
(if (= name "map")
;; map returns a list
(if (>= (len args) 2)
(let ((fn-type (infer-type (first args) type-env prim-types type-registry)))
;; If the fn's return type is known, produce (list-of return-type)
(if (and (= (type-of fn-type) "list")
(= (first fn-type) "->"))
(list "list-of" (last fn-type))
"list"))
"list")
(if (= name "filter")
;; filter preserves element type
(if (>= (len args) 2)
(infer-type (nth args 1) type-env prim-types type-registry)
"list")
(if (= name "reduce")
;; reduce returns the accumulator type — too complex to infer
"any"
(if (= name "list")
"list"
(if (= name "dict")
"dict"
(if (= name "quote")
"any"
(if (= name "str")
"string"
(if (= name "not")
"boolean"
(if (= name "get")
;; get — resolve record field type from type registry
(if (and (>= (len args) 2) (not (nil? type-registry)))
(let ((dict-type (infer-type (first args) type-env prim-types type-registry))
(key-arg (nth args 1))
(key-name (cond
(= (type-of key-arg) "keyword") (keyword-name key-arg)
(= (type-of key-arg) "string") key-arg
:else nil)))
(if (and key-name
(= (type-of dict-type) "string")
(has-key? type-registry dict-type))
(let ((resolved (resolve-type dict-type type-registry)))
(if (and (= (type-of resolved) "dict")
(has-key? resolved key-name))
(get resolved key-name)
"any"))
"any"))
"any")
(if (starts-with? name "~")
"element" ;; component call
;; Regular function call: look up return type
(if (has-key? prim-types name)
(get prim-types name)
"any")))))))))))))))))))))))))
(define infer-if-type
(fn ((args :as list) (type-env :as dict) (prim-types :as dict) type-registry)
;; (if test then else?) → union of then and else types
(if (< (len args) 2) "nil"
(let ((then-type (infer-type (nth args 1) type-env prim-types type-registry)))
(if (>= (len args) 3)
(type-union then-type (infer-type (nth args 2) type-env prim-types type-registry))
(type-union then-type "nil"))))))
(define infer-let-type
(fn ((args :as list) (type-env :as dict) (prim-types :as dict) type-registry)
;; (let ((x expr) ...) body) → type of body in extended type-env
(if (< (len args) 2) "nil"
(let ((bindings (first args))
(body (last args))
(extended (merge type-env (dict))))
;; Add binding types
(for-each
(fn (binding)
(when (and (= (type-of binding) "list") (>= (len binding) 2))
(let ((name (if (= (type-of (first binding)) "symbol")
(symbol-name (first binding))
(str (first binding))))
(val-type (infer-type (nth binding 1) extended prim-types type-registry)))
(dict-set! extended name val-type))))
bindings)
(infer-type body extended prim-types type-registry)))))
;; --------------------------------------------------------------------------
;; 7. Diagnostic types
;; --------------------------------------------------------------------------
;; Diagnostics are dicts:
;; {:level "error"|"warning"|"info"
;; :message "human-readable explanation"
;; :component "~name" (or nil for top-level)
;; :expr <the offending AST node>}
(define make-diagnostic
(fn ((level :as string) (message :as string) component expr)
{:level level
:message message
:component component
:expr expr}))
;; --------------------------------------------------------------------------
;; 8. Call-site checking
;; --------------------------------------------------------------------------
(define check-primitive-call
(fn ((name :as string) (args :as list) (type-env :as dict) (prim-types :as dict) prim-param-types (comp-name :as string) type-registry)
;; Check a primitive call site against declared param types.
;; prim-param-types is a dict: {prim-name → {:positional [...] :rest-type type-or-nil}}
;; Each positional entry is a list (name type-or-nil).
;; Returns list of diagnostics.
(let ((diagnostics (list)))
(when (and (not (nil? prim-param-types))
(has-key? prim-param-types name))
(let ((sig (get prim-param-types name))
(positional (get sig "positional"))
(rest-type (get sig "rest-type")))
;; Check each positional arg
(for-each
(fn (idx)
(when (< idx (len args))
(if (< idx (len positional))
;; Positional param — check against declared type
(let ((param-info (nth positional idx))
(arg-expr (nth args idx)))
(let ((expected-type (nth param-info 1)))
(when (not (nil? expected-type))
(let ((actual (infer-type arg-expr type-env prim-types type-registry)))
(when (and (not (type-any? expected-type))
(not (type-any? actual))
(not (subtype-resolved? actual expected-type type-registry)))
(append! diagnostics
(make-diagnostic "error"
(str "Argument " (+ idx 1) " of `" name
"` expects " expected-type ", got " actual)
comp-name arg-expr)))))))
;; Rest param — check against rest-type
(when (not (nil? rest-type))
(let ((arg-expr (nth args idx))
(actual (infer-type arg-expr type-env prim-types type-registry)))
(when (and (not (type-any? rest-type))
(not (type-any? actual))
(not (subtype-resolved? actual rest-type type-registry)))
(append! diagnostics
(make-diagnostic "error"
(str "Argument " (+ idx 1) " of `" name
"` expects " rest-type ", got " actual)
comp-name arg-expr))))))))
(range 0 (len args) 1))))
diagnostics)))
(define check-component-call
(fn ((comp-name :as string) (comp :as component) (call-args :as list) (type-env :as dict) (prim-types :as dict) type-registry)
;; Check a component call site against its declared param types.
;; comp is the component value, call-args is the list of args
;; from the call site (after the component name).
(let ((diagnostics (list))
(param-types (component-param-types comp))
(params (component-params comp)))
(when (and (not (nil? param-types))
(not (empty? (keys param-types))))
;; Parse keyword args from call site
(let ((i 0)
(provided-keys (list)))
(for-each
(fn (idx)
(when (< idx (len call-args))
(let ((arg (nth call-args idx)))
(when (= (type-of arg) "keyword")
(let ((key-name (keyword-name arg)))
(append! provided-keys key-name)
(when (< (+ idx 1) (len call-args))
(let ((val-expr (nth call-args (+ idx 1))))
;; Check type of value against declared param type
(when (has-key? param-types key-name)
(let ((expected (get param-types key-name))
(actual (infer-type val-expr type-env prim-types type-registry)))
(when (and (not (type-any? expected))
(not (type-any? actual))
(not (subtype-resolved? actual expected type-registry)))
(append! diagnostics
(make-diagnostic "error"
(str "Keyword :" key-name " of " comp-name
" expects " expected ", got " actual)
comp-name val-expr))))))))))))
(range 0 (len call-args) 1))
;; Check for missing required params (those with declared types)
(for-each
(fn (param-name)
(when (and (has-key? param-types param-name)
(not (contains? provided-keys param-name))
(not (type-nullable? (get param-types param-name))))
(append! diagnostics
(make-diagnostic "warning"
(str "Required param :" param-name " of " comp-name " not provided")
comp-name nil))))
params)
;; Check for unknown kwargs
(for-each
(fn (key)
(when (not (contains? params key))
(append! diagnostics
(make-diagnostic "warning"
(str "Unknown keyword :" key " passed to " comp-name)
comp-name nil))))
provided-keys)))
diagnostics)))
;; --------------------------------------------------------------------------
;; 9. AST walker — check a component body
;; --------------------------------------------------------------------------
(define check-body-walk
(fn (node (comp-name :as string) (type-env :as dict) (prim-types :as dict) prim-param-types env (diagnostics :as list) type-registry effect-annotations)
;; Recursively walk an AST and collect diagnostics.
;; prim-param-types: dict of {name → {:positional [...] :rest-type t}} or nil
;; type-registry: dict of {type-name → type-def} or nil
;; effect-annotations: dict of {fn-name → effect-list} or nil
(let ((kind (type-of node)))
(when (= kind "list")
(when (not (empty? node))
(let ((head (first node))
(args (rest node)))
;; Check calls when head is a symbol
(when (= (type-of head) "symbol")
(let ((name (symbol-name head)))
;; Component call
(when (starts-with? name "~")
(let ((comp-val (env-get env name)))
(when (= (type-of comp-val) "component")
(for-each
(fn (d) (append! diagnostics d))
(check-component-call name comp-val args
type-env prim-types type-registry))))
;; Effect check for component calls
(when (not (nil? effect-annotations))
(let ((caller-effects (get-effects comp-name effect-annotations)))
(for-each
(fn (d) (append! diagnostics d))
(check-effect-call name caller-effects effect-annotations comp-name)))))
;; Primitive call — check param types
(when (and (not (starts-with? name "~"))
(not (nil? prim-param-types))
(has-key? prim-param-types name))
(for-each
(fn (d) (append! diagnostics d))
(check-primitive-call name args type-env prim-types
prim-param-types comp-name type-registry)))
;; Effect check for function calls
(when (and (not (starts-with? name "~"))
(not (nil? effect-annotations)))
(let ((caller-effects (get-effects comp-name effect-annotations)))
(for-each
(fn (d) (append! diagnostics d))
(check-effect-call name caller-effects effect-annotations comp-name))))
;; Recurse into let with extended type env
(when (or (= name "let") (= name "let*"))
(when (>= (len args) 2)
(let ((bindings (first args))
(body-exprs (rest args))
(extended (merge type-env (dict))))
(for-each
(fn (binding)
(when (and (= (type-of binding) "list")
(>= (len binding) 2))
(let ((bname (if (= (type-of (first binding)) "symbol")
(symbol-name (first binding))
(str (first binding))))
(val-type (infer-type (nth binding 1) extended prim-types type-registry)))
(dict-set! extended bname val-type))))
bindings)
(for-each
(fn (body)
(check-body-walk body comp-name extended prim-types prim-param-types env diagnostics type-registry effect-annotations))
body-exprs))))
;; Recurse into define with type binding
(when (= name "define")
(when (>= (len args) 2)
(let ((def-name (if (= (type-of (first args)) "symbol")
(symbol-name (first args))
nil))
(def-val (nth args 1)))
(when def-name
(dict-set! type-env def-name
(infer-type def-val type-env prim-types type-registry)))
(check-body-walk def-val comp-name type-env prim-types prim-param-types env diagnostics type-registry effect-annotations))))))
;; Recurse into all child expressions
(for-each
(fn (child)
(check-body-walk child comp-name type-env prim-types prim-param-types env diagnostics type-registry effect-annotations))
args)))))))
;; --------------------------------------------------------------------------
;; 10. Check a single component
;; --------------------------------------------------------------------------
(define check-component
(fn ((comp-name :as string) env (prim-types :as dict) prim-param-types type-registry effect-annotations)
;; Type-check a component's body. Returns list of diagnostics.
;; prim-param-types: dict of param type info, or nil to skip primitive checking.
;; type-registry: dict of {type-name → type-def} or nil
;; effect-annotations: dict of {fn-name → effect-list} or nil
(let ((comp (env-get env comp-name))
(diagnostics (list)))
(when (= (type-of comp) "component")
(let ((body (component-body comp))
(params (component-params comp))
(param-types (component-param-types comp))
;; Build initial type env from component params
(type-env (dict)))
;; Add param types (annotated or default to any)
(for-each
(fn (p)
(dict-set! type-env p
(if (and (not (nil? param-types))
(has-key? param-types p))
(get param-types p)
"any")))
params)
;; Add children as (list-of element) if component has children
(when (component-has-children comp)
(dict-set! type-env "children" (list "list-of" "element")))
(check-body-walk body comp-name type-env prim-types prim-param-types env diagnostics type-registry effect-annotations)))
diagnostics)))
;; --------------------------------------------------------------------------
;; 11. Check all components in an environment
;; --------------------------------------------------------------------------
(define check-all
(fn (env (prim-types :as dict) prim-param-types type-registry effect-annotations)
;; Type-check every component in the environment.
;; prim-param-types: dict of param type info, or nil to skip primitive checking.
;; type-registry: dict of {type-name → type-def} or nil
;; effect-annotations: dict of {fn-name → effect-list} or nil
;; Returns list of all diagnostics.
(let ((all-diagnostics (list)))
(for-each
(fn (name)
(let ((val (env-get env name)))
(when (= (type-of val) "component")
(for-each
(fn (d) (append! all-diagnostics d))
(check-component name env prim-types prim-param-types type-registry effect-annotations)))))
(keys env))
all-diagnostics)))
;; --------------------------------------------------------------------------
;; 12. Build primitive type registry
;; --------------------------------------------------------------------------
;; Builds a dict mapping primitive-name → return-type from
;; the declarations parsed by boundary_parser.py.
;; This is called by the host at startup with the parsed declarations.
(define build-type-registry
(fn ((prim-declarations :as list) (io-declarations :as list))
;; Both are lists of dicts: {:name "+" :returns "number" :params (...)}
;; Returns a flat dict: {"+" "number", "str" "string", ...}
(let ((registry (dict)))
(for-each
(fn (decl)
(let ((name (get decl "name"))
(returns (get decl "returns")))
(when (and (not (nil? name)) (not (nil? returns)))
(dict-set! registry name returns))))
prim-declarations)
(for-each
(fn (decl)
(let ((name (get decl "name"))
(returns (get decl "returns")))
(when (and (not (nil? name)) (not (nil? returns)))
(dict-set! registry name returns))))
io-declarations)
registry)))
;; --------------------------------------------------------------------------
;; 13. User-defined types (deftype)
;; --------------------------------------------------------------------------
;; Type definitions are plain dicts: {:name "price" :params [] :body "number"}
;; Stored in env under "*type-registry*" mapping type names to defs.
;; make-type-def and normalize-type-body are defined in eval.sx
;; (always compiled). They're available when types.sx is compiled as a spec module.
;; -- Standard type definitions --
;; These define the record types used throughout the type system itself.
;; Universal: nullable shorthand
(deftype (maybe a) (union a nil))
;; A type definition entry in the registry
(deftype type-def
{:name string :params list :body any})
;; A diagnostic produced by the type checker
(deftype diagnostic
{:level string :message string :component string? :expr any})
;; Primitive parameter type signature
(deftype prim-param-sig
{:positional list :rest-type string?})
;; Effect declarations
(defeffect io)
(defeffect mutation)
(defeffect render)
(define type-def-name
(fn (td) (get td "name")))
(define type-def-params
(fn (td) (get td "params")))
(define type-def-body
(fn (td) (get td "body")))
(define resolve-type
(fn (t registry)
;; Resolve a type through the registry.
;; Returns the resolved type representation.
(if (nil? registry) t
(cond
;; String — might be a named type alias
(= (type-of t) "string")
(if (has-key? registry t)
(let ((td (get registry t)))
(let ((params (type-def-params td))
(body (type-def-body td)))
(if (empty? params)
;; Simple alias — resolve the body recursively
(resolve-type body registry)
;; Parameterized with no args — return as-is
t)))
t)
;; List — might be parameterized type application or compound
(= (type-of t) "list")
(if (empty? t) t
(let ((head (first t)))
(cond
;; (or ...), (list-of ...), (-> ...) — recurse into members
(or (= head "or") (= head "list-of") (= head "->")
(= head "dict-of"))
(cons head (map (fn (m) (resolve-type m registry)) (rest t)))
;; Parameterized type application: ("maybe" "string") etc.
(and (= (type-of head) "string")
(has-key? registry head))
(let ((td (get registry head))
(params (type-def-params td))
(body (type-def-body td))
(args (rest t)))
(if (= (len params) (len args))
(resolve-type
(substitute-type-vars body params args)
registry)
;; Wrong arity — return as-is
t))
:else t)))
;; Dict — record type, resolve field types
(= (type-of t) "dict")
(map-dict (fn (k v) (resolve-type v registry)) t)
;; Anything else — return as-is
:else t))))
(define substitute-type-vars
(fn (body (params :as list) (args :as list))
;; Substitute type variables in body.
;; params is a list of type var names, args is corresponding types.
(let ((subst (dict)))
(for-each
(fn (i)
(dict-set! subst (nth params i) (nth args i)))
(range 0 (len params) 1))
(substitute-in-type body subst))))
(define substitute-in-type
(fn (t (subst :as dict))
;; Recursively substitute type variables.
(cond
(= (type-of t) "string")
(if (has-key? subst t) (get subst t) t)
(= (type-of t) "list")
(map (fn (m) (substitute-in-type m subst)) t)
(= (type-of t) "dict")
(map-dict (fn (k v) (substitute-in-type v subst)) t)
:else t)))
(define subtype-resolved?
(fn (a b registry)
;; Resolve both sides through the registry, then check subtype.
(if (nil? registry)
(subtype? a b)
(let ((ra (resolve-type a registry))
(rb (resolve-type b registry)))
;; Handle record structural subtyping: dict a <: dict b
;; if every field in b exists in a with compatible type
(if (and (= (type-of ra) "dict") (= (type-of rb) "dict"))
(every?
(fn (key)
(and (has-key? ra key)
(subtype-resolved? (get ra key) (get rb key) registry)))
(keys rb))
(subtype? ra rb))))))
;; --------------------------------------------------------------------------
;; 14. Effect checking (defeffect)
;; --------------------------------------------------------------------------
;; Effects are annotations on functions/components describing their
;; side effects. A pure function cannot call IO functions.
(define get-effects
(fn ((name :as string) effect-annotations)
;; Look up declared effects for a function/component.
;; Returns list of effect strings, or nil if unannotated.
(if (nil? effect-annotations) nil
(if (has-key? effect-annotations name)
(get effect-annotations name)
nil))))
(define effects-subset?
(fn (callee-effects caller-effects)
;; Are all callee effects allowed by caller?
;; nil effects = unannotated = assumed to have all effects.
;; Empty list = pure = no effects.
(if (nil? caller-effects) true ;; unannotated caller allows everything
(if (nil? callee-effects) true ;; unannotated callee — skip check
(every?
(fn (e) (contains? caller-effects e))
callee-effects)))))
(define check-effect-call
(fn ((callee-name :as string) caller-effects effect-annotations (comp-name :as string))
;; Check that callee's effects are allowed by caller's effects.
;; Returns list of diagnostics.
(let ((diagnostics (list))
(callee-effects (get-effects callee-name effect-annotations)))
(when (and (not (nil? caller-effects))
(not (nil? callee-effects))
(not (effects-subset? callee-effects caller-effects)))
(append! diagnostics
(make-diagnostic "error"
(str "`" callee-name "` has effects "
(join ", " callee-effects)
" but `" comp-name "` only allows "
(if (empty? caller-effects) "[pure]"
(join ", " caller-effects)))
comp-name nil)))
diagnostics)))
(define build-effect-annotations
(fn ((io-declarations :as list))
;; Assign [io] effect to all IO primitives.
(let ((annotations (dict)))
(for-each
(fn (decl)
(let ((name (get decl "name")))
(when (not (nil? name))
(dict-set! annotations name (list "io")))))
io-declarations)
annotations)))
;; --------------------------------------------------------------------------
;; 15. Check component effects — convenience wrapper
;; --------------------------------------------------------------------------
;; Validates that components respect their declared effect annotations.
;; Delegates to check-body-walk with nil type checking (effects only).
(define check-component-effects
(fn ((comp-name :as string) env effect-annotations)
;; Check a single component's effect usage. Returns diagnostics list.
;; Skips type checking — only checks effect violations.
(let ((comp (env-get env comp-name))
(diagnostics (list)))
(when (= (type-of comp) "component")
(let ((body (component-body comp)))
(check-body-walk body comp-name (dict) (dict) nil env
diagnostics nil effect-annotations)))
diagnostics)))
(define check-all-effects
(fn (env effect-annotations)
;; Check all components in env for effect violations.
;; Returns list of all diagnostics.
(let ((all-diagnostics (list)))
(for-each
(fn (name)
(let ((val (env-get env name)))
(when (= (type-of val) "component")
(for-each
(fn (d) (append! all-diagnostics d))
(check-component-effects name env effect-annotations)))))
(keys env))
all-diagnostics)))
;; --------------------------------------------------------------------------
;; Platform interface summary
;; --------------------------------------------------------------------------
;;
;; From eval.sx (already provided):
;; (type-of x), (symbol-name s), (keyword-name k), (env-get env k)
;; (component-body c), (component-params c), (component-has-children c)
;;
;; New for types.sx (each host implements):
;; (component-param-types c) → dict {param-name → type} or nil
;; (component-set-param-types! c d) → store param types on component
;; (merge d1 d2) → new dict merging d1 and d2
;;
;; Primitive param types:
;; The host provides prim-param-types as a dict mapping primitive names
;; to param type descriptors. Each descriptor is a dict:
;; {"positional" [["name" "type-or-nil"] ...] "rest-type" "type-or-nil"}
;; Built by boundary_parser.parse_primitive_param_types() in Python.
;; Passed to check-component/check-all as an optional extra argument.
;;
;; --------------------------------------------------------------------------

633
lib/vm.sx Normal file
View File

@@ -0,0 +1,633 @@
;; ==========================================================================
;; vm.sx — SX bytecode virtual machine
;;
;; Stack-based interpreter for bytecode produced by compiler.sx.
;; Written in SX — transpiled to each target (OCaml, JS, WASM).
;;
;; Architecture:
;; - Array-based value stack (no allocation per step)
;; - Frame list for call stack (one frame per function invocation)
;; - Upvalue cells for shared mutable closure variables
;; - Iterative dispatch loop (no host-stack growth)
;; - TCO via frame replacement on OP_TAIL_CALL
;;
;; Platform interface:
;; The host must provide:
;; - make-vm-stack, vm-stack-get, vm-stack-set!, vm-stack-grow
;; - cek-call (fallback for Lambda/Component)
;; - get-primitive (primitive lookup)
;; Everything else is defined here.
;; ==========================================================================
;; --------------------------------------------------------------------------
;; 1. Types — VM data structures
;; --------------------------------------------------------------------------
;; Upvalue cell — shared mutable reference for captured variables.
;; When a closure captures a local, both the parent frame and the
;; closure read/write through this cell.
(define make-upvalue-cell
(fn (value)
{:uv-value value}))
(define uv-get (fn (cell) (get cell "uv-value")))
(define uv-set! (fn (cell value) (dict-set! cell "uv-value" value)))
;; VM code object — compiled bytecode + constant pool.
;; Produced by compiler.sx, consumed by the VM.
(define make-vm-code
(fn (arity locals bytecode constants)
{:vc-arity arity
:vc-locals locals
:vc-bytecode bytecode
:vc-constants constants}))
;; VM closure — code + captured upvalues + globals reference.
(define make-vm-closure
(fn (code upvalues name globals closure-env)
{:vm-code code
:vm-upvalues upvalues
:vm-name name
:vm-globals globals
:vm-closure-env closure-env}))
;; VM frame — one per active function invocation.
(define make-vm-frame
(fn (closure base)
{:closure closure
:ip 0
:base base
:local-cells {}}))
;; VM state — the virtual machine.
(define make-vm
(fn (globals)
{:stack (make-vm-stack 4096)
:sp 0
:frames (list)
:globals globals}))
;; --------------------------------------------------------------------------
;; 2. Stack operations
;; --------------------------------------------------------------------------
(define vm-push
(fn (vm value)
(let ((sp (get vm "sp"))
(stack (get vm "stack")))
;; Grow stack if needed
(when (>= sp (vm-stack-length stack))
(let ((new-stack (make-vm-stack (* sp 2))))
(vm-stack-copy! stack new-stack sp)
(dict-set! vm "stack" new-stack)
(set! stack new-stack)))
(vm-stack-set! stack sp value)
(dict-set! vm "sp" (+ sp 1)))))
(define vm-pop
(fn (vm)
(let ((sp (- (get vm "sp") 1)))
(dict-set! vm "sp" sp)
(vm-stack-get (get vm "stack") sp))))
(define vm-peek
(fn (vm)
(vm-stack-get (get vm "stack") (- (get vm "sp") 1))))
;; --------------------------------------------------------------------------
;; 3. Operand reading — read from bytecode stream
;; --------------------------------------------------------------------------
(define frame-read-u8
(fn (frame)
(let ((ip (get frame "ip"))
(bc (get (get (get frame "closure") "vm-code") "vc-bytecode")))
(let ((v (nth bc ip)))
(dict-set! frame "ip" (+ ip 1))
v))))
(define frame-read-u16
(fn (frame)
(let ((lo (frame-read-u8 frame))
(hi (frame-read-u8 frame)))
(+ lo (* hi 256)))))
(define frame-read-i16
(fn (frame)
(let ((v (frame-read-u16 frame)))
(if (>= v 32768) (- v 65536) v))))
;; --------------------------------------------------------------------------
;; 4. Frame management
;; --------------------------------------------------------------------------
;; Push a closure frame onto the VM.
;; Lays out args as locals, pads remaining locals with nil.
(define vm-push-frame
(fn (vm closure args)
(let ((frame (make-vm-frame closure (get vm "sp"))))
(for-each (fn (a) (vm-push vm a)) args)
;; Pad remaining local slots with nil
(let ((arity (len args))
(total-locals (get (get closure "vm-code") "vc-locals")))
(let ((pad-count (- total-locals arity)))
(when (> pad-count 0)
(let ((i 0))
(define pad-loop
(fn ()
(when (< i pad-count)
(vm-push vm nil)
(set! i (+ i 1))
(pad-loop))))
(pad-loop)))))
(dict-set! vm "frames" (cons frame (get vm "frames"))))))
;; --------------------------------------------------------------------------
;; 5. Code loading — convert compiler output to VM structures
;; --------------------------------------------------------------------------
(define code-from-value
(fn (v)
"Convert a compiler output dict to a vm-code object."
(if (not (dict? v))
(make-vm-code 0 16 (list) (list))
(let ((bc-raw (get v "bytecode"))
(bc (if (nil? bc-raw) (list) bc-raw))
(consts-raw (get v "constants"))
(consts (if (nil? consts-raw) (list) consts-raw))
(arity-raw (get v "arity"))
(arity (if (nil? arity-raw) 0 arity-raw)))
(make-vm-code arity (+ arity 16) bc consts)))))
;; --------------------------------------------------------------------------
;; 6. Call dispatch — route calls by value type
;; --------------------------------------------------------------------------
;; vm-call dispatches a function call within the VM.
;; VmClosure: push frame on current VM (fast path, enables TCO).
;; NativeFn: call directly, push result.
;; Lambda/Component: fall back to CEK evaluator.
(define vm-closure?
(fn (v)
(and (dict? v) (has-key? v "vm-code"))))
(define vm-call
(fn (vm f args)
(cond
(vm-closure? f)
;; Fast path: push frame on current VM
(vm-push-frame vm f args)
(callable? f)
;; Native function or primitive
(vm-push vm (apply f args))
(or (= (type-of f) "lambda") (= (type-of f) "component") (= (type-of f) "island"))
;; CEK fallback — the host provides cek-call
(vm-push vm (cek-call f args))
:else
(error (str "VM: not callable: " (type-of f))))))
;; --------------------------------------------------------------------------
;; 7. Local/upvalue access helpers
;; --------------------------------------------------------------------------
(define frame-local-get
(fn (vm frame slot)
"Read a local variable — check shared cells first, then stack."
(let ((cells (get frame "local-cells"))
(key (str slot)))
(if (has-key? cells key)
(uv-get (get cells key))
(vm-stack-get (get vm "stack") (+ (get frame "base") slot))))))
(define frame-local-set
(fn (vm frame slot value)
"Write a local variable — to shared cell if captured, else to stack."
(let ((cells (get frame "local-cells"))
(key (str slot)))
(if (has-key? cells key)
(uv-set! (get cells key) value)
(vm-stack-set! (get vm "stack") (+ (get frame "base") slot) value)))))
(define frame-upvalue-get
(fn (frame idx)
(uv-get (nth (get (get frame "closure") "vm-upvalues") idx))))
(define frame-upvalue-set
(fn (frame idx value)
(uv-set! (nth (get (get frame "closure") "vm-upvalues") idx) value)))
;; --------------------------------------------------------------------------
;; 8. Global variable access with closure env chain
;; --------------------------------------------------------------------------
(define vm-global-get
(fn (vm frame name)
"Look up a global: globals table → closure env chain → primitives."
(let ((globals (get vm "globals")))
(if (has-key? globals name)
(get globals name)
;; Walk the closure env chain for inner functions
(let ((closure-env (get (get frame "closure") "vm-closure-env")))
(if (nil? closure-env)
(get-primitive name)
(let ((found (env-walk closure-env name)))
(if (nil? found)
(get-primitive name)
found))))))))
(define vm-global-set
(fn (vm frame name value)
"Set a global: write to closure env if name exists there, else globals."
(let ((closure-env (get (get frame "closure") "vm-closure-env"))
(written false))
(when (not (nil? closure-env))
(set! written (env-walk-set! closure-env name value)))
(when (not written)
(dict-set! (get vm "globals") name value)))))
;; env-walk: walk an environment chain looking for a binding.
;; Returns the value or nil if not found.
(define env-walk
(fn (env name)
(if (nil? env) nil
(if (env-has? env name)
(env-get env name)
(let ((parent (env-parent env)))
(if (nil? parent) nil
(env-walk parent name)))))))
;; env-walk-set!: walk an environment chain, set value if name found.
;; Returns true if set, false if not found.
(define env-walk-set!
(fn (env name value)
(if (nil? env) false
(if (env-has? env name)
(do (env-set! env name value) true)
(let ((parent (env-parent env)))
(if (nil? parent) false
(env-walk-set! parent name value)))))))
;; --------------------------------------------------------------------------
;; 9. Closure creation — OP_CLOSURE with upvalue capture
;; --------------------------------------------------------------------------
(define vm-create-closure
(fn (vm frame code-val)
"Create a closure from a code constant. Reads upvalue descriptors
from the bytecode stream and captures values from the enclosing frame."
(let ((code (code-from-value code-val))
(uv-count (if (dict? code-val)
(let ((n (get code-val "upvalue-count")))
(if (nil? n) 0 n))
0)))
(let ((upvalues
(let ((result (list))
(i 0))
(define capture-loop
(fn ()
(when (< i uv-count)
(let ((is-local (frame-read-u8 frame))
(index (frame-read-u8 frame)))
(let ((cell
(if (= is-local 1)
;; Capture from enclosing frame's local slot.
;; Create/reuse a shared cell so both parent
;; and closure read/write through it.
(let ((cells (get frame "local-cells"))
(key (str index)))
(if (has-key? cells key)
(get cells key)
(let ((c (make-upvalue-cell
(vm-stack-get (get vm "stack")
(+ (get frame "base") index)))))
(dict-set! cells key c)
c)))
;; Capture from enclosing frame's upvalue
(nth (get (get frame "closure") "vm-upvalues") index))))
(append! result cell)
(set! i (+ i 1))
(capture-loop))))))
(capture-loop)
result)))
(make-vm-closure code upvalues nil
(get vm "globals") nil)))))
;; --------------------------------------------------------------------------
;; 10. Main execution loop — iterative dispatch
;; --------------------------------------------------------------------------
(define vm-run
(fn (vm)
"Execute bytecode until all frames are exhausted.
VmClosure calls push new frames; the loop picks them up.
OP_TAIL_CALL + VmClosure = true TCO: drop frame, push new, loop."
(define loop
(fn ()
(when (not (empty? (get vm "frames")))
(let ((frame (first (get vm "frames")))
(rest-frames (rest (get vm "frames"))))
(let ((bc (get (get (get frame "closure") "vm-code") "vc-bytecode"))
(consts (get (get (get frame "closure") "vm-code") "vc-constants")))
(if (>= (get frame "ip") (len bc))
;; Bytecode exhausted — stop
(dict-set! vm "frames" (list))
(do
(vm-step vm frame rest-frames bc consts)
(loop))))))))
(loop)))
;; --------------------------------------------------------------------------
;; 11. Single step — opcode dispatch
;; --------------------------------------------------------------------------
(define vm-step
(fn (vm frame rest-frames bc consts)
(let ((op (frame-read-u8 frame)))
(cond
;; ---- Constants ----
(= op 1) ;; OP_CONST
(let ((idx (frame-read-u16 frame)))
(vm-push vm (nth consts idx)))
(= op 2) ;; OP_NIL
(vm-push vm nil)
(= op 3) ;; OP_TRUE
(vm-push vm true)
(= op 4) ;; OP_FALSE
(vm-push vm false)
(= op 5) ;; OP_POP
(vm-pop vm)
(= op 6) ;; OP_DUP
(vm-push vm (vm-peek vm))
;; ---- Variable access ----
(= op 16) ;; OP_LOCAL_GET
(let ((slot (frame-read-u8 frame)))
(vm-push vm (frame-local-get vm frame slot)))
(= op 17) ;; OP_LOCAL_SET
(let ((slot (frame-read-u8 frame)))
(frame-local-set vm frame slot (vm-peek vm)))
(= op 18) ;; OP_UPVALUE_GET
(let ((idx (frame-read-u8 frame)))
(vm-push vm (frame-upvalue-get frame idx)))
(= op 19) ;; OP_UPVALUE_SET
(let ((idx (frame-read-u8 frame)))
(frame-upvalue-set frame idx (vm-peek vm)))
(= op 20) ;; OP_GLOBAL_GET
(let ((idx (frame-read-u16 frame))
(name (nth consts idx)))
(vm-push vm (vm-global-get vm frame name)))
(= op 21) ;; OP_GLOBAL_SET
(let ((idx (frame-read-u16 frame))
(name (nth consts idx)))
(vm-global-set vm frame name (vm-peek vm)))
;; ---- Control flow ----
(= op 32) ;; OP_JUMP
(let ((offset (frame-read-i16 frame)))
(dict-set! frame "ip" (+ (get frame "ip") offset)))
(= op 33) ;; OP_JUMP_IF_FALSE
(let ((offset (frame-read-i16 frame))
(v (vm-pop vm)))
(when (not v)
(dict-set! frame "ip" (+ (get frame "ip") offset))))
(= op 34) ;; OP_JUMP_IF_TRUE
(let ((offset (frame-read-i16 frame))
(v (vm-pop vm)))
(when v
(dict-set! frame "ip" (+ (get frame "ip") offset))))
;; ---- Function calls ----
(= op 48) ;; OP_CALL
(let ((argc (frame-read-u8 frame))
(args-rev (list))
(i 0))
(define collect-args
(fn ()
(when (< i argc)
(set! args-rev (cons (vm-pop vm) args-rev))
(set! i (+ i 1))
(collect-args))))
(collect-args)
(let ((f (vm-pop vm)))
(vm-call vm f args-rev)))
(= op 49) ;; OP_TAIL_CALL
(let ((argc (frame-read-u8 frame))
(args-rev (list))
(i 0))
(define collect-args
(fn ()
(when (< i argc)
(set! args-rev (cons (vm-pop vm) args-rev))
(set! i (+ i 1))
(collect-args))))
(collect-args)
(let ((f (vm-pop vm)))
;; Drop current frame, reuse stack space — true TCO
(dict-set! vm "frames" rest-frames)
(dict-set! vm "sp" (get frame "base"))
(vm-call vm f args-rev)))
(= op 50) ;; OP_RETURN
(let ((result (vm-pop vm)))
(dict-set! vm "frames" rest-frames)
(dict-set! vm "sp" (get frame "base"))
(vm-push vm result))
(= op 51) ;; OP_CLOSURE
(let ((idx (frame-read-u16 frame))
(code-val (nth consts idx)))
(let ((cl (vm-create-closure vm frame code-val)))
(vm-push vm cl)))
(= op 52) ;; OP_CALL_PRIM
(let ((idx (frame-read-u16 frame))
(argc (frame-read-u8 frame))
(name (nth consts idx))
(args-rev (list))
(i 0))
(define collect-args
(fn ()
(when (< i argc)
(set! args-rev (cons (vm-pop vm) args-rev))
(set! i (+ i 1))
(collect-args))))
(collect-args)
(vm-push vm (call-primitive name args-rev)))
;; ---- Collections ----
(= op 64) ;; OP_LIST
(let ((count (frame-read-u16 frame))
(items-rev (list))
(i 0))
(define collect-items
(fn ()
(when (< i count)
(set! items-rev (cons (vm-pop vm) items-rev))
(set! i (+ i 1))
(collect-items))))
(collect-items)
(vm-push vm items-rev))
(= op 65) ;; OP_DICT
(let ((count (frame-read-u16 frame))
(d {})
(i 0))
(define collect-pairs
(fn ()
(when (< i count)
(let ((v (vm-pop vm))
(k (vm-pop vm)))
(dict-set! d k v)
(set! i (+ i 1))
(collect-pairs)))))
(collect-pairs)
(vm-push vm d))
;; ---- String ops ----
(= op 144) ;; OP_STR_CONCAT
(let ((count (frame-read-u8 frame))
(parts-rev (list))
(i 0))
(define collect-parts
(fn ()
(when (< i count)
(set! parts-rev (cons (vm-pop vm) parts-rev))
(set! i (+ i 1))
(collect-parts))))
(collect-parts)
(vm-push vm (apply str parts-rev)))
;; ---- Define ----
(= op 128) ;; OP_DEFINE
(let ((idx (frame-read-u16 frame))
(name (nth consts idx)))
(dict-set! (get vm "globals") name (vm-peek vm)))
;; ---- Inline primitives ----
(= op 160) ;; OP_ADD
(let ((b (vm-pop vm)) (a (vm-pop vm)))
(vm-push vm (+ a b)))
(= op 161) ;; OP_SUB
(let ((b (vm-pop vm)) (a (vm-pop vm)))
(vm-push vm (- a b)))
(= op 162) ;; OP_MUL
(let ((b (vm-pop vm)) (a (vm-pop vm)))
(vm-push vm (* a b)))
(= op 163) ;; OP_DIV
(let ((b (vm-pop vm)) (a (vm-pop vm)))
(vm-push vm (/ a b)))
(= op 164) ;; OP_EQ
(let ((b (vm-pop vm)) (a (vm-pop vm)))
(vm-push vm (= a b)))
(= op 165) ;; OP_LT
(let ((b (vm-pop vm)) (a (vm-pop vm)))
(vm-push vm (< a b)))
(= op 166) ;; OP_GT
(let ((b (vm-pop vm)) (a (vm-pop vm)))
(vm-push vm (> a b)))
(= op 167) ;; OP_NOT
(vm-push vm (not (vm-pop vm)))
(= op 168) ;; OP_LEN
(vm-push vm (len (vm-pop vm)))
(= op 169) ;; OP_FIRST
(vm-push vm (first (vm-pop vm)))
(= op 170) ;; OP_REST
(vm-push vm (rest (vm-pop vm)))
(= op 171) ;; OP_NTH
(let ((n (vm-pop vm)) (coll (vm-pop vm)))
(vm-push vm (nth coll n)))
(= op 172) ;; OP_CONS
(let ((coll (vm-pop vm)) (x (vm-pop vm)))
(vm-push vm (cons x coll)))
(= op 173) ;; OP_NEG
(vm-push vm (- 0 (vm-pop vm)))
(= op 174) ;; OP_INC
(vm-push vm (inc (vm-pop vm)))
(= op 175) ;; OP_DEC
(vm-push vm (dec (vm-pop vm)))
:else
(error (str "VM: unknown opcode " op))))))
;; --------------------------------------------------------------------------
;; 12. Entry points
;; --------------------------------------------------------------------------
;; Execute a closure with arguments — creates a fresh VM.
(define vm-call-closure
(fn (closure args globals)
(let ((vm (make-vm globals)))
(vm-push-frame vm closure args)
(vm-run vm)
(vm-pop vm))))
;; Execute a compiled module (top-level bytecode).
(define vm-execute-module
(fn (code globals)
(let ((closure (make-vm-closure code (list) "module" globals nil))
(vm (make-vm globals)))
(let ((frame (make-vm-frame closure 0)))
;; Pad local slots
(let ((i 0)
(total (get code "vc-locals")))
(define pad-loop
(fn ()
(when (< i total)
(vm-push vm nil)
(set! i (+ i 1))
(pad-loop))))
(pad-loop))
(dict-set! vm "frames" (list frame))
(vm-run vm)
(vm-pop vm)))))
;; --------------------------------------------------------------------------
;; 13. Platform interface
;; --------------------------------------------------------------------------
;;
;; Each target must provide:
;;
;; make-vm-stack(size) → opaque stack (array-like)
;; vm-stack-get(stack, idx) → value at index
;; vm-stack-set!(stack, idx, value) → mutate index
;; vm-stack-length(stack) → current capacity
;; vm-stack-copy!(src, dst, count) → copy first count elements
;;
;; cek-call(f, args) → evaluate via CEK machine (fallback)
;; get-primitive(name) → look up primitive by name (returns callable)
;; call-primitive(name, args) → call primitive directly with args list
;;
;; env-parent(env) → parent environment or nil
;; env-has?(env, name) → boolean
;; env-get(env, name) → value
;; env-set!(env, name, value) → mutate binding