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

Use match for value dispatch in evaluator and compiler

Browse Source 
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) <noreply@anthropic.com>
This commit is contained in:
giles
2026-03-29 07:53:16 +00:00
parent 394c86b474
commit 8bba02fbc9
5 changed files with 1399 additions and 1414 deletions
Download Patch File Download Diff File Expand all files Collapse all files

24
hosts/javascript/run_tests.js
View File

@@ -82,6 +82,18 @@ env["env-merge"] = function(a, b) { return Object.assign({}, a, b); };
// Missing primitives referenced by tests // Missing primitives referenced by tests
// primitive? is now in platform.py PRIMITIVES // 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["upcase"] = function(s) { return s.toUpperCase(); };
env["downcase"] = function(s) { return s.toLowerCase(); }; env["downcase"] = function(s) { return s.toLowerCase(); };
env["make-keyword"] = function(name) { return new Sx.Keyword(name); }; 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 // Load compiler + VM from lib/ when running full tests
if (fullBuild) { if (fullBuild) {
const libDir = path.join(projectDir, "lib"); const libDir = path.join(projectDir, "lib");

18
hosts/ocaml/bin/run_tests.ml
View File

@@ -390,6 +390,22 @@ let make_test_env () =
bind "defeffect" (fun _args -> Nil); bind "defeffect" (fun _args -> Nil);
(* --- Primitives for canonical.sx / content tests --- *) (* --- 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 -> bind "contains-char?" (fun args ->
match args with match args with
| [String s; String c] when String.length c = 1 -> | [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)) with e -> Printf.eprintf "Warning: %s: %s\n%!" name (Printexc.to_string e))
end end
in in
(* Content-addressing, serialization *)
load_module "canonical.sx" spec_dir;
(* Render adapter for test-render-html.sx *) (* Render adapter for test-render-html.sx *)
load_module "render.sx" spec_dir; load_module "render.sx" spec_dir;
load_module "adapter-html.sx" web_dir; load_module "adapter-html.sx" web_dir;

1112
lib/compiler.sx
View File

File diff suppressed because it is too large Load Diff

369
spec/evaluator.sx
View File

@@ -306,34 +306,27 @@
value-matches-type? value-matches-type?
(fn (fn
(val expected-type) (val expected-type)
(cond (match
(= expected-type "any") expected-type
true ("any" true)
(= expected-type "number") ("number" (number? val))
(number? val) ("string" (string? val))
(= expected-type "string") ("boolean" (boolean? val))
(string? val) ("nil" (nil? val))
(= expected-type "boolean") ("list" (list? val))
(boolean? val) ("dict" (dict? val))
(= expected-type "nil") ("lambda" (lambda? val))
(nil? val) ("symbol" (= (type-of val) "symbol"))
(= expected-type "list") ("keyword" (= (type-of val) "keyword"))
(list? val) (_
(= expected-type "dict") (if
(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 "?")) (and (string? expected-type) (ends-with? expected-type "?"))
(or (or
(nil? val) (nil? val)
(value-matches-type? (value-matches-type?
val val
(slice expected-type 0 (- (string-length expected-type) 1)))) (slice expected-type 0 (- (string-length expected-type) 1))))
:else true))) true)))))
(define (define
strict-check-args strict-check-args
@@ -1019,91 +1012,58 @@
(= (type-of head) "symbol") (= (type-of head) "symbol")
(let (let
((name (symbol-name head))) ((name (symbol-name head)))
(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 (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) (has-key? *custom-special-forms* name)
(make-cek-value (make-cek-value
((get *custom-special-forms* name) args env) ((get *custom-special-forms* name) args env)
@@ -1115,7 +1075,7 @@
(make-cek-state (expand-macro mac args env) env kont)) (make-cek-state (expand-macro mac args env) env kont))
(and *render-check* (*render-check* expr env)) (and *render-check* (*render-check* expr env))
(make-cek-value (*render-fn* expr env) env kont) (make-cek-value (*render-fn* expr env) env kont)
:else (step-eval-call head args env kont))) :else (step-eval-call head args env kont)))))
(step-eval-call head args env kont)))))) (step-eval-call head args env kont))))))
(define (define
@@ -1690,8 +1650,9 @@
((ordered (ho-swap-args ho-type evaled))) ((ordered (ho-swap-args ho-type evaled)))
(let (let
((f (first ordered))) ((f (first ordered)))
(cond (match
(= ho-type "map") ho-type
("map"
(let (let
((coll (nth ordered 1))) ((coll (nth ordered 1)))
(if (if
@@ -1702,8 +1663,8 @@
(list (first coll)) (list (first coll))
env env
(list) (list)
(kont-push (make-map-frame f (rest coll) (list) env) kont)))) (kont-push (make-map-frame f (rest coll) (list) env) kont)))))
(= ho-type "map-indexed") ("map-indexed"
(let (let
((coll (nth ordered 1))) ((coll (nth ordered 1)))
(if (if
@@ -1716,8 +1677,8 @@
(list) (list)
(kont-push (kont-push
(make-map-indexed-frame f (rest coll) (list) env) (make-map-indexed-frame f (rest coll) (list) env)
kont)))) kont)))))
(= ho-type "filter") ("filter"
(let (let
((coll (nth ordered 1))) ((coll (nth ordered 1)))
(if (if
@@ -1729,9 +1690,14 @@
env env
(list) (list)
(kont-push (kont-push
(make-filter-frame f (rest coll) (list) (first coll) env) (make-filter-frame
kont)))) f
(= ho-type "reduce") (rest coll)
(list)
(first coll)
env)
kont)))))
("reduce"
(let (let
((init (nth ordered 1)) (coll (nth ordered 2))) ((init (nth ordered 1)) (coll (nth ordered 2)))
(if (if
@@ -1742,8 +1708,8 @@
(list init (first coll)) (list init (first coll))
env env
(list) (list)
(kont-push (make-reduce-frame f (rest coll) env) kont)))) (kont-push (make-reduce-frame f (rest coll) env) kont)))))
(= ho-type "some") ("some"
(let (let
((coll (nth ordered 1))) ((coll (nth ordered 1)))
(if (if
@@ -1754,8 +1720,8 @@
(list (first coll)) (list (first coll))
env env
(list) (list)
(kont-push (make-some-frame f (rest coll) env) kont)))) (kont-push (make-some-frame f (rest coll) env) kont)))))
(= ho-type "every") ("every"
(let (let
((coll (nth ordered 1))) ((coll (nth ordered 1)))
(if (if
@@ -1766,8 +1732,8 @@
(list (first coll)) (list (first coll))
env env
(list) (list)
(kont-push (make-every-frame f (rest coll) env) kont)))) (kont-push (make-every-frame f (rest coll) env) kont)))))
(= ho-type "for-each") ("for-each"
(let (let
((coll (nth ordered 1))) ((coll (nth ordered 1)))
(if (if
@@ -1778,8 +1744,8 @@
(list (first coll)) (list (first coll))
env env
(list) (list)
(kont-push (make-for-each-frame f (rest coll) env) kont)))) (kont-push (make-for-each-frame f (rest coll) env) kont)))))
:else (error (str "Unknown HO type: " ho-type))))))) (_ (error (str "Unknown HO type: " ho-type))))))))
(define (define
step-ho-map step-ho-map
@@ -1863,16 +1829,20 @@
((frame (kont-top kont)) ((frame (kont-top kont))
(rest-k (kont-pop kont)) (rest-k (kont-pop kont))
(ft (frame-type frame))) (ft (frame-type frame)))
(cond (match
(= ft "if") ft
("if"
(if (if
(and value (not (nil? value))) (and value (not (nil? value)))
(make-cek-state (get frame "then") (get frame "env") rest-k) (make-cek-state (get frame "then") (get frame "env") rest-k)
(if (if
(nil? (get frame "else")) (nil? (get frame "else"))
(make-cek-value nil env rest-k) (make-cek-value nil env rest-k)
(make-cek-state (get frame "else") (get frame "env") rest-k))) (make-cek-state
(= ft "when") (get frame "else")
(get frame "env")
rest-k))))
("when"
(if (if
(and value (not (nil? value))) (and value (not (nil? value)))
(let (let
@@ -1886,9 +1856,11 @@
(make-cek-state (make-cek-state
(first body) (first body)
fenv fenv
(kont-push (make-begin-frame (rest body) fenv) rest-k))))) (kont-push
(make-cek-value nil env rest-k)) (make-begin-frame (rest body) fenv)
(= ft "begin") rest-k)))))
(make-cek-value nil env rest-k)))
("begin"
(let (let
((remaining (get frame "remaining")) ((remaining (get frame "remaining"))
(fenv (get frame "env"))) (fenv (get frame "env")))
@@ -1903,8 +1875,8 @@
fenv fenv
(kont-push (kont-push
(make-begin-frame (rest remaining) fenv) (make-begin-frame (rest remaining) fenv)
rest-k))))) rest-k))))))
(= ft "let") ("let"
(let (let
((name (get frame "name")) ((name (get frame "name"))
(remaining (get frame "remaining")) (remaining (get frame "remaining"))
@@ -1926,8 +1898,8 @@
local local
(kont-push (kont-push
(make-let-frame vname (rest remaining) body local) (make-let-frame vname (rest remaining) body local)
rest-k))))) rest-k))))))
(= ft "define") ("define"
(let (let
((name (get frame "name")) ((name (get frame "name"))
(fenv (get frame "env")) (fenv (get frame "env"))
@@ -1940,7 +1912,7 @@
(when (when
has-effects has-effects
(let (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-names (map (fn (e) (if (= (type-of e) "symbol") (symbol-name e) e)) effect-list))
(effect-anns (effect-anns
(if (if
(env-has? fenv "*effect-annotations*") (env-has? fenv "*effect-annotations*")
@@ -1948,13 +1920,13 @@
(dict)))) (dict))))
(dict-set! effect-anns name effect-names) (dict-set! effect-anns name effect-names)
(env-bind! fenv "*effect-annotations*" effect-anns))) (env-bind! fenv "*effect-annotations*" effect-anns)))
(make-cek-value value fenv rest-k)) (make-cek-value value fenv rest-k)))
(= ft "set") ("set"
(let (let
((name (get frame "name")) (fenv (get frame "env"))) ((name (get frame "name")) (fenv (get frame "env")))
(env-set! fenv name value) (env-set! fenv name value)
(make-cek-value value env rest-k)) (make-cek-value value env rest-k)))
(= ft "and") ("and"
(if (if
(not value) (not value)
(make-cek-value value env rest-k) (make-cek-value value env rest-k)
@@ -1971,8 +1943,8 @@
rest-k rest-k
(kont-push (kont-push
(make-and-frame (rest remaining) (get frame "env")) (make-and-frame (rest remaining) (get frame "env"))
rest-k)))))) rest-k)))))))
(= ft "or") ("or"
(if (if
value value
(make-cek-value value env rest-k) (make-cek-value value env rest-k)
@@ -1989,8 +1961,8 @@
rest-k rest-k
(kont-push (kont-push
(make-or-frame (rest remaining) (get frame "env")) (make-or-frame (rest remaining) (get frame "env"))
rest-k)))))) rest-k)))))))
(= ft "cond") ("cond"
(let (let
((remaining (get frame "remaining")) ((remaining (get frame "remaining"))
(fenv (get frame "env")) (fenv (get frame "env"))
@@ -2021,7 +1993,7 @@
value value
(make-cek-state (nth remaining 1) fenv rest-k) (make-cek-state (nth remaining 1) fenv rest-k)
(let (let
((next (slice remaining 2))) ((next (slice remaining 2 (len remaining))))
(if (if
(< (len next) 2) (< (len next) 2)
(make-cek-value nil fenv rest-k) (make-cek-value nil fenv rest-k)
@@ -2035,8 +2007,8 @@
fenv fenv
(kont-push (kont-push
(make-cond-frame next fenv false) (make-cond-frame next fenv false)
rest-k))))))))) rest-k))))))))))
(= ft "case") ("case"
(let (let
((match-val (get frame "match-val")) ((match-val (get frame "match-val"))
(remaining (get frame "remaining")) (remaining (get frame "remaining"))
@@ -2044,8 +2016,8 @@
(if (if
(nil? match-val) (nil? match-val)
(sf-case-step-loop value remaining fenv rest-k) (sf-case-step-loop value remaining fenv rest-k)
(sf-case-step-loop match-val remaining fenv rest-k))) (sf-case-step-loop match-val remaining fenv rest-k))))
(= ft "thread") ("thread"
(let (let
((remaining (get frame "remaining")) ((remaining (get frame "remaining"))
(fenv (get frame "env"))) (fenv (get frame "env")))
@@ -2075,7 +2047,7 @@
fenv fenv
new-kont) new-kont)
(let (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)))))))) ((result (thread-insert-arg form value fenv)))
(if (if
(empty? rest-forms) (empty? rest-forms)
(make-cek-value result fenv rest-k) (make-cek-value result fenv rest-k)
@@ -2084,8 +2056,8 @@
fenv fenv
(kont-push (kont-push
(make-thread-frame rest-forms fenv) (make-thread-frame rest-forms fenv)
rest-k)))))))) rest-k)))))))))
(= ft "arg") ("arg"
(let (let
((f (get frame "f")) ((f (get frame "f"))
(evaled (get frame "evaled")) (evaled (get frame "evaled"))
@@ -2134,8 +2106,8 @@
fenv fenv
raw-args raw-args
hname) hname)
rest-k)))))) rest-k)))))))
(= ft "dict") ("dict"
(let (let
((remaining (get frame "remaining")) ((remaining (get frame "remaining"))
(results (get frame "results")) (results (get frame "results"))
@@ -2166,8 +2138,8 @@
completed completed
(list (list (first next-entry)))) (list (list (first next-entry))))
fenv) fenv)
rest-k)))))) rest-k)))))))
(= ft "ho-setup") ("ho-setup"
(let (let
((ho-type (get frame "ho-type")) ((ho-type (get frame "ho-type"))
(remaining (get frame "remaining")) (remaining (get frame "remaining"))
@@ -2180,13 +2152,16 @@
(first remaining) (first remaining)
fenv fenv
(kont-push (kont-push
(make-ho-setup-frame ho-type (rest remaining) evaled fenv) (make-ho-setup-frame
rest-k)))) ho-type
(= ft "reset") (rest remaining)
(make-cek-value value env rest-k) evaled
(= ft "deref") fenv)
rest-k)))))
("reset" (make-cek-value value env rest-k))
("deref"
(let (let
((val value) (fenv (get frame "env"))) ((val (get frame "value")) (fenv (get frame "env")))
(if (if
(not (signal? val)) (not (signal? val))
(make-cek-value val fenv rest-k) (make-cek-value val fenv rest-k)
@@ -2195,7 +2170,7 @@
(reactive-shift-deref val fenv rest-k) (reactive-shift-deref val fenv rest-k)
(do (do
(let (let
((ctx (context "sx-reactive" nil))) ((ctx (get-tracking-context)))
(when (when
ctx ctx
(let (let
@@ -2205,16 +2180,16 @@
(not (contains? dep-list val)) (not (contains? dep-list val))
(append! dep-list val) (append! dep-list val)
(signal-add-sub! val notify-fn))))) (signal-add-sub! val notify-fn)))))
(make-cek-value (signal-value val) fenv rest-k))))) (make-cek-value (signal-value val) fenv rest-k))))))
(= ft "reactive-reset") ("reactive-reset"
(let (let
((update-fn (get frame "update-fn")) ((update-fn (get frame "update-fn"))
(first? (get frame "first-render"))) (first? (get frame "first-render")))
(when (when
(and update-fn (not first?)) (and update-fn (not first?))
(cek-call update-fn (list value))) (cek-call update-fn (list value)))
(make-cek-value value env rest-k)) (make-cek-value value env rest-k)))
(= ft "scope") ("scope"
(let (let
((name (get frame "name")) ((name (get frame "name"))
(remaining (get frame "remaining")) (remaining (get frame "remaining"))
@@ -2227,8 +2202,8 @@
fenv fenv
(kont-push (kont-push
(make-scope-frame name (rest remaining) fenv) (make-scope-frame name (rest remaining) fenv)
rest-k)))) rest-k)))))
(= ft "provide") ("provide"
(let (let
((remaining (get frame "remaining")) ((remaining (get frame "remaining"))
(fenv (get frame "env"))) (fenv (get frame "env")))
@@ -2244,8 +2219,8 @@
(get frame "value") (get frame "value")
(rest remaining) (rest remaining)
fenv) fenv)
rest-k)))) rest-k)))))
(= ft "scope-acc") ("scope-acc"
(let (let
((remaining (get frame "remaining")) ((remaining (get frame "remaining"))
(fenv (get frame "env"))) (fenv (get frame "env")))
@@ -2257,11 +2232,11 @@
fenv fenv
(kont-push (kont-push
(let (let
((new-frame (make-scope-acc-frame (get frame "name") (get frame "value") (rest remaining) fenv))) ((new-frame (make-scope-acc-frame (get frame "name") (rest remaining) fenv)))
(dict-set! new-frame "emitted" (get frame "emitted")) (dict-set! new-frame "emitted" (get frame "emitted"))
new-frame) new-frame)
rest-k)))) rest-k)))))
(= ft "map") ("map"
(let (let
((f (get frame "f")) ((f (get frame "f"))
(remaining (get frame "remaining")) (remaining (get frame "remaining"))
@@ -2283,14 +2258,18 @@
(rest remaining) (rest remaining)
new-results new-results
fenv) fenv)
(make-map-frame f (rest remaining) new-results fenv)))) (make-map-frame
f
(rest remaining)
new-results
fenv))))
(continue-with-call (continue-with-call
f f
call-args call-args
fenv fenv
(list) (list)
(kont-push next-frame rest-k)))))) (kont-push next-frame rest-k)))))))
(= ft "filter") ("filter"
(let (let
((f (get frame "f")) ((f (get frame "f"))
(remaining (get frame "remaining")) (remaining (get frame "remaining"))
@@ -2314,8 +2293,8 @@
new-results new-results
(first remaining) (first remaining)
fenv) fenv)
rest-k))))) rest-k))))))
(= ft "reduce") ("reduce"
(let (let
((f (get frame "f")) ((f (get frame "f"))
(remaining (get frame "remaining")) (remaining (get frame "remaining"))
@@ -2330,8 +2309,8 @@
(list) (list)
(kont-push (kont-push
(make-reduce-frame f (rest remaining) fenv) (make-reduce-frame f (rest remaining) fenv)
rest-k)))) rest-k)))))
(= ft "for-each") ("for-each"
(let (let
((f (get frame "f")) ((f (get frame "f"))
(remaining (get frame "remaining")) (remaining (get frame "remaining"))
@@ -2346,8 +2325,8 @@
(list) (list)
(kont-push (kont-push
(make-for-each-frame f (rest remaining) fenv) (make-for-each-frame f (rest remaining) fenv)
rest-k)))) rest-k)))))
(= ft "some") ("some"
(let (let
((f (get frame "f")) ((f (get frame "f"))
(remaining (get frame "remaining")) (remaining (get frame "remaining"))
@@ -2365,8 +2344,8 @@
(list) (list)
(kont-push (kont-push
(make-some-frame f (rest remaining) fenv) (make-some-frame f (rest remaining) fenv)
rest-k))))) rest-k))))))
(= ft "every") ("every"
(let (let
((f (get frame "f")) ((f (get frame "f"))
(remaining (get frame "remaining")) (remaining (get frame "remaining"))
@@ -2384,8 +2363,8 @@
(list) (list)
(kont-push (kont-push
(make-every-frame f (rest remaining) fenv) (make-every-frame f (rest remaining) fenv)
rest-k))))) rest-k))))))
(= ft "handler") ("handler"
(let (let
((remaining (get frame "remaining")) ((remaining (get frame "remaining"))
(fenv (get frame "env"))) (fenv (get frame "env")))
@@ -2400,16 +2379,14 @@
(get frame "f") (get frame "f")
(rest remaining) (rest remaining)
fenv) fenv)
rest-k)))) rest-k)))))
(= ft "restart") ("restart" (make-cek-value value env rest-k))
(make-cek-value value env rest-k) ("signal-return"
(= ft "signal-return")
(let (let
((saved-kont (get frame "f"))) ((saved-kont (get frame "saved-kont")))
(make-cek-value value (get frame "env") saved-kont)) (make-cek-value value (get frame "env") saved-kont)))
(= ft "comp-trace") ("comp-trace" (make-cek-value value env rest-k))
(make-cek-value value env rest-k) (_ (error (str "Unknown frame type: " ft)))))))))
:else (error (str "Unknown frame type: " ft))))))))
(define (define
continue-with-call continue-with-call

66
spec/tests/test-canonical.sx
View File

@@ -1,91 +1,97 @@
(test-group (defsuite
"canonical-serialize" "canonical-serialize"
(test "nil" (assert= (canonical-serialize nil) "nil")) (deftest "nil" (assert= (canonical-serialize nil) "nil"))
(test (deftest
"booleans" "booleans"
(assert= (canonical-serialize true) "true") (assert= (canonical-serialize true) "true")
(assert= (canonical-serialize false) "false")) (assert= (canonical-serialize false) "false"))
(test (deftest
"integers" "integers"
(assert= (canonical-serialize 0) "0") (assert= (canonical-serialize 0) "0")
(assert= (canonical-serialize 42) "42") (assert= (canonical-serialize 42) "42")
(assert= (canonical-serialize -7) "-7")) (assert= (canonical-serialize -7) "-7"))
(test (deftest
"strings" "strings"
(assert= (canonical-serialize "hello") "\"hello\"") (assert= (canonical-serialize "hello") "\"hello\"")
(assert= (canonical-serialize "") "\"\"") (assert= (canonical-serialize "") "\"\"")
(assert= (canonical-serialize "a\"b") "\"a\\\"b\"")) (assert= (canonical-serialize "a\"b") "\"a\\\"b\""))
(test (deftest
"symbols" "symbols"
(assert= (canonical-serialize (quote deref)) "deref") (assert= (canonical-serialize (quote deref)) "deref")
(assert= (canonical-serialize (quote swap!)) "swap!")) (assert= (canonical-serialize (quote swap!)) "swap!"))
(test (deftest
"keywords" "keywords"
(assert= (canonical-serialize :class) ":class") (assert= (canonical-serialize (make-keyword "class")) ":class")
(assert= (canonical-serialize :arity) ":arity")) (assert= (canonical-serialize (make-keyword "arity")) ":arity"))
(test "empty list" (assert= (canonical-serialize (list)) "()")) (deftest "empty list" (assert= (canonical-serialize (list)) "()"))
(test "flat list" (assert= (canonical-serialize (list 1 2 3)) "(1 2 3)")) (deftest
(test "flat list"
(assert= (canonical-serialize (list 1 2 3)) "(1 2 3)"))
(deftest
"nested list" "nested list"
(assert= (assert=
(canonical-serialize (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\"))")) "(div :class \"flex\" (h2 \"title\"))"))
(test (deftest
"dict keys sorted" "dict keys sorted"
(let (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}"))) (assert= (canonical-serialize d) "{:alpha 2 :middle 3 :zebra 1}")))
(test (deftest
"dict with nested values" "dict with nested values"
(let (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\"}")))) (assert= (canonical-serialize d) "{:a (1 2) :b \"hello\"}"))))
(test-group (defsuite
"content-id" "content-id"
(test (deftest
"same expression same CID" "same expression same CID"
(assert= (content-id (list 1 2 3)) (content-id (list 1 2 3)))) (assert= (content-id (list 1 2 3)) (content-id (list 1 2 3))))
(test (deftest
"different expression different CID" "different expression different CID"
(assert (assert
(not (= (content-id (list 1 2 3)) (content-id (list 1 2 4)))))) (not (= (content-id (list 1 2 3)) (content-id (list 1 2 4))))))
(test (deftest
"CID is a hex string" "CID is a hex string"
(let (let
((cid (content-id 42))) ((cid (content-id 42)))
(assert (string? cid)) (assert (string? cid))
(assert= (len cid) 64))) (assert= (len cid) 64)))
(test (deftest
"short CID is 16 chars" "short CID is 16 chars"
(let ((cid (content-id-short 42))) (assert= (len cid) 16))) (let ((cid (content-id-short 42))) (assert= (len cid) 16)))
(test (deftest
"short CID is prefix of full CID" "short CID is prefix of full CID"
(let (let
((full (content-id 42)) (short (content-id-short 42))) ((full (content-id 42)) (short (content-id-short 42)))
(assert= short (slice full 0 16))))) (assert= short (slice full 0 16)))))
(test-group (defsuite
"bytecode-module" "bytecode-module"
(test (deftest
"make and query" "make and query"
(let (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? m))
(assert= (bytecode-module-version m) 1) (assert= (bytecode-module-version m) 1)
(assert= (bytecode-module-source-hash m) "abc123"))) (assert= (bytecode-module-source-hash m) "abc123")))
(test (deftest
"non-module fails predicate" "non-module fails predicate"
(assert (not (bytecode-module? (list 1 2 3)))) (assert (not (bytecode-module? (list 1 2 3))))
(assert (not (bytecode-module? "hello"))))) (assert (not (bytecode-module? "hello")))))
(test-group (defsuite
"provenance" "provenance"
(test (deftest
"make provenance record" "make provenance record"
(let (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= (first p) (quote provenance))
(assert= (nth p 2) "src-cid") (assert= (nth p 2) "src-cid")
(assert= (nth p 4) "bc-cid")))) (assert= (nth p 4) "bc-cid"))))