From 8bba02fbc993970f75dfc8dfdaade6b26359d5b9 Mon Sep 17 00:00:00 2001 From: giles Date: Sun, 29 Mar 2026 07:53:16 +0000 Subject: [PATCH] Use match for value dispatch in evaluator and compiler Convert large cond chains doing string equality dispatch to use the match special form: step-eval-list (42 arms), step-continue (31 arms), compile-list (30 arms), ho-setup-dispatch (7 arms), value-matches-type? (10 arms). Also fix test-canonical.sx to use defsuite/deftest format and load canonical.sx in both test runners. Co-Authored-By: Claude Opus 4.6 (1M context) --- hosts/javascript/run_tests.js | 24 + hosts/ocaml/bin/run_tests.ml | 18 + lib/compiler.sx | 1260 ++++++++++++++-------------- spec/evaluator.sx | 1445 ++++++++++++++++----------------- spec/tests/test-canonical.sx | 66 +- 5 files changed, 1399 insertions(+), 1414 deletions(-) diff --git a/hosts/javascript/run_tests.js b/hosts/javascript/run_tests.js index dc7ff631..1f229ed2 100644 --- a/hosts/javascript/run_tests.js +++ b/hosts/javascript/run_tests.js @@ -82,6 +82,18 @@ env["env-merge"] = function(a, b) { return Object.assign({}, a, b); }; // Missing primitives referenced by tests // primitive? is now in platform.py PRIMITIVES +env["contains-char?"] = function(s, c) { return typeof s === "string" && typeof c === "string" && s.indexOf(c) >= 0; }; +env["escape-string"] = function(s) { return s.replace(/\\/g, "\\\\").replace(/"/g, '\\"').replace(/\n/g, "\\n").replace(/\t/g, "\\t"); }; +env["trim-right"] = function(s) { return typeof s === "string" ? s.trimEnd() : s; }; +env["sha3-256"] = function(s) { + // Simple hash stub for testing — not real SHA3 + var h = 0; + for (var i = 0; i < s.length; i++) { h = ((h << 5) - h + s.charCodeAt(i)) | 0; } + h = Math.abs(h); + var hex = h.toString(16); + while (hex.length < 64) hex = "0" + hex; + return hex; +}; env["upcase"] = function(s) { return s.toUpperCase(); }; env["downcase"] = function(s) { return s.toLowerCase(); }; env["make-keyword"] = function(name) { return new Sx.Keyword(name); }; @@ -291,6 +303,18 @@ if (fs.existsSync(harnessPath)) { } } +// Load canonical.sx (content-addressing, serialization) +const canonicalPath = path.join(projectDir, "spec", "canonical.sx"); +if (fs.existsSync(canonicalPath)) { + const canonicalSrc = fs.readFileSync(canonicalPath, "utf8"); + const canonicalExprs = Sx.parse(canonicalSrc); + for (const expr of canonicalExprs) { + try { Sx.eval(expr, env); } catch (e) { + console.error(`Error loading canonical.sx: ${e.message}`); + } + } +} + // Load compiler + VM from lib/ when running full tests if (fullBuild) { const libDir = path.join(projectDir, "lib"); diff --git a/hosts/ocaml/bin/run_tests.ml b/hosts/ocaml/bin/run_tests.ml index 40392abe..13e33641 100644 --- a/hosts/ocaml/bin/run_tests.ml +++ b/hosts/ocaml/bin/run_tests.ml @@ -390,6 +390,22 @@ let make_test_env () = bind "defeffect" (fun _args -> Nil); (* --- Primitives for canonical.sx / content tests --- *) + bind "symbol-name" (fun args -> + match args with + | [Symbol s] -> String s + | _ -> raise (Eval_error "symbol-name: expected symbol")); + bind "keyword-name" (fun args -> + match args with + | [Keyword k] -> String k + | _ -> raise (Eval_error "keyword-name: expected keyword")); + bind "trim-right" (fun args -> + match args with + | [String s] -> + let len = String.length s in + let i = ref (len - 1) in + while !i >= 0 && (s.[!i] = ' ' || s.[!i] = '\t' || s.[!i] = '\n' || s.[!i] = '\r') do decr i done; + String (String.sub s 0 (!i + 1)) + | _ -> raise (Eval_error "trim-right: expected string")); bind "contains-char?" (fun args -> match args with | [String s; String c] when String.length c = 1 -> @@ -809,6 +825,8 @@ let run_spec_tests env test_files = with e -> Printf.eprintf "Warning: %s: %s\n%!" name (Printexc.to_string e)) end in + (* Content-addressing, serialization *) + load_module "canonical.sx" spec_dir; (* Render adapter for test-render-html.sx *) load_module "render.sx" spec_dir; load_module "adapter-html.sx" web_dir; diff --git a/lib/compiler.sx b/lib/compiler.sx index c1aa987b..89a030ca 100644 --- a/lib/compiler.sx +++ b/lib/compiler.sx @@ -1,826 +1,786 @@ -;; ========================================================================== -;; 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. -;; ========================================================================== +(define make-pool (fn () {:entries (if (primitive? "mutable-list") (mutable-list) (list)) :index {:_count 0}})) - -;; -------------------------------------------------------------------------- -;; Constant pool builder -;; -------------------------------------------------------------------------- - -(define make-pool - (fn () - {:entries (if (primitive? "mutable-list") (mutable-list) (list)) - :index {:_count 0}})) - -(define pool-add - (fn (pool value) +(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) + (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"))) + (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))))) +(define make-scope (fn (parent) {:next-slot 0 :upvalues (list) :locals (list) :parent parent :is-function false})) -;; -------------------------------------------------------------------------- -;; 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 +(define + scope-define-local + (fn + (scope name) + "Add a local variable, return its slot index.\n 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}) + (let + ((slot (get scope "next-slot"))) + (append! (get scope "locals") {:mutable false :slot slot :name name}) (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") +(define + scope-resolve + (fn + (scope name) + "Resolve a variable name. Returns {:type \"local\"|\"upvalue\"|\"global\", :index N}.\n Upvalue captures only happen at function boundaries (is-function=true).\n Let scopes share the enclosing function's frame — their locals are\n accessed directly without upvalue indirection." + (if + (nil? scope) + {:index name :type "global"} + (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)))) + {:index (get local "slot") :type "local"}) + (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)))) + {:index (get uv "uv-index") :type "upvalue"}) + (let + ((parent (get scope "parent"))) + (if + (nil? parent) + {:index name :type "global"} + (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) + (if + (get scope "is-function") + (let + ((uv-idx (len (get scope "upvalues")))) + (append! (get scope "upvalues") {:index (get parent-result "index") :is-local (= (get parent-result "type") "local") :uv-index uv-idx :name name}) + {:index uv-idx :type "upvalue"}) parent-result)))))))))))) +(define make-emitter (fn () {:pool (make-pool) :bytecode (if (primitive? "mutable-list") (mutable-list) (list))})) -;; -------------------------------------------------------------------------- -;; Code emitter -;; -------------------------------------------------------------------------- +(define emit-byte (fn (em byte) (append! (get em "bytecode") byte))) -(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) +(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-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-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 +(define + emit-const + (fn + (em value) + (let + ((idx (pool-add (get em "pool") value))) + (emit-op em 1) (emit-u16 em idx)))) -(define current-offset - (fn (em) - (len (get em "bytecode")))) +(define current-offset (fn (em) (len (get em "bytecode")))) -(define patch-i16 - (fn (em offset value) +(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 + (let + ((v (if (< value 0) (+ value 65536) value)) + (bc (get em "bytecode"))) (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?) +(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 + (emit-op em 2) (= (type-of expr) "number") - (emit-const em expr) - - ;; String + (emit-const em expr) (= (type-of expr) "string") - (emit-const em expr) - - ;; Boolean + (emit-const em expr) (= (type-of expr) "boolean") - (emit-op em (if expr 3 4)) ;; OP_TRUE / OP_FALSE - - ;; Keyword + (emit-op em (if expr 3 4)) (= (type-of expr) "keyword") - (emit-const em (keyword-name expr)) - - ;; Symbol — resolve to local/upvalue/global + (emit-const em (keyword-name expr)) (= (type-of expr) "symbol") - (compile-symbol em (symbol-name expr) scope) - - ;; List — dispatch on head + (compile-symbol em (symbol-name expr) scope) (= (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 + (if + (empty? expr) + (do (emit-op em 64) (emit-u16 em 0)) + (compile-list em expr scope tail?)) (= (type-of expr) "dict") - (compile-dict em expr scope) + (compile-dict em expr scope) + :else (emit-const em expr)))) - ;; Fallback - :else - (emit-const em expr)))) - - -(define compile-symbol - (fn (em name scope) - (let ((resolved (scope-resolve scope name))) +(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"))) + (do (emit-op em 16) (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)))))) + (do (emit-op em 18) (emit-byte em (get resolved "index"))) + :else (let + ((idx (pool-add (get em "pool") name))) + (emit-op em 20) + (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)) +(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-op em 65) (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 +(define + compile-list + (fn + (em expr scope tail?) + (let + ((head (first expr)) (args (rest expr))) + (if + (not (= (type-of head) "symbol")) (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?))))))) + (let + ((name (symbol-name head))) + (match + name + ("if" (compile-if em args scope tail?)) + ("when" (compile-when em args scope tail?)) + ("and" (compile-and em args scope tail?)) + ("or" (compile-or em args scope tail?)) + ("let" (compile-let em args scope tail?)) + ("let*" (compile-let em args scope tail?)) + ("begin" (compile-begin em args scope tail?)) + ("do" (compile-begin em args scope tail?)) + ("lambda" (compile-lambda em args scope)) + ("fn" (compile-lambda em args scope)) + ("define" (compile-define em args scope)) + ("set!" (compile-set em args scope)) + ("quote" (compile-quote em args)) + ("cond" (compile-cond em args scope tail?)) + ("case" (compile-case em args scope tail?)) + ("->" (compile-thread em args scope tail?)) + ("defcomp" (compile-defcomp em args scope)) + ("defisland" (compile-defcomp em args scope)) + ("defmacro" (compile-defmacro em args scope)) + ("defstyle" (emit-op em 2)) + ("defhandler" (emit-op em 2)) + ("defpage" (emit-op em 2)) + ("defquery" (emit-op em 2)) + ("defaction" (emit-op em 2)) + ("defrelation" (emit-op em 2)) + ("deftype" (emit-op em 2)) + ("defeffect" (emit-op em 2)) + ("quasiquote" (compile-quasiquote em (first args) scope)) + ("letrec" (compile-letrec em args scope tail?)) + (_ (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 +(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-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) + (emit-op em 33) + (let + ((else-jump (current-offset em))) + (emit-i16 em 0) (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 + (emit-op em 32) + (let + ((end-jump (current-offset em))) + (emit-i16 em 0) (patch-i16 em else-jump (- (current-offset em) (+ else-jump 2))) - ;; Compile else - (if (nil? else-expr) - (emit-op em 2) ;; OP_NIL + (if + (nil? else-expr) + (emit-op em 2) (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))) +(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-op em 33) + (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-op em 32) + (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 + (emit-op em 2) (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) +(define + compile-and + (fn + (em args scope tail?) + (if + (empty? args) + (emit-op em 3) + (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-op em 6) + (emit-op em 33) + (let + ((skip (current-offset em))) (emit-i16 em 0) - (emit-op em 5) ;; OP_POP (discard duplicated truthy) + (emit-op em 5) (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) +(define + compile-or + (fn + (em args scope tail?) + (if + (empty? args) + (emit-op em 4) + (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-op em 6) + (emit-op em 34) + (let + ((skip (current-offset em))) (emit-i16 em 0) - (emit-op em 5) ;; OP_POP + (emit-op em 5) (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)))) +(define + compile-begin + (fn + (em exprs scope tail?) + (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) + (if + (empty? exprs) + (emit-op em 2) + (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 + (emit-op em 5) (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))) +(define + compile-let + (fn + (em args scope tail?) + (if + (= (type-of (first args)) "symbol") + (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))) + (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)) + (let + ((bindings (first args)) (body (rest args)) (let-scope (make-scope scope))) + (dict-set! let-scope "next-slot" (get scope "next-slot")) + (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) + (emit-byte em slot))) + bindings) + (compile-begin em body let-scope tail?))))) + +(define + compile-letrec + (fn + (em args scope tail?) + "Compile letrec: all names visible during value compilation.\n 1. Define all local slots (initialized to nil).\n 2. Compile each value and assign — names are already in scope\n 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 + (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) (emit-op em 17) (emit-byte em slot) slot))) bindings))) + (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) + (emit-byte em slot))) + (map + (fn (i) (list (nth bindings i) (nth slots i))) + (range 0 (len bindings))))) (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 +(define + compile-lambda + (fn + (em args scope) + (let + ((params (first args)) + (body (rest args)) + (fn-scope (make-scope scope)) + (fn-em (make-emitter))) (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)))) + (for-each + (fn + (p) + (let + ((name (cond (= (type-of p) "symbol") (symbol-name p) (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 + (compile-begin fn-em body fn-scope true) + (emit-op fn-em 50) + (let + ((upvals (get fn-scope "upvalues")) + (code {:upvalue-count (len upvals) :arity (len (get fn-scope "locals")) :constants (get (get fn-em "pool") "entries") :bytecode (get fn-em "bytecode")}) + (code-idx (pool-add (get em "pool") code))) + (emit-op em 51) (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"))) + (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)) + (value + (let + ((rest-args (rest args))) + (if + (and + (not (empty? rest-args)) + (= (type-of (first rest-args)) "keyword")) + (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))))) + (if + (not (nil? (get scope "parent"))) + (let + ((slot (scope-define-local scope name))) + (compile-expr em value scope false) + (emit-op em 17) + (emit-byte em slot)) + (let + ((name-idx (pool-add (get em "pool") name))) + (compile-expr em value scope false) + (emit-op em 128) + (emit-u16 em name-idx)))))) -(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))) +(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"))) + (do (emit-op em 17) (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)))))) + (do (emit-op em 19) (emit-byte em (get resolved "index"))) + :else (let + ((idx (pool-add (get em "pool") name))) + (emit-op em 21) + (emit-u16 em idx)))))) +(define + compile-quote + (fn + (em args) + (if (empty? args) (emit-op em 2) (emit-const em (first args))))) -(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?) +(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 + (if + (< (len args) 2) + (emit-op em 2) + (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)) (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-op em 33) + (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-op em 32) + (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))))))))))) + (patch-i16 + em + end-jump + (- (current-offset em) (+ end-jump 2))))))))))) - -(define compile-case - (fn (em args scope tail?) +(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))) + (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?)) +(define + compile-case-clauses + (fn + (em clauses scope tail?) + (if + (< (len clauses) 2) + (do (emit-op em 5) (emit-op em 2)) + (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) (compile-expr em body scope tail?)) (do - (emit-op em 6) ;; DUP match-val + (emit-op em 6) (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))) + (let + ((name-idx (pool-add (get em "pool") "="))) + (emit-op em 52) + (emit-u16 em name-idx) + (emit-byte em 2)) + (emit-op em 33) + (let + ((skip (current-offset em))) (emit-i16 em 0) - (emit-op em 5) ;; POP match-val + (emit-op em 5) (compile-expr em body scope tail?) - (emit-op em 32) ;; JUMP - (let ((end-jump (current-offset em))) + (emit-op em 32) + (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))))))))))) + (patch-i16 + em + end-jump + (- (current-offset em) (+ end-jump 2))))))))))) - -(define compile-thread - (fn (em args scope tail?) +(define + compile-thread + (fn + (em args scope tail?) "Compile (-> val (f1 a) (f2 b)) by desugaring to nested calls." - (if (empty? args) + (if + (empty? args) (emit-op em 2) - (if (= (len args) 1) + (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))) + (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) +(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) + (let + ((form (first forms)) + (rest-forms (rest forms)) + (is-tail (and tail? (empty? rest-forms)))) + (let + ((call-expr (if (list? form) (concat (list (first form) val-expr) (rest form)) (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) +(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 + (let + ((name-idx (pool-add (get em "pool") "eval-defcomp"))) + (emit-op em 20) + (emit-u16 em name-idx)) (emit-const em (concat (list (make-symbol "defcomp")) args)) - (emit-op em 48) (emit-byte em 1))) ;; CALL 1 + (emit-op em 48) + (emit-byte em 1))) -(define compile-defmacro - (fn (em args scope) +(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 + (let + ((name-idx (pool-add (get em "pool") "eval-defmacro"))) + (emit-op em 20) + (emit-u16 em name-idx)) (emit-const em (concat (list (make-symbol "defmacro")) args)) - (emit-op em 48) (emit-byte em 1))) + (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." +(define + compile-quasiquote + (fn + (em expr scope) + "Compile quasiquote inline — walks the template at compile time,\n emitting code that builds the structure at runtime. Unquoted\n expressions are compiled normally (resolving locals/upvalues),\n avoiding the qq-expand-runtime env-lookup limitation." (compile-qq-expr em expr scope))) -(define compile-qq-expr - (fn (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 + (if + (not (= (type-of expr) "list")) (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 + (if + (empty? expr) + (do (emit-op em 64) (emit-u16 em 0)) + (let + ((head (first expr))) + (if + (and + (= (type-of head) "symbol") + (= (symbol-name head) "unquote")) (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 +(define + compile-qq-list + (fn + (em items scope) + "Compile a quasiquote list. Handles splice-unquote by building\n 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) (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)) + (emit-op em 64) + (emit-u16 em (len items))) + (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 + (fn + (item) + (if + (and + (= (type-of item) "list") + (>= (len item) 2) + (= (type-of (first item)) "symbol") + (= (symbol-name (first item)) "splice-unquote")) (do - (when (> pending 0) - (emit-op em 64) (emit-u16 em pending) ;; OP_LIST for pending + (when + (> pending 0) + (emit-op em 64) + (emit-u16 em 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) + (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) + (when + (> segment-count 1) + (let + ((concat-idx (pool-add (get em "pool") "concat"))) + (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))) +(define + compile-call + (fn + (em head args scope tail?) + (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 + (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-op em 52) (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))))))))) + (if + tail? + (do (emit-op em 49) (emit-byte em (len args))) + (do (emit-op em 48) (emit-byte em (len args))))))))) - -;; -------------------------------------------------------------------------- -;; Top-level API -;; -------------------------------------------------------------------------- - -(define compile - (fn (expr) +(define + compile + (fn + (expr) "Compile a single SX expression to a bytecode module." - (let ((em (make-emitter)) - (scope (make-scope nil))) + (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")}))) + (emit-op em 50) + {:constants (get (get em "pool") "entries") :bytecode (get em "bytecode")}))) -(define compile-module - (fn (exprs) +(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 + (let + ((em (make-emitter)) (scope (make-scope nil))) + (for-each + (fn (expr) (compile-expr em expr scope false) (emit-op em 5)) (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")}))) + (emit-op em 50) + {:constants (get (get em "pool") "entries") :bytecode (get em "bytecode")}))) diff --git a/spec/evaluator.sx b/spec/evaluator.sx index e43c7a3c..0c4572b3 100644 --- a/spec/evaluator.sx +++ b/spec/evaluator.sx @@ -306,34 +306,27 @@ value-matches-type? (fn (val expected-type) - (cond - (= expected-type "any") - true - (= expected-type "number") - (number? val) - (= expected-type "string") - (string? val) - (= expected-type "boolean") - (boolean? val) - (= expected-type "nil") - (nil? val) - (= expected-type "list") - (list? val) - (= expected-type "dict") - (dict? val) - (= expected-type "lambda") - (lambda? val) - (= expected-type "symbol") - (= (type-of val) "symbol") - (= expected-type "keyword") - (= (type-of val) "keyword") - (and (string? expected-type) (ends-with? expected-type "?")) - (or - (nil? val) - (value-matches-type? - val - (slice expected-type 0 (- (string-length expected-type) 1)))) - :else true))) + (match + expected-type + ("any" true) + ("number" (number? val)) + ("string" (string? val)) + ("boolean" (boolean? val)) + ("nil" (nil? val)) + ("list" (list? val)) + ("dict" (dict? val)) + ("lambda" (lambda? val)) + ("symbol" (= (type-of val) "symbol")) + ("keyword" (= (type-of val) "keyword")) + (_ + (if + (and (string? expected-type) (ends-with? expected-type "?")) + (or + (nil? val) + (value-matches-type? + val + (slice expected-type 0 (- (string-length expected-type) 1)))) + true))))) (define strict-check-args @@ -1019,103 +1012,70 @@ (= (type-of head) "symbol") (let ((name (symbol-name head))) - (cond - (= name "if") - (step-sf-if args env kont) - (= name "when") - (step-sf-when args env kont) - (= name "cond") - (step-sf-cond args env kont) - (= name "case") - (step-sf-case args env kont) - (= name "and") - (step-sf-and args env kont) - (= name "or") - (step-sf-or args env kont) - (= name "let") - (step-sf-let args env kont) - (= name "let*") - (step-sf-let args env kont) - (= name "lambda") - (step-sf-lambda args env kont) - (= name "fn") - (step-sf-lambda args env kont) - (= name "define") - (step-sf-define args env kont) - (= name "defcomp") - (make-cek-value (sf-defcomp args env) env kont) - (= name "defisland") - (make-cek-value (sf-defisland args env) env kont) - (= name "defmacro") - (make-cek-value (sf-defmacro args env) env kont) - (= name "begin") - (step-sf-begin args env kont) - (= name "do") - (step-sf-begin args env kont) - (= name "quote") - (make-cek-value (if (empty? args) nil (first args)) env kont) - (= name "quasiquote") - (make-cek-value (qq-expand (first args) env) env kont) - (= name "->") - (step-sf-thread-first args env kont) - (= name "set!") - (step-sf-set! args env kont) - (= name "letrec") - (step-sf-letrec args env kont) - (= name "reset") - (step-sf-reset args env kont) - (= name "shift") - (step-sf-shift args env kont) - (= name "deref") - (step-sf-deref args env kont) - (= name "scope") - (step-sf-scope args env kont) - (= name "provide") - (step-sf-provide args env kont) - (= name "context") - (step-sf-context args env kont) - (= name "emit!") - (step-sf-emit args env kont) - (= name "emitted") - (step-sf-emitted args env kont) - (= name "handler-bind") - (step-sf-handler-bind args env kont) - (= name "restart-case") - (step-sf-restart-case args env kont) - (= name "signal") - (step-sf-signal args env kont) - (= name "invoke-restart") - (step-sf-invoke-restart args env kont) - (= name "match") - (step-sf-match args env kont) - (= name "dynamic-wind") - (make-cek-value (sf-dynamic-wind args env) env kont) - (= name "map") - (step-ho-map args env kont) - (= name "map-indexed") - (step-ho-map-indexed args env kont) - (= name "filter") - (step-ho-filter args env kont) - (= name "reduce") - (step-ho-reduce args env kont) - (= name "some") - (step-ho-some args env kont) - (= name "every?") - (step-ho-every args env kont) - (= name "for-each") - (step-ho-for-each args env kont) - (has-key? *custom-special-forms* name) - (make-cek-value - ((get *custom-special-forms* name) args env) - env - kont) - (and (env-has? env name) (macro? (env-get env name))) - (let - ((mac (env-get env name))) - (make-cek-state (expand-macro mac args env) env kont)) - (and *render-check* (*render-check* expr env)) - (make-cek-value (*render-fn* expr env) env kont) - :else (step-eval-call head args env kont))) + (match + name + ("if" (step-sf-if args env kont)) + ("when" (step-sf-when args env kont)) + ("cond" (step-sf-cond args env kont)) + ("case" (step-sf-case args env kont)) + ("and" (step-sf-and args env kont)) + ("or" (step-sf-or args env kont)) + ("let" (step-sf-let args env kont)) + ("let*" (step-sf-let args env kont)) + ("lambda" (step-sf-lambda args env kont)) + ("fn" (step-sf-lambda args env kont)) + ("define" (step-sf-define args env kont)) + ("defcomp" (make-cek-value (sf-defcomp args env) env kont)) + ("defisland" (make-cek-value (sf-defisland args env) env kont)) + ("defmacro" (make-cek-value (sf-defmacro args env) env kont)) + ("begin" (step-sf-begin args env kont)) + ("do" (step-sf-begin args env kont)) + ("quote" + (make-cek-value + (if (empty? args) nil (first args)) + env + kont)) + ("quasiquote" + (make-cek-value (qq-expand (first args) env) env kont)) + ("->" (step-sf-thread-first args env kont)) + ("set!" (step-sf-set! args env kont)) + ("letrec" (step-sf-letrec args env kont)) + ("reset" (step-sf-reset args env kont)) + ("shift" (step-sf-shift args env kont)) + ("deref" (step-sf-deref args env kont)) + ("scope" (step-sf-scope args env kont)) + ("provide" (step-sf-provide args env kont)) + ("context" (step-sf-context args env kont)) + ("emit!" (step-sf-emit args env kont)) + ("emitted" (step-sf-emitted args env kont)) + ("handler-bind" (step-sf-handler-bind args env kont)) + ("restart-case" (step-sf-restart-case args env kont)) + ("signal" (step-sf-signal args env kont)) + ("invoke-restart" (step-sf-invoke-restart args env kont)) + ("match" (step-sf-match args env kont)) + ("dynamic-wind" + (make-cek-value (sf-dynamic-wind args env) env kont)) + ("map" (step-ho-map args env kont)) + ("map-indexed" (step-ho-map-indexed args env kont)) + ("filter" (step-ho-filter args env kont)) + ("reduce" (step-ho-reduce args env kont)) + ("some" (step-ho-some args env kont)) + ("every?" (step-ho-every args env kont)) + ("for-each" (step-ho-for-each args env kont)) + (_ + (cond + (has-key? *custom-special-forms* name) + (make-cek-value + ((get *custom-special-forms* name) args env) + env + kont) + (and (env-has? env name) (macro? (env-get env name))) + (let + ((mac (env-get env name))) + (make-cek-state (expand-macro mac args env) env kont)) + (and *render-check* (*render-check* expr env)) + (make-cek-value (*render-fn* expr env) env kont) + :else (step-eval-call head args env kont))))) (step-eval-call head args env kont)))))) (define @@ -1690,96 +1650,102 @@ ((ordered (ho-swap-args ho-type evaled))) (let ((f (first ordered))) - (cond - (= ho-type "map") - (let - ((coll (nth ordered 1))) - (if - (empty? coll) - (make-cek-value (list) env kont) - (continue-with-call - f - (list (first coll)) - env - (list) - (kont-push (make-map-frame f (rest coll) (list) env) kont)))) - (= ho-type "map-indexed") - (let - ((coll (nth ordered 1))) - (if - (empty? coll) - (make-cek-value (list) env kont) - (continue-with-call - f - (list 0 (first coll)) - env - (list) - (kont-push - (make-map-indexed-frame f (rest coll) (list) env) - kont)))) - (= ho-type "filter") - (let - ((coll (nth ordered 1))) - (if - (empty? coll) - (make-cek-value (list) env kont) - (continue-with-call - f - (list (first coll)) - env - (list) - (kont-push - (make-filter-frame f (rest coll) (list) (first coll) env) - kont)))) - (= ho-type "reduce") - (let - ((init (nth ordered 1)) (coll (nth ordered 2))) - (if - (empty? coll) - (make-cek-value init env kont) - (continue-with-call - f - (list init (first coll)) - env - (list) - (kont-push (make-reduce-frame f (rest coll) env) kont)))) - (= ho-type "some") - (let - ((coll (nth ordered 1))) - (if - (empty? coll) - (make-cek-value false env kont) - (continue-with-call - f - (list (first coll)) - env - (list) - (kont-push (make-some-frame f (rest coll) env) kont)))) - (= ho-type "every") - (let - ((coll (nth ordered 1))) - (if - (empty? coll) - (make-cek-value true env kont) - (continue-with-call - f - (list (first coll)) - env - (list) - (kont-push (make-every-frame f (rest coll) env) kont)))) - (= ho-type "for-each") - (let - ((coll (nth ordered 1))) - (if - (empty? coll) - (make-cek-value nil env kont) - (continue-with-call - f - (list (first coll)) - env - (list) - (kont-push (make-for-each-frame f (rest coll) env) kont)))) - :else (error (str "Unknown HO type: " ho-type))))))) + (match + ho-type + ("map" + (let + ((coll (nth ordered 1))) + (if + (empty? coll) + (make-cek-value (list) env kont) + (continue-with-call + f + (list (first coll)) + env + (list) + (kont-push (make-map-frame f (rest coll) (list) env) kont))))) + ("map-indexed" + (let + ((coll (nth ordered 1))) + (if + (empty? coll) + (make-cek-value (list) env kont) + (continue-with-call + f + (list 0 (first coll)) + env + (list) + (kont-push + (make-map-indexed-frame f (rest coll) (list) env) + kont))))) + ("filter" + (let + ((coll (nth ordered 1))) + (if + (empty? coll) + (make-cek-value (list) env kont) + (continue-with-call + f + (list (first coll)) + env + (list) + (kont-push + (make-filter-frame + f + (rest coll) + (list) + (first coll) + env) + kont))))) + ("reduce" + (let + ((init (nth ordered 1)) (coll (nth ordered 2))) + (if + (empty? coll) + (make-cek-value init env kont) + (continue-with-call + f + (list init (first coll)) + env + (list) + (kont-push (make-reduce-frame f (rest coll) env) kont))))) + ("some" + (let + ((coll (nth ordered 1))) + (if + (empty? coll) + (make-cek-value false env kont) + (continue-with-call + f + (list (first coll)) + env + (list) + (kont-push (make-some-frame f (rest coll) env) kont))))) + ("every" + (let + ((coll (nth ordered 1))) + (if + (empty? coll) + (make-cek-value true env kont) + (continue-with-call + f + (list (first coll)) + env + (list) + (kont-push (make-every-frame f (rest coll) env) kont))))) + ("for-each" + (let + ((coll (nth ordered 1))) + (if + (empty? coll) + (make-cek-value nil env kont) + (continue-with-call + f + (list (first coll)) + env + (list) + (kont-push (make-for-each-frame f (rest coll) env) kont))))) + (_ (error (str "Unknown HO type: " ho-type)))))))) (define step-ho-map @@ -1863,553 +1829,564 @@ ((frame (kont-top kont)) (rest-k (kont-pop kont)) (ft (frame-type frame))) - (cond - (= ft "if") - (if - (and value (not (nil? value))) - (make-cek-state (get frame "then") (get frame "env") rest-k) + (match + ft + ("if" (if - (nil? (get frame "else")) - (make-cek-value nil env rest-k) - (make-cek-state (get frame "else") (get frame "env") rest-k))) - (= ft "when") - (if - (and value (not (nil? value))) - (let - ((body (get frame "body")) (fenv (get frame "env"))) + (and value (not (nil? value))) + (make-cek-state (get frame "then") (get frame "env") rest-k) (if - (empty? body) - (make-cek-value nil fenv rest-k) + (nil? (get frame "else")) + (make-cek-value nil env rest-k) + (make-cek-state + (get frame "else") + (get frame "env") + rest-k)))) + ("when" + (if + (and value (not (nil? value))) + (let + ((body (get frame "body")) (fenv (get frame "env"))) (if - (= (len body) 1) - (make-cek-state (first body) fenv rest-k) - (make-cek-state - (first body) - fenv - (kont-push (make-begin-frame (rest body) fenv) rest-k))))) - (make-cek-value nil env rest-k)) - (= ft "begin") - (let - ((remaining (get frame "remaining")) - (fenv (get frame "env"))) - (if - (empty? remaining) - (make-cek-value value fenv rest-k) - (if - (= (len remaining) 1) - (make-cek-state (first remaining) fenv rest-k) - (make-cek-state - (first remaining) - fenv - (kont-push - (make-begin-frame (rest remaining) fenv) - rest-k))))) - (= ft "let") - (let - ((name (get frame "name")) - (remaining (get frame "remaining")) - (body (get frame "body")) - (local (get frame "env"))) - (env-bind! local name value) - (if - (empty? remaining) - (step-sf-begin body local rest-k) - (let - ((next-binding (first remaining)) - (vname - (if - (= (type-of (first next-binding)) "symbol") - (symbol-name (first next-binding)) - (first next-binding)))) - (make-cek-state - (nth next-binding 1) - local - (kont-push - (make-let-frame vname (rest remaining) body local) - rest-k))))) - (= ft "define") - (let - ((name (get frame "name")) - (fenv (get frame "env")) - (has-effects (get frame "has-effects")) - (effect-list (get frame "effect-list"))) - (when - (and (lambda? value) (nil? (lambda-name value))) - (set-lambda-name! value name)) - (env-bind! fenv name value) - (when - has-effects - (let - ((effect-names (if (= (type-of effect-list) "list") (map (fn (e) (if (= (type-of e) "symbol") (symbol-name e) (str e))) effect-list) (list (str effect-list)))) - (effect-anns - (if - (env-has? fenv "*effect-annotations*") - (env-get fenv "*effect-annotations*") - (dict)))) - (dict-set! effect-anns name effect-names) - (env-bind! fenv "*effect-annotations*" effect-anns))) - (make-cek-value value fenv rest-k)) - (= ft "set") - (let - ((name (get frame "name")) (fenv (get frame "env"))) - (env-set! fenv name value) - (make-cek-value value env rest-k)) - (= ft "and") - (if - (not value) - (make-cek-value value env rest-k) - (let - ((remaining (get frame "remaining"))) - (if - (empty? remaining) - (make-cek-value value env rest-k) - (make-cek-state - (first remaining) - (get frame "env") + (empty? body) + (make-cek-value nil fenv rest-k) (if - (= (len remaining) 1) - rest-k - (kont-push - (make-and-frame (rest remaining) (get frame "env")) - rest-k)))))) - (= ft "or") - (if - value - (make-cek-value value env rest-k) - (let - ((remaining (get frame "remaining"))) - (if - (empty? remaining) - (make-cek-value false env rest-k) - (make-cek-state - (first remaining) - (get frame "env") - (if - (= (len remaining) 1) - rest-k - (kont-push - (make-or-frame (rest remaining) (get frame "env")) - rest-k)))))) - (= ft "cond") - (let - ((remaining (get frame "remaining")) - (fenv (get frame "env")) - (scheme? (get frame "scheme"))) - (if - scheme? - (if - value - (make-cek-state (nth (first remaining) 1) fenv rest-k) - (let - ((next-clauses (rest remaining))) - (if - (empty? next-clauses) - (make-cek-value nil fenv rest-k) - (let - ((next-clause (first next-clauses)) - (next-test (first next-clause))) - (if - (is-else-clause? next-test) - (make-cek-state (nth next-clause 1) fenv rest-k) - (make-cek-state - next-test - fenv - (kont-push - (make-cond-frame next-clauses fenv true) - rest-k))))))) - (if - value - (make-cek-state (nth remaining 1) fenv rest-k) - (let - ((next (slice remaining 2))) - (if - (< (len next) 2) - (make-cek-value nil fenv rest-k) - (let - ((next-test (first next))) - (if - (is-else-clause? next-test) - (make-cek-state (nth next 1) fenv rest-k) - (make-cek-state - next-test - fenv - (kont-push - (make-cond-frame next fenv false) - rest-k))))))))) - (= ft "case") - (let - ((match-val (get frame "match-val")) - (remaining (get frame "remaining")) - (fenv (get frame "env"))) - (if - (nil? match-val) - (sf-case-step-loop value remaining fenv rest-k) - (sf-case-step-loop match-val remaining fenv rest-k))) - (= ft "thread") - (let - ((remaining (get frame "remaining")) - (fenv (get frame "env"))) - (if - (empty? remaining) - (make-cek-value value fenv rest-k) - (let - ((form (first remaining)) - (rest-forms (rest remaining)) - (new-kont - (if - (empty? (rest remaining)) - rest-k + (= (len body) 1) + (make-cek-state (first body) fenv rest-k) + (make-cek-state + (first body) + fenv (kont-push - (make-thread-frame (rest remaining) fenv) - rest-k)))) + (make-begin-frame (rest body) fenv) + rest-k))))) + (make-cek-value nil env rest-k))) + ("begin" + (let + ((remaining (get frame "remaining")) + (fenv (get frame "env"))) + (if + (empty? remaining) + (make-cek-value value fenv rest-k) (if - (and - (= (type-of form) "list") - (not (empty? form)) - (= (type-of (first form)) "symbol") - (ho-form-name? (symbol-name (first form)))) - (make-cek-state - (cons - (first form) - (cons (list (quote quote) value) (rest form))) - fenv - new-kont) - (let - ((result (if (= (type-of form) "list") (let ((f (trampoline (eval-expr (first form) fenv))) (rargs (map (fn (a) (trampoline (eval-expr a fenv))) (rest form))) (all-args (cons value rargs))) (cond (and (callable? f) (not (lambda? f))) (apply f all-args) (lambda? f) (trampoline (call-lambda f all-args fenv)) :else (error (str "-> form not callable: " (inspect f))))) (let ((f (trampoline (eval-expr form fenv)))) (cond (and (callable? f) (not (lambda? f))) (f value) (lambda? f) (trampoline (call-lambda f (list value) fenv)) :else (error (str "-> form not callable: " (inspect f)))))))) - (if - (empty? rest-forms) - (make-cek-value result fenv rest-k) - (make-cek-value - result - fenv - (kont-push - (make-thread-frame rest-forms fenv) - rest-k)))))))) - (= ft "arg") - (let - ((f (get frame "f")) - (evaled (get frame "evaled")) - (remaining (get frame "remaining")) - (fenv (get frame "env")) - (raw-args (get frame "raw-args")) - (hname (get frame "head-name"))) - (if - (nil? f) - (do - (when - (and *strict* hname) - (strict-check-args hname (list))) - (if - (empty? remaining) - (continue-with-call value (list) fenv raw-args rest-k) + (= (len remaining) 1) + (make-cek-state (first remaining) fenv rest-k) (make-cek-state (first remaining) fenv (kont-push - (make-arg-frame - value - (list) - (rest remaining) - fenv - raw-args - hname) - rest-k)))) - (let - ((new-evaled (append evaled (list value)))) - (if - (empty? remaining) - (do - (when - (and *strict* hname) - (strict-check-args hname new-evaled)) - (continue-with-call f new-evaled fenv raw-args rest-k)) - (make-cek-state - (first remaining) - fenv - (kont-push - (make-arg-frame - f - new-evaled - (rest remaining) - fenv - raw-args - hname) + (make-begin-frame (rest remaining) fenv) rest-k)))))) - (= ft "dict") - (let - ((remaining (get frame "remaining")) - (results (get frame "results")) - (fenv (get frame "env"))) + ("let" (let - ((last-result (last results)) - (completed - (append - (slice results 0 (dec (len results))) - (list (list (first last-result) value))))) + ((name (get frame "name")) + (remaining (get frame "remaining")) + (body (get frame "body")) + (local (get frame "env"))) + (env-bind! local name value) (if (empty? remaining) + (step-sf-begin body local rest-k) (let - ((d (dict))) - (for-each - (fn (pair) (dict-set! d (first pair) (nth pair 1))) - completed) - (make-cek-value d fenv rest-k)) - (let - ((next-entry (first remaining))) - (make-cek-state - (nth next-entry 1) - fenv - (kont-push - (make-dict-frame - (rest remaining) - (append - completed - (list (list (first next-entry)))) - fenv) - rest-k)))))) - (= ft "ho-setup") - (let - ((ho-type (get frame "ho-type")) - (remaining (get frame "remaining")) - (evaled (append (get frame "evaled") (list value))) - (fenv (get frame "env"))) - (if - (empty? remaining) - (ho-setup-dispatch ho-type evaled fenv rest-k) - (make-cek-state - (first remaining) - fenv - (kont-push - (make-ho-setup-frame ho-type (rest remaining) evaled fenv) - rest-k)))) - (= ft "reset") - (make-cek-value value env rest-k) - (= ft "deref") - (let - ((val value) (fenv (get frame "env"))) - (if - (not (signal? val)) - (make-cek-value val fenv rest-k) - (if - (has-reactive-reset-frame? rest-k) - (reactive-shift-deref val fenv rest-k) - (do - (let - ((ctx (context "sx-reactive" nil))) - (when - ctx - (let - ((dep-list (get ctx "deps")) - (notify-fn (get ctx "notify"))) - (when - (not (contains? dep-list val)) - (append! dep-list val) - (signal-add-sub! val notify-fn))))) - (make-cek-value (signal-value val) fenv rest-k))))) - (= ft "reactive-reset") - (let - ((update-fn (get frame "update-fn")) - (first? (get frame "first-render"))) - (when - (and update-fn (not first?)) - (cek-call update-fn (list value))) - (make-cek-value value env rest-k)) - (= ft "scope") - (let - ((name (get frame "name")) - (remaining (get frame "remaining")) - (fenv (get frame "env"))) - (if - (empty? remaining) - (do (scope-pop! name) (make-cek-value value fenv rest-k)) - (make-cek-state - (first remaining) - fenv - (kont-push - (make-scope-frame name (rest remaining) fenv) - rest-k)))) - (= ft "provide") - (let - ((remaining (get frame "remaining")) - (fenv (get frame "env"))) - (if - (empty? remaining) - (make-cek-value value fenv rest-k) - (make-cek-state - (first remaining) - fenv - (kont-push - (make-provide-frame - (get frame "name") - (get frame "value") - (rest remaining) - fenv) - rest-k)))) - (= ft "scope-acc") - (let - ((remaining (get frame "remaining")) - (fenv (get frame "env"))) - (if - (empty? remaining) - (make-cek-value value fenv rest-k) - (make-cek-state - (first remaining) - fenv - (kont-push - (let - ((new-frame (make-scope-acc-frame (get frame "name") (get frame "value") (rest remaining) fenv))) - (dict-set! new-frame "emitted" (get frame "emitted")) - new-frame) - rest-k)))) - (= ft "map") - (let - ((f (get frame "f")) - (remaining (get frame "remaining")) - (results (get frame "results")) - (indexed (get frame "indexed")) - (fenv (get frame "env"))) - (let - ((new-results (append results (list value)))) - (if - (empty? remaining) - (make-cek-value new-results fenv rest-k) - (let - ((call-args (if indexed (list (len new-results) (first remaining)) (list (first remaining)))) - (next-frame + ((next-binding (first remaining)) + (vname (if - indexed - (make-map-indexed-frame - f - (rest remaining) - new-results - fenv) - (make-map-frame f (rest remaining) new-results fenv)))) - (continue-with-call - f - call-args - fenv - (list) - (kont-push next-frame rest-k)))))) - (= ft "filter") - (let - ((f (get frame "f")) - (remaining (get frame "remaining")) - (results (get frame "results")) - (current-item (get frame "current-item")) - (fenv (get frame "env"))) + (= (type-of (first next-binding)) "symbol") + (symbol-name (first next-binding)) + (first next-binding)))) + (make-cek-state + (nth next-binding 1) + local + (kont-push + (make-let-frame vname (rest remaining) body local) + rest-k)))))) + ("define" (let - ((new-results (if value (append results (list current-item)) results))) - (if - (empty? remaining) - (make-cek-value new-results fenv rest-k) - (continue-with-call - f - (list (first remaining)) - fenv - (list) - (kont-push - (make-filter-frame - f - (rest remaining) - new-results - (first remaining) - fenv) - rest-k))))) - (= ft "reduce") - (let - ((f (get frame "f")) - (remaining (get frame "remaining")) - (fenv (get frame "env"))) - (if - (empty? remaining) - (make-cek-value value fenv rest-k) - (continue-with-call - f - (list value (first remaining)) - fenv - (list) - (kont-push - (make-reduce-frame f (rest remaining) fenv) - rest-k)))) - (= ft "for-each") - (let - ((f (get frame "f")) - (remaining (get frame "remaining")) - (fenv (get frame "env"))) - (if - (empty? remaining) - (make-cek-value nil fenv rest-k) - (continue-with-call - f - (list (first remaining)) - fenv - (list) - (kont-push - (make-for-each-frame f (rest remaining) fenv) - rest-k)))) - (= ft "some") - (let - ((f (get frame "f")) - (remaining (get frame "remaining")) - (fenv (get frame "env"))) - (if - value - (make-cek-value value fenv rest-k) - (if - (empty? remaining) - (make-cek-value false fenv rest-k) - (continue-with-call - f - (list (first remaining)) - fenv - (list) - (kont-push - (make-some-frame f (rest remaining) fenv) - rest-k))))) - (= ft "every") - (let - ((f (get frame "f")) - (remaining (get frame "remaining")) - (fenv (get frame "env"))) + ((name (get frame "name")) + (fenv (get frame "env")) + (has-effects (get frame "has-effects")) + (effect-list (get frame "effect-list"))) + (when + (and (lambda? value) (nil? (lambda-name value))) + (set-lambda-name! value name)) + (env-bind! fenv name value) + (when + has-effects + (let + ((effect-names (map (fn (e) (if (= (type-of e) "symbol") (symbol-name e) e)) effect-list)) + (effect-anns + (if + (env-has? fenv "*effect-annotations*") + (env-get fenv "*effect-annotations*") + (dict)))) + (dict-set! effect-anns name effect-names) + (env-bind! fenv "*effect-annotations*" effect-anns))) + (make-cek-value value fenv rest-k))) + ("set" + (let + ((name (get frame "name")) (fenv (get frame "env"))) + (env-set! fenv name value) + (make-cek-value value env rest-k))) + ("and" (if (not value) - (make-cek-value false fenv rest-k) + (make-cek-value value env rest-k) + (let + ((remaining (get frame "remaining"))) + (if + (empty? remaining) + (make-cek-value value env rest-k) + (make-cek-state + (first remaining) + (get frame "env") + (if + (= (len remaining) 1) + rest-k + (kont-push + (make-and-frame (rest remaining) (get frame "env")) + rest-k))))))) + ("or" + (if + value + (make-cek-value value env rest-k) + (let + ((remaining (get frame "remaining"))) + (if + (empty? remaining) + (make-cek-value false env rest-k) + (make-cek-state + (first remaining) + (get frame "env") + (if + (= (len remaining) 1) + rest-k + (kont-push + (make-or-frame (rest remaining) (get frame "env")) + rest-k))))))) + ("cond" + (let + ((remaining (get frame "remaining")) + (fenv (get frame "env")) + (scheme? (get frame "scheme"))) + (if + scheme? + (if + value + (make-cek-state (nth (first remaining) 1) fenv rest-k) + (let + ((next-clauses (rest remaining))) + (if + (empty? next-clauses) + (make-cek-value nil fenv rest-k) + (let + ((next-clause (first next-clauses)) + (next-test (first next-clause))) + (if + (is-else-clause? next-test) + (make-cek-state (nth next-clause 1) fenv rest-k) + (make-cek-state + next-test + fenv + (kont-push + (make-cond-frame next-clauses fenv true) + rest-k))))))) + (if + value + (make-cek-state (nth remaining 1) fenv rest-k) + (let + ((next (slice remaining 2 (len remaining)))) + (if + (< (len next) 2) + (make-cek-value nil fenv rest-k) + (let + ((next-test (first next))) + (if + (is-else-clause? next-test) + (make-cek-state (nth next 1) fenv rest-k) + (make-cek-state + next-test + fenv + (kont-push + (make-cond-frame next fenv false) + rest-k)))))))))) + ("case" + (let + ((match-val (get frame "match-val")) + (remaining (get frame "remaining")) + (fenv (get frame "env"))) + (if + (nil? match-val) + (sf-case-step-loop value remaining fenv rest-k) + (sf-case-step-loop match-val remaining fenv rest-k)))) + ("thread" + (let + ((remaining (get frame "remaining")) + (fenv (get frame "env"))) (if (empty? remaining) - (make-cek-value true fenv rest-k) + (make-cek-value value fenv rest-k) + (let + ((form (first remaining)) + (rest-forms (rest remaining)) + (new-kont + (if + (empty? (rest remaining)) + rest-k + (kont-push + (make-thread-frame (rest remaining) fenv) + rest-k)))) + (if + (and + (= (type-of form) "list") + (not (empty? form)) + (= (type-of (first form)) "symbol") + (ho-form-name? (symbol-name (first form)))) + (make-cek-state + (cons + (first form) + (cons (list (quote quote) value) (rest form))) + fenv + new-kont) + (let + ((result (thread-insert-arg form value fenv))) + (if + (empty? rest-forms) + (make-cek-value result fenv rest-k) + (make-cek-value + result + fenv + (kont-push + (make-thread-frame rest-forms fenv) + rest-k))))))))) + ("arg" + (let + ((f (get frame "f")) + (evaled (get frame "evaled")) + (remaining (get frame "remaining")) + (fenv (get frame "env")) + (raw-args (get frame "raw-args")) + (hname (get frame "head-name"))) + (if + (nil? f) + (do + (when + (and *strict* hname) + (strict-check-args hname (list))) + (if + (empty? remaining) + (continue-with-call value (list) fenv raw-args rest-k) + (make-cek-state + (first remaining) + fenv + (kont-push + (make-arg-frame + value + (list) + (rest remaining) + fenv + raw-args + hname) + rest-k)))) + (let + ((new-evaled (append evaled (list value)))) + (if + (empty? remaining) + (do + (when + (and *strict* hname) + (strict-check-args hname new-evaled)) + (continue-with-call f new-evaled fenv raw-args rest-k)) + (make-cek-state + (first remaining) + fenv + (kont-push + (make-arg-frame + f + new-evaled + (rest remaining) + fenv + raw-args + hname) + rest-k))))))) + ("dict" + (let + ((remaining (get frame "remaining")) + (results (get frame "results")) + (fenv (get frame "env"))) + (let + ((last-result (last results)) + (completed + (append + (slice results 0 (dec (len results))) + (list (list (first last-result) value))))) + (if + (empty? remaining) + (let + ((d (dict))) + (for-each + (fn (pair) (dict-set! d (first pair) (nth pair 1))) + completed) + (make-cek-value d fenv rest-k)) + (let + ((next-entry (first remaining))) + (make-cek-state + (nth next-entry 1) + fenv + (kont-push + (make-dict-frame + (rest remaining) + (append + completed + (list (list (first next-entry)))) + fenv) + rest-k))))))) + ("ho-setup" + (let + ((ho-type (get frame "ho-type")) + (remaining (get frame "remaining")) + (evaled (append (get frame "evaled") (list value))) + (fenv (get frame "env"))) + (if + (empty? remaining) + (ho-setup-dispatch ho-type evaled fenv rest-k) + (make-cek-state + (first remaining) + fenv + (kont-push + (make-ho-setup-frame + ho-type + (rest remaining) + evaled + fenv) + rest-k))))) + ("reset" (make-cek-value value env rest-k)) + ("deref" + (let + ((val (get frame "value")) (fenv (get frame "env"))) + (if + (not (signal? val)) + (make-cek-value val fenv rest-k) + (if + (has-reactive-reset-frame? rest-k) + (reactive-shift-deref val fenv rest-k) + (do + (let + ((ctx (get-tracking-context))) + (when + ctx + (let + ((dep-list (get ctx "deps")) + (notify-fn (get ctx "notify"))) + (when + (not (contains? dep-list val)) + (append! dep-list val) + (signal-add-sub! val notify-fn))))) + (make-cek-value (signal-value val) fenv rest-k)))))) + ("reactive-reset" + (let + ((update-fn (get frame "update-fn")) + (first? (get frame "first-render"))) + (when + (and update-fn (not first?)) + (cek-call update-fn (list value))) + (make-cek-value value env rest-k))) + ("scope" + (let + ((name (get frame "name")) + (remaining (get frame "remaining")) + (fenv (get frame "env"))) + (if + (empty? remaining) + (do (scope-pop! name) (make-cek-value value fenv rest-k)) + (make-cek-state + (first remaining) + fenv + (kont-push + (make-scope-frame name (rest remaining) fenv) + rest-k))))) + ("provide" + (let + ((remaining (get frame "remaining")) + (fenv (get frame "env"))) + (if + (empty? remaining) + (make-cek-value value fenv rest-k) + (make-cek-state + (first remaining) + fenv + (kont-push + (make-provide-frame + (get frame "name") + (get frame "value") + (rest remaining) + fenv) + rest-k))))) + ("scope-acc" + (let + ((remaining (get frame "remaining")) + (fenv (get frame "env"))) + (if + (empty? remaining) + (make-cek-value value fenv rest-k) + (make-cek-state + (first remaining) + fenv + (kont-push + (let + ((new-frame (make-scope-acc-frame (get frame "name") (rest remaining) fenv))) + (dict-set! new-frame "emitted" (get frame "emitted")) + new-frame) + rest-k))))) + ("map" + (let + ((f (get frame "f")) + (remaining (get frame "remaining")) + (results (get frame "results")) + (indexed (get frame "indexed")) + (fenv (get frame "env"))) + (let + ((new-results (append results (list value)))) + (if + (empty? remaining) + (make-cek-value new-results fenv rest-k) + (let + ((call-args (if indexed (list (len new-results) (first remaining)) (list (first remaining)))) + (next-frame + (if + indexed + (make-map-indexed-frame + f + (rest remaining) + new-results + fenv) + (make-map-frame + f + (rest remaining) + new-results + fenv)))) + (continue-with-call + f + call-args + fenv + (list) + (kont-push next-frame rest-k))))))) + ("filter" + (let + ((f (get frame "f")) + (remaining (get frame "remaining")) + (results (get frame "results")) + (current-item (get frame "current-item")) + (fenv (get frame "env"))) + (let + ((new-results (if value (append results (list current-item)) results))) + (if + (empty? remaining) + (make-cek-value new-results fenv rest-k) + (continue-with-call + f + (list (first remaining)) + fenv + (list) + (kont-push + (make-filter-frame + f + (rest remaining) + new-results + (first remaining) + fenv) + rest-k)))))) + ("reduce" + (let + ((f (get frame "f")) + (remaining (get frame "remaining")) + (fenv (get frame "env"))) + (if + (empty? remaining) + (make-cek-value value fenv rest-k) + (continue-with-call + f + (list value (first remaining)) + fenv + (list) + (kont-push + (make-reduce-frame f (rest remaining) fenv) + rest-k))))) + ("for-each" + (let + ((f (get frame "f")) + (remaining (get frame "remaining")) + (fenv (get frame "env"))) + (if + (empty? remaining) + (make-cek-value nil fenv rest-k) (continue-with-call f (list (first remaining)) fenv (list) (kont-push - (make-every-frame f (rest remaining) fenv) + (make-for-each-frame f (rest remaining) fenv) rest-k))))) - (= ft "handler") - (let - ((remaining (get frame "remaining")) - (fenv (get frame "env"))) - (if - (empty? remaining) - (make-cek-value value fenv rest-k) - (make-cek-state - (first remaining) - fenv - (kont-push - (make-handler-frame - (get frame "f") - (rest remaining) - fenv) - rest-k)))) - (= ft "restart") - (make-cek-value value env rest-k) - (= ft "signal-return") - (let - ((saved-kont (get frame "f"))) - (make-cek-value value (get frame "env") saved-kont)) - (= ft "comp-trace") - (make-cek-value value env rest-k) - :else (error (str "Unknown frame type: " ft)))))))) + ("some" + (let + ((f (get frame "f")) + (remaining (get frame "remaining")) + (fenv (get frame "env"))) + (if + value + (make-cek-value value fenv rest-k) + (if + (empty? remaining) + (make-cek-value false fenv rest-k) + (continue-with-call + f + (list (first remaining)) + fenv + (list) + (kont-push + (make-some-frame f (rest remaining) fenv) + rest-k)))))) + ("every" + (let + ((f (get frame "f")) + (remaining (get frame "remaining")) + (fenv (get frame "env"))) + (if + (not value) + (make-cek-value false fenv rest-k) + (if + (empty? remaining) + (make-cek-value true fenv rest-k) + (continue-with-call + f + (list (first remaining)) + fenv + (list) + (kont-push + (make-every-frame f (rest remaining) fenv) + rest-k)))))) + ("handler" + (let + ((remaining (get frame "remaining")) + (fenv (get frame "env"))) + (if + (empty? remaining) + (make-cek-value value fenv rest-k) + (make-cek-state + (first remaining) + fenv + (kont-push + (make-handler-frame + (get frame "f") + (rest remaining) + fenv) + rest-k))))) + ("restart" (make-cek-value value env rest-k)) + ("signal-return" + (let + ((saved-kont (get frame "saved-kont"))) + (make-cek-value value (get frame "env") saved-kont))) + ("comp-trace" (make-cek-value value env rest-k)) + (_ (error (str "Unknown frame type: " ft))))))))) (define continue-with-call diff --git a/spec/tests/test-canonical.sx b/spec/tests/test-canonical.sx index 7022ba29..7c2caaaa 100644 --- a/spec/tests/test-canonical.sx +++ b/spec/tests/test-canonical.sx @@ -1,91 +1,97 @@ -(test-group +(defsuite "canonical-serialize" - (test "nil" (assert= (canonical-serialize nil) "nil")) - (test + (deftest "nil" (assert= (canonical-serialize nil) "nil")) + (deftest "booleans" (assert= (canonical-serialize true) "true") (assert= (canonical-serialize false) "false")) - (test + (deftest "integers" (assert= (canonical-serialize 0) "0") (assert= (canonical-serialize 42) "42") (assert= (canonical-serialize -7) "-7")) - (test + (deftest "strings" (assert= (canonical-serialize "hello") "\"hello\"") (assert= (canonical-serialize "") "\"\"") (assert= (canonical-serialize "a\"b") "\"a\\\"b\"")) - (test + (deftest "symbols" (assert= (canonical-serialize (quote deref)) "deref") (assert= (canonical-serialize (quote swap!)) "swap!")) - (test + (deftest "keywords" - (assert= (canonical-serialize :class) ":class") - (assert= (canonical-serialize :arity) ":arity")) - (test "empty list" (assert= (canonical-serialize (list)) "()")) - (test "flat list" (assert= (canonical-serialize (list 1 2 3)) "(1 2 3)")) - (test + (assert= (canonical-serialize (make-keyword "class")) ":class") + (assert= (canonical-serialize (make-keyword "arity")) ":arity")) + (deftest "empty list" (assert= (canonical-serialize (list)) "()")) + (deftest + "flat list" + (assert= (canonical-serialize (list 1 2 3)) "(1 2 3)")) + (deftest "nested list" (assert= (canonical-serialize - (list (quote div) :class "flex" (list (quote h2) "title"))) + (list + (quote div) + (make-keyword "class") + "flex" + (list (quote h2) "title"))) "(div :class \"flex\" (h2 \"title\"))")) - (test + (deftest "dict keys sorted" (let - ((d (dict "zebra" 1 "alpha" 2 "middle" 3))) + ((d {:zebra 1 :middle 3 :alpha 2})) (assert= (canonical-serialize d) "{:alpha 2 :middle 3 :zebra 1}"))) - (test + (deftest "dict with nested values" (let - ((d (dict "a" (list 1 2) "b" "hello"))) + ((d {:b "hello" :a (list 1 2)})) (assert= (canonical-serialize d) "{:a (1 2) :b \"hello\"}")))) -(test-group +(defsuite "content-id" - (test + (deftest "same expression same CID" (assert= (content-id (list 1 2 3)) (content-id (list 1 2 3)))) - (test + (deftest "different expression different CID" (assert (not (= (content-id (list 1 2 3)) (content-id (list 1 2 4)))))) - (test + (deftest "CID is a hex string" (let ((cid (content-id 42))) (assert (string? cid)) (assert= (len cid) 64))) - (test + (deftest "short CID is 16 chars" (let ((cid (content-id-short 42))) (assert= (len cid) 16))) - (test + (deftest "short CID is prefix of full CID" (let ((full (content-id 42)) (short (content-id-short 42))) (assert= short (slice full 0 16))))) -(test-group +(defsuite "bytecode-module" - (test + (deftest "make and query" (let - ((m (make-bytecode-module 1 "abc123" (list (quote code) :bytecode (list 1 2 3))))) + ((m (make-bytecode-module 1 "abc123" (list 1 2 3)))) (assert (bytecode-module? m)) (assert= (bytecode-module-version m) 1) (assert= (bytecode-module-source-hash m) "abc123"))) - (test + (deftest "non-module fails predicate" (assert (not (bytecode-module? (list 1 2 3)))) (assert (not (bytecode-module? "hello"))))) -(test-group +(defsuite "provenance" - (test + (deftest "make provenance record" (let - ((p (make-provenance "src-cid" "bc-cid" "compiler-cid" "2026-03-27T00:00:00Z"))) + ((p (make-provenance "src-cid" "bc-cid" "v1" "js"))) (assert= (first p) (quote provenance)) (assert= (nth p 2) "src-cid") (assert= (nth p 4) "bc-cid"))))