19 Commits

Author SHA1 Message Date
f7bd3a6bf1 kernel: loop summary — 18 commits, 322 tests, 6 reflective API candidates [proposes-reflective-extraction]
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 42s
Loop closer documenting what 18 feature commits produced. Kernel-on-SX
is 1,398 LoC substrate + 1,747 LoC tests = 3,145 LoC total. Zero
substrate fixes required across the loop. R-1RK core + extras
implemented. Six proposed lib/guest/reflective/ files awaiting second
consumer. Substrate verdict: env-as-value generalises to
evaluator-as-value; the m-eval demo proves it.
2026-05-11 21:28:10 +00:00
d5d77a3611 kernel: type predicates + metacircular demo + map/filter/reduce fix [shapes-reflective]
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 44s
Five type predicates (number?, string?, list?, boolean?, symbol?).
New tests/metacircular.sx: m-eval defined in Kernel walks expressions
itself, recursing on applicative-call args and delegating to host
eval only for operatives and symbol lookup. 14 demo tests.

The demo surfaced a real bug: map/filter/reduce called kernel-combine
on applicative head-vals directly, which re-evaluates already-
evaluated element values; nested-list elements crashed. Fix: extracted
knl-apply-op (unwrap-applicative-or-pass-through) and use it in all
three combinators before kernel-combine. Mirrors apply's approach.

Added knl-apply-op as a proposed entry in the reflective combiner.sx
API. 322 tests total.
2026-05-11 21:27:23 +00:00
67449f5b0c kernel: append + reverse + 11 tests [nothing]
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 33s
Variadic append concatenates lists; reverse is unary. 307 tests total.
2026-05-11 21:19:01 +00:00
6d8f11e093 kernel: apply combinator + 7 tests [shapes-reflective]
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 32s
(apply F (list V1 V2 V3)) ≡ (F V1 V2 V3). Unwrap applicative first to
skip auto-eval (args are values), then kernel-combine with the
underlying operative. Universal pattern in reflective Lisps —
sketched into the combiner.sx API. 296 tests total.
2026-05-11 21:17:24 +00:00
78dab5b28c kernel: map/filter/reduce + with-env applicative constructor + 10 tests [shapes-reflective]
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 27s
Added kernel-make-primitive-applicative-with-env in eval.sx — IMPL
receives (args dyn-env), needed by combinators that re-enter the
evaluator. map/filter/reduce in runtime.sx use it to call user-supplied
combiners on each element with the caller's dynamic env preserved.
Sketched the env-blind vs env-aware applicative split as a new entry
in the proposed combiner.sx reflective API. 289 tests total.
2026-05-11 21:15:54 +00:00
1fb852ef64 kernel: variadic +-*/, chained <>=? + 19 tests [nothing]
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 25s
knl-fold-app for n-ary fold with zero-arity identity and one-arity
special-case (- negates, / inverts). knl-chain-cmp for chained
boolean comparison. 279 tests total.
2026-05-11 21:13:13 +00:00
b80871ac4f kernel: $let* sequential let + multi-body $let + 8 tests [nothing]
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 27s
$let* nests env-extensions one per binding — each binding sees earlier
ones. $let now also accepts multi-expression bodies. 260 tests total.
2026-05-11 21:11:01 +00:00
9ff5d1b464 kernel: $and? / $or? short-circuit + 10 tests [shapes-reflective]
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 26s
Operatives (not applicatives) so untaken args are not evaluated. Empty
$and? = true, empty $or? = false (Kernel identity convention). Returns
last evaluated value, not bool-coerced. Sketched reflective short-
circuit API: identical protocol across reflective Lisps because
operative semantics are forced — an applicative variant defeats the
purpose. 252 tests total.
2026-05-11 21:09:20 +00:00
5fa6c6ecc1 kernel: $cond/$when/$unless + 12 tests [nothing]
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 28s
Standard Kernel control flow. $cond walks clauses in order with `else`
catch-all; clauses past the first match are NOT evaluated. $when/$unless
are simple guards. 12 tests, 242 total.
2026-05-11 21:08:08 +00:00
a4a7753314 kernel: $quasiquote runtime + reflective/quoting.sx sketch [shapes-reflective]
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 26s
kernel-quasiquote-operative walks the template via mutually-recursive
knl-quasi-walk ↔ knl-quasi-walk-list. $unquote forms eval in dyn-env;
$unquote-splicing splices list-valued results. No depth tracking
(nested quasiquotes flatten). 8 new tests, 230 total. Sketched the
universal reflective quoting kit API for the eventual Phase 7 extraction.
2026-05-11 21:06:35 +00:00
af8d10a717 kernel: multi-expression body for $vau/$lambda + 5 tests [nothing]
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 31s
:body slot holds a LIST of forms now (was single expression). New
knl-eval-body in eval.sx evaluates each form in sequence, returning
the last. $vau and $lambda accept (formals env-param body...) /
(formals body...). No $sequence dependency. 223 tests total.
2026-05-11 21:04:19 +00:00
c21eb9d5ad kernel: reader macros + 8 tests (Phase 1 closure) [consumes-lex]
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 44s
Parser now reads 'expr, \`expr, ,expr, ,@expr as the four standard
shorthands. Quote uses existing $quote operative; quasiquote /
unquote / unquote-splicing recognised but not yet expanded at runtime
(left for first consumer to drive). 218 tests total across six suites.
2026-05-11 21:01:01 +00:00
d896685555 kernel: Phase 7 reflective API proposal — partial [proposes-reflective-extraction]
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 32s
Two-consumer rule blocks actual extraction. API surface fully
documented across four candidate files: env.sx (Phase 2), combiner.sx
(Phase 3), evaluator.sx (Phase 4), hygiene.sx (Phase 6). ~25 functions,
~500 LoC estimate when second consumer materialises. Candidates listed
in priority order: metacircular Scheme, CL macro evaluator, Maru.
Loop complete: 210 tests, 7 commits, one feature per commit.
2026-05-11 20:58:41 +00:00
bf7ec55e92 kernel: Phase 6 hygiene — $let + $define-in! + 18 tests [shapes-reflective]
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 29s
Hygiene-by-default was already present: user operatives close over
static-env and bind formals + body $define!s in (extend STATIC-ENV),
caller's env untouched. $let evaluates values in caller env, binds
in fresh child env, runs body there. $define-in! explicitly targets
an env. Full scope-set / frame-stamp hygiene is research-grade
and documented as deferred future work in the reflective API notes.
2026-05-11 20:57:47 +00:00
45789520ce kernel: Phase 5 encapsulations + promise demo + 19 tests [nothing]
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 30s
make-encapsulation-type returns (encapsulator predicate decapsulator).
Fresh empty dict per call as family identity — SX dict reference
equality gives unique per-family opacity. Encap/decap/pred close over
the family marker; foreign values fail both predicate and decap.
Classic promise demo: (force (delay (lambda () (+ 19 23)))) → 42.
2026-05-11 20:54:31 +00:00
b91d8cf72e kernel: Phase 4 standard env + factorial + 49 tests [shapes-reflective]
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 30s
kernel-standard-env extends kernel-base-env with $if/$define!/$sequence/
$quote, reflection (eval/make-environment/get-current-environment),
binary arithmetic, comparison, list/pair, boolean primitives. Headline
test is recursive factorial (5! = 120, 10! = 3628800). Recursive sum,
length, map-add1, closures, curried arithmetic, and a $vau-using-$define!
demo also covered.
2026-05-11 20:50:34 +00:00
0da39de68a kernel: Phase 3 $vau/$lambda/wrap/unwrap + 34 tests [shapes-reflective]
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 27s
User-defined operatives via $vau; applicatives via $lambda (wrap ∘ $vau).
wrap/unwrap as Kernel-level applicatives. kernel-call-operative forks
on :impl (primitive) vs :body (user) tag. kernel-base-env wires the
four combiners + operative?/applicative? predicates. Env-param sentinel
`_` / `#ignore` → :knl-ignore (skip dyn-env bind). Flat parameter list
only; destructuring later. Headline test: custom applicative + custom
operative composed from user code.
2026-05-11 07:43:45 +00:00
7e57e0b215 kernel: Phase 2 evaluator — lookup-and-combine + 36 tests [shapes-reflective]
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 43s
kernel-eval/kernel-combine dispatch on tagged values: operatives see
un-evaluated args + dynamic env; applicatives evaluate args then recurse.
No hardcoded special forms — $if/$quote tested as ordinary operatives
built on the fly. Pure-SX env representation
{:knl-tag :env :bindings DICT :parent P}, surfaced as a candidate
lib/guest/reflective/env.sx API since SX make-env is HTTP-mode only.
2026-05-10 20:50:42 +00:00
cbba642d7f kernel: Phase 1 parser — s-expr reader + 54 tests [consumes-lex]
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 49s
R-1RK lexical syntax: numbers, strings, symbols, #t/#f, (), nested lists,
; comments. Strings wrap as {:knl-string ...} to distinguish from symbols
(bare SX strings). Reader macros deferred to Phase 6 per plan.
Consumes lib/guest/lex.sx character predicates.
2026-05-10 20:42:53 +00:00
17 changed files with 3260 additions and 312 deletions

View File

@@ -1279,7 +1279,7 @@ let run_foundation_tests () =
assert_true "sx_truthy \"\"" (Bool (sx_truthy (String ""))); assert_true "sx_truthy \"\"" (Bool (sx_truthy (String "")));
assert_eq "not truthy nil" (Bool false) (Bool (sx_truthy Nil)); assert_eq "not truthy nil" (Bool false) (Bool (sx_truthy Nil));
assert_eq "not truthy false" (Bool false) (Bool (sx_truthy (Bool false))); assert_eq "not truthy false" (Bool false) (Bool (sx_truthy (Bool false)));
let l = { l_params = ["x"]; l_body = Symbol "x"; l_closure = Sx_types.make_env (); l_name = None; l_compiled = None; l_call_count = 0 } in let l = { l_params = ["x"]; l_body = Symbol "x"; l_closure = Sx_types.make_env (); l_name = None; l_compiled = None } in
assert_true "is_lambda" (Bool (Sx_types.is_lambda (Lambda l))); assert_true "is_lambda" (Bool (Sx_types.is_lambda (Lambda l)));
ignore (Sx_types.set_lambda_name (Lambda l) "my-fn"); ignore (Sx_types.set_lambda_name (Lambda l) "my-fn");
assert_eq "lambda name mutated" (String "my-fn") (lambda_name (Lambda l)) assert_eq "lambda name mutated" (String "my-fn") (lambda_name (Lambda l))

View File

@@ -4109,25 +4109,4 @@ let () =
| k :: v :: rest -> ignore (env_bind child (value_to_string k) v); add_bindings rest | k :: v :: rest -> ignore (env_bind child (value_to_string k) v); add_bindings rest
| [_] -> raise (Eval_error "env-extend: odd number of key-val pairs") in | [_] -> raise (Eval_error "env-extend: odd number of key-val pairs") in
add_bindings pairs; add_bindings pairs;
Env child); Env child)
(* JIT cache control & observability — backed by refs in sx_types.ml to
avoid creating a sx_primitives → sx_vm dependency cycle. sx_vm reads
these refs to decide when to JIT. *)
register "jit-stats" (fun _args ->
let d = Hashtbl.create 8 in
Hashtbl.replace d "threshold" (Number (float_of_int !Sx_types.jit_threshold));
Hashtbl.replace d "compiled" (Number (float_of_int !Sx_types.jit_compiled_count));
Hashtbl.replace d "compile-failed" (Number (float_of_int !Sx_types.jit_skipped_count));
Hashtbl.replace d "below-threshold" (Number (float_of_int !Sx_types.jit_threshold_skipped_count));
Dict d);
register "jit-set-threshold!" (fun args ->
match args with
| [Number n] -> Sx_types.jit_threshold := int_of_float n; Nil
| [Integer n] -> Sx_types.jit_threshold := n; Nil
| _ -> raise (Eval_error "jit-set-threshold!: (n) where n is integer"));
register "jit-reset-counters!" (fun _args ->
Sx_types.jit_compiled_count := 0;
Sx_types.jit_skipped_count := 0;
Sx_types.jit_threshold_skipped_count := 0;
Nil)

View File

@@ -138,7 +138,6 @@ and lambda = {
l_closure : env; l_closure : env;
mutable l_name : string option; mutable l_name : string option;
mutable l_compiled : vm_closure option; (** Lazy JIT cache *) mutable l_compiled : vm_closure option; (** Lazy JIT cache *)
mutable l_call_count : int; (** Tiered-compilation counter — JIT after threshold calls *)
} }
and component = { and component = {
@@ -450,20 +449,7 @@ let make_lambda params body closure =
| List items -> List.map value_to_string items | List items -> List.map value_to_string items
| _ -> value_to_string_list params | _ -> value_to_string_list params
in in
Lambda { l_params = ps; l_body = body; l_closure = unwrap_env_val closure; l_name = None; l_compiled = None; l_call_count = 0 } Lambda { l_params = ps; l_body = body; l_closure = unwrap_env_val closure; l_name = None; l_compiled = None }
(** {1 JIT cache control}
Tiered compilation: only JIT a lambda after it's been called [jit_threshold]
times. This filters out one-shot lambdas (test harness, dynamic eval, REPLs)
so they never enter the JIT cache. Counters are exposed to SX as [(jit-stats)].
These live here (in sx_types) rather than sx_vm so [sx_primitives] can read
them without creating a sx_primitives → sx_vm dependency cycle. *)
let jit_threshold = ref 4
let jit_compiled_count = ref 0
let jit_skipped_count = ref 0
let jit_threshold_skipped_count = ref 0
let make_component name params has_children body closure affinity = let make_component name params has_children body closure affinity =
let n = value_to_string name in let n = value_to_string name in

View File

@@ -57,9 +57,6 @@ let () = Sx_types._convert_vm_suspension := (fun exn ->
let jit_compile_ref : (lambda -> (string, value) Hashtbl.t -> vm_closure option) ref = let jit_compile_ref : (lambda -> (string, value) Hashtbl.t -> vm_closure option) ref =
ref (fun _ _ -> None) ref (fun _ _ -> None)
(* JIT threshold and counters live in Sx_types so primitives can read them
without creating a sx_primitives → sx_vm dependency cycle. *)
(** Sentinel closure indicating JIT compilation was attempted and failed. (** Sentinel closure indicating JIT compilation was attempted and failed.
Prevents retrying compilation on every call. *) Prevents retrying compilation on every call. *)
let jit_failed_sentinel = { let jit_failed_sentinel = {
@@ -367,21 +364,13 @@ and vm_call vm f args =
| None -> | None ->
if l.l_name <> None if l.l_name <> None
then begin then begin
l.l_call_count <- l.l_call_count + 1; l.l_compiled <- Some jit_failed_sentinel;
if l.l_call_count >= !Sx_types.jit_threshold then begin match !jit_compile_ref l vm.globals with
l.l_compiled <- Some jit_failed_sentinel; | Some cl ->
match !jit_compile_ref l vm.globals with l.l_compiled <- Some cl;
| Some cl -> push_closure_frame vm cl args
incr Sx_types.jit_compiled_count; | None ->
l.l_compiled <- Some cl;
push_closure_frame vm cl args
| None ->
incr Sx_types.jit_skipped_count;
push vm (cek_call_or_suspend vm f (List args))
end else begin
incr Sx_types.jit_threshold_skipped_count;
push vm (cek_call_or_suspend vm f (List args)) push vm (cek_call_or_suspend vm f (List args))
end
end end
else else
push vm (cek_call_or_suspend vm f (List args))) push vm (cek_call_or_suspend vm f (List args)))

234
lib/kernel/eval.sx Normal file
View File

@@ -0,0 +1,234 @@
;; lib/kernel/eval.sx — Kernel evaluator.
;;
;; The evaluator is `lookup-and-combine`: there are no hardcoded special
;; forms. Even $if / $define! / $lambda are ordinary operatives bound in
;; the standard environment (Phase 4). This file builds the dispatch
;; machinery and the operative/applicative tagged-value protocol.
;;
;; Tagged values
;; -------------
;; {:knl-tag :env :bindings DICT :parent PARENT-OR-NIL}
;; A first-class Kernel environment. Bindings is a mutable SX dict
;; keyed by symbol name; parent walks up the lookup chain.
;;
;; {:knl-tag :operative :impl FN}
;; Primitive operative. FN receives (args dyn-env) — args are the
;; UN-evaluated argument expressions, dyn-env is the calling env.
;;
;; {:knl-tag :operative :params P :env-param EP :body B :static-env SE}
;; User-defined operative (built by $vau). Same tag; dispatch in
;; kernel-call-operative forks on which keys are present.
;;
;; {:knl-tag :applicative :underlying OP}
;; An applicative wraps an operative. Calls evaluate args first,
;; then forward to the underlying operative.
;;
;; The env-param of a user operative may be the sentinel :knl-ignore,
;; in which case the dynamic env is not bound.
;;
;; Public API
;; (kernel-eval EXPR ENV) — primary entry
;; (kernel-combine COMBINER ARGS DYN-ENV)
;; (kernel-call-operative OP ARGS DYN-ENV)
;; (kernel-bind-params! ENV PARAMS ARGS)
;; (kernel-make-env) / (kernel-extend-env P)
;; (kernel-env-bind! E N V) / (kernel-env-lookup E N)
;; (kernel-env-has? E N) / (kernel-env? V)
;; (kernel-make-primitive-operative IMPL)
;; (kernel-make-primitive-applicative IMPL)
;; (kernel-make-user-operative PARAMS EPARAM BODY STATIC-ENV)
;; (kernel-wrap OP) / (kernel-unwrap APP)
;; (kernel-operative? V) / (kernel-applicative? V) / (kernel-combiner? V)
;;
;; Consumes: lib/kernel/parser.sx (kernel-string?, kernel-string-value)
;; ── Environments — first-class, pure-SX (binding dict + parent) ──
(define kernel-env? (fn (v) (and (dict? v) (= (get v :knl-tag) :env))))
(define kernel-make-env (fn () {:parent nil :knl-tag :env :bindings {}}))
(define kernel-extend-env (fn (parent) {:parent parent :knl-tag :env :bindings {}}))
(define
kernel-env-bind!
(fn (env name val) (dict-set! (get env :bindings) name val) val))
(define
kernel-env-has?
(fn
(env name)
(cond
((nil? env) false)
((not (kernel-env? env)) false)
((dict-has? (get env :bindings) name) true)
(:else (kernel-env-has? (get env :parent) name)))))
(define
kernel-env-lookup
(fn
(env name)
(cond
((nil? env) (error (str "kernel-eval: unbound symbol: " name)))
((not (kernel-env? env))
(error (str "kernel-eval: corrupt env: " env)))
((dict-has? (get env :bindings) name) (get (get env :bindings) name))
(:else (kernel-env-lookup (get env :parent) name)))))
;; ── Tagged-value constructors and predicates ─────────────────────
(define kernel-make-primitive-operative (fn (impl) {:impl impl :knl-tag :operative}))
(define
kernel-make-user-operative
(fn (params eparam body static-env) {:knl-tag :operative :static-env static-env :params params :body body :env-param eparam}))
(define
kernel-operative?
(fn (v) (and (dict? v) (= (get v :knl-tag) :operative))))
(define
kernel-applicative?
(fn (v) (and (dict? v) (= (get v :knl-tag) :applicative))))
(define
kernel-combiner?
(fn (v) (or (kernel-operative? v) (kernel-applicative? v))))
(define
kernel-wrap
(fn
(op)
(cond
((kernel-operative? op) {:knl-tag :applicative :underlying op})
(:else (error "kernel-wrap: argument must be an operative")))))
(define
kernel-unwrap
(fn
(app)
(cond
((kernel-applicative? app) (get app :underlying))
(:else (error "kernel-unwrap: argument must be an applicative")))))
(define
kernel-make-primitive-applicative
(fn
(impl)
(kernel-wrap
(kernel-make-primitive-operative (fn (args dyn-env) (impl args))))))
;; As above, but IMPL receives (args dyn-env). Used by combinators that
;; re-enter the evaluator (map, filter, reduce, apply, eval, ...).
(define kernel-make-primitive-applicative-with-env
(fn (impl)
(kernel-wrap
(kernel-make-primitive-operative
(fn (args dyn-env) (impl args dyn-env))))))
;; ── The evaluator ────────────────────────────────────────────────
(define
kernel-eval
(fn
(expr env)
(cond
((number? expr) expr)
((boolean? expr) expr)
((nil? expr) expr)
((kernel-string? expr) (kernel-string-value expr))
((string? expr) (kernel-env-lookup env expr))
((list? expr)
(cond
((= (length expr) 0) expr)
(:else
(let
((combiner (kernel-eval (first expr) env))
(args (rest expr)))
(kernel-combine combiner args env)))))
(:else (error (str "kernel-eval: unknown form: " expr))))))
(define
kernel-combine
(fn
(combiner args dyn-env)
(cond
((kernel-operative? combiner)
(kernel-call-operative combiner args dyn-env))
((kernel-applicative? combiner)
(kernel-combine
(get combiner :underlying)
(kernel-eval-args args dyn-env)
dyn-env))
(:else (error (str "kernel-eval: not a combiner: " combiner))))))
;; Operatives may be primitive (:impl is a host fn) or user-defined
;; (carry :params / :env-param / :body / :static-env). The dispatch
;; fork is here so kernel-combine stays small.
(define
kernel-call-operative
(fn
(op args dyn-env)
(cond
((dict-has? op :impl) ((get op :impl) args dyn-env))
((dict-has? op :body)
(let
((local (kernel-extend-env (get op :static-env))))
(kernel-bind-params! local (get op :params) args)
(let
((eparam (get op :env-param)))
(when
(not (= eparam :knl-ignore))
(kernel-env-bind! local eparam dyn-env)))
;; :body is a list of forms — evaluate in sequence, return last.
(knl-eval-body (get op :body) local)))
(:else (error "kernel-call-operative: malformed operative")))))
(define knl-eval-body
(fn (forms env)
(cond
((= (length forms) 1) (kernel-eval (first forms) env))
(:else
(begin
(kernel-eval (first forms) env)
(knl-eval-body (rest forms) env))))))
;; Phase 3 supports a flat parameter list only — destructuring later.
(define
kernel-bind-params!
(fn
(env params args)
(cond
((or (nil? params) (= (length params) 0))
(cond
((or (nil? args) (= (length args) 0)) nil)
(:else (error "kernel-call: too many arguments"))))
((or (nil? args) (= (length args) 0))
(error "kernel-call: too few arguments"))
(:else
(begin
(kernel-env-bind! env (first params) (first args))
(kernel-bind-params! env (rest params) (rest args)))))))
(define
kernel-eval-args
(fn
(args env)
(cond
((or (nil? args) (= (length args) 0)) (list))
(:else
(cons
(kernel-eval (first args) env)
(kernel-eval-args (rest args) env))))))
(define
kernel-eval-program
(fn
(forms env)
(cond
((or (nil? forms) (= (length forms) 0)) nil)
((= (length forms) 1) (kernel-eval (first forms) env))
(:else
(begin
(kernel-eval (first forms) env)
(kernel-eval-program (rest forms) env))))))

253
lib/kernel/parser.sx Normal file
View File

@@ -0,0 +1,253 @@
;; lib/kernel/parser.sx — Kernel s-expression reader.
;;
;; Reads R-1RK lexical syntax: numbers, strings, symbols, booleans (#t/#f),
;; the empty list (), nested lists, and ; line comments. Reader macros
;; (' ` , ,@) deferred to Phase 6 per the plan.
;;
;; Public AST shape:
;; number → SX number
;; #t / #f → SX true / false
;; () → SX empty list (Kernel's nil — the empty list)
;; "..." → {:knl-string "..."} wrapped to distinguish from symbols
;; foo → "foo" bare SX string is a Kernel symbol
;; (a b c) → SX list of forms
;;
;; Public API:
;; (kernel-parse SRC) — first form; errors on extra trailing input
;; (kernel-parse-all SRC) — all top-level forms, as SX list
;; (kernel-string? V) — recognise wrapped string literal
;; (kernel-string-value V) — extract the underlying string
;;
;; Consumes: lib/guest/lex.sx (lex-digit?, lex-whitespace?)
(define kernel-string-make (fn (s) {:knl-string s}))
(define
kernel-string?
(fn (v) (and (dict? v) (string? (get v :knl-string)))))
(define kernel-string-value (fn (v) (get v :knl-string)))
;; Atom delimiters: characters that end a symbol or numeric token.
(define
knl-delim?
(fn
(c)
(or
(nil? c)
(lex-whitespace? c)
(= c "(")
(= c ")")
(= c "\"")
(= c ";")
(= c "'")
(= c "`")
(= c ","))))
;; Numeric grammar: [+-]? (digit+ ('.' digit+)? | '.' digit+) ([eE][+-]?digit+)?
(define
knl-numeric?
(fn
(s)
(let
((n (string-length s)))
(cond
((= n 0) false)
(:else
(let
((c0 (substring s 0 1)))
(let
((start (if (or (= c0 "+") (= c0 "-")) 1 0)))
(knl-num-body? s start n))))))))
(define
knl-num-body?
(fn
(s start n)
(cond
((>= start n) false)
((= (substring s start (+ start 1)) ".")
(knl-num-need-digits? s (+ start 1) n false))
((lex-digit? (substring s start (+ start 1)))
(knl-num-int-tail? s (+ start 1) n))
(:else false))))
(define
knl-num-int-tail?
(fn
(s i n)
(cond
((>= i n) true)
((lex-digit? (substring s i (+ i 1)))
(knl-num-int-tail? s (+ i 1) n))
((= (substring s i (+ i 1)) ".")
(knl-num-need-digits? s (+ i 1) n true))
((or (= (substring s i (+ i 1)) "e") (= (substring s i (+ i 1)) "E"))
(knl-num-exp-sign? s (+ i 1) n))
(:else false))))
(define
knl-num-need-digits?
(fn
(s i n had-int)
(cond
((>= i n) had-int)
((lex-digit? (substring s i (+ i 1)))
(knl-num-frac-tail? s (+ i 1) n))
(:else false))))
(define
knl-num-frac-tail?
(fn
(s i n)
(cond
((>= i n) true)
((lex-digit? (substring s i (+ i 1)))
(knl-num-frac-tail? s (+ i 1) n))
((or (= (substring s i (+ i 1)) "e") (= (substring s i (+ i 1)) "E"))
(knl-num-exp-sign? s (+ i 1) n))
(:else false))))
(define
knl-num-exp-sign?
(fn
(s i n)
(cond
((>= i n) false)
((or (= (substring s i (+ i 1)) "+") (= (substring s i (+ i 1)) "-"))
(knl-num-exp-digits? s (+ i 1) n false))
(:else (knl-num-exp-digits? s i n false)))))
(define
knl-num-exp-digits?
(fn
(s i n had)
(cond
((>= i n) had)
((lex-digit? (substring s i (+ i 1)))
(knl-num-exp-digits? s (+ i 1) n true))
(:else false))))
;; Reader: a closure over (src, pos). Exposes :read-form and :read-all.
(define
knl-make-reader
(fn
(src)
(let
((pos 0) (n (string-length src)))
(define
at
(fn () (if (< pos n) (substring src pos (+ pos 1)) nil)))
(define adv (fn () (set! pos (+ pos 1))))
(define
skip-line
(fn () (when (and (at) (not (= (at) "\n"))) (adv) (skip-line))))
(define
skip-ws
(fn
()
(cond
((nil? (at)) nil)
((lex-whitespace? (at)) (do (adv) (skip-ws)))
((= (at) ";") (do (adv) (skip-line) (skip-ws)))
(:else nil))))
(define
read-string-body
(fn
(acc)
(cond
((nil? (at)) (error "kernel-parse: unterminated string"))
((= (at) "\"") (do (adv) acc))
((= (at) "\\")
(do
(adv)
(let
((c (at)))
(when (nil? c) (error "kernel-parse: trailing backslash"))
(adv)
(read-string-body
(str
acc
(cond
((= c "n") "\n")
((= c "t") "\t")
((= c "r") "\r")
((= c "\"") "\"")
((= c "\\") "\\")
(:else c)))))))
(:else
(let ((c (at))) (adv) (read-string-body (str acc c)))))))
(define
read-atom-body
(fn
(acc)
(cond
((knl-delim? (at)) acc)
(:else (let ((c (at))) (adv) (read-atom-body (str acc c)))))))
(define
classify-atom
(fn
(s)
(cond
((= s "#t") true)
((= s "#f") false)
((knl-numeric? s) (string->number s))
(:else s))))
(define
read-form
(fn
()
(skip-ws)
(cond
((nil? (at)) :knl-eof)
((= (at) ")") (error "kernel-parse: unexpected ')'"))
((= (at) "(") (do (adv) (read-list (list))))
((= (at) "\"")
(do (adv) (kernel-string-make (read-string-body ""))))
((= (at) "'")
(do (adv) (list "$quote" (read-form))))
((= (at) "`")
(do (adv) (list "$quasiquote" (read-form))))
((= (at) ",")
(do (adv)
(cond
((= (at) "@")
(do (adv) (list "$unquote-splicing" (read-form))))
(:else (list "$unquote" (read-form))))))
(:else (classify-atom (read-atom-body ""))))))
(define
read-list
(fn
(acc)
(skip-ws)
(cond
((nil? (at)) (error "kernel-parse: unterminated list"))
((= (at) ")") (do (adv) acc))
(:else (read-list (append acc (list (read-form))))))))
(define
read-all
(fn
(acc)
(skip-ws)
(if (nil? (at)) acc (read-all (append acc (list (read-form)))))))
{:read-form read-form :read-all read-all})))
(define
kernel-parse-all
(fn (src) ((get (knl-make-reader src) :read-all) (list))))
(define
kernel-parse
(fn
(src)
(let
((r (knl-make-reader src)))
(let
((form ((get r :read-form))))
(cond
((= form :knl-eof) (error "kernel-parse: empty input"))
(:else
(let
((next ((get r :read-form))))
(if
(= next :knl-eof)
form
(error "kernel-parse: trailing input after first form")))))))))

911
lib/kernel/runtime.sx Normal file
View File

@@ -0,0 +1,911 @@
;; lib/kernel/runtime.sx — the operativeapplicative substrate and the
;; standard Kernel environment.
;;
;; Phase 3 supplied four user-visible combiners ($vau, $lambda, wrap,
;; unwrap). Phase 4 fills out the rest of the R-1RK core: $if, $define!,
;; $sequence, eval, make-environment, get-current-environment, plus
;; arithmetic, equality, list/pair, and boolean primitives — enough to
;; write factorial.
;;
;; The standard env is built by EXTENDING the base env, not replacing
;; it. So `kernel-standard-env` includes everything from `kernel-base-env`.
;;
;; Public API
;; (kernel-base-env) — Phase 3 combiners
;; (kernel-standard-env) — Phase 4 standard environment
(define
knl-eparam-sentinel
(fn
(sym)
(cond
((= sym "_") :knl-ignore)
((= sym "#ignore") :knl-ignore)
(:else sym))))
(define
knl-formals-ok?
(fn
(formals)
(cond
((not (list? formals)) false)
((= (length formals) 0) true)
((string? (first formals)) (knl-formals-ok? (rest formals)))
(:else false))))
;; ── $vau ─────────────────────────────────────────────────────────
(define
kernel-vau-impl
(fn
(args dyn-env)
(cond
((< (length args) 3)
(error "$vau: expects (formals env-param body...)"))
(:else
(let
((formals (first args))
(eparam-raw (nth args 1))
(body-forms (rest (rest args))))
(cond
((not (knl-formals-ok? formals))
(error "$vau: formals must be a list of symbols"))
((not (string? eparam-raw))
(error "$vau: env-param must be a symbol"))
(:else
(kernel-make-user-operative
formals
(knl-eparam-sentinel eparam-raw)
body-forms
dyn-env))))))))
(define
kernel-vau-operative
(kernel-make-primitive-operative kernel-vau-impl))
;; ── $lambda ──────────────────────────────────────────────────────
(define
kernel-lambda-impl
(fn
(args dyn-env)
(cond
((< (length args) 2)
(error "$lambda: expects (formals body...)"))
(:else
(let
((formals (first args)) (body-forms (rest args)))
(cond
((not (knl-formals-ok? formals))
(error "$lambda: formals must be a list of symbols"))
(:else
(kernel-wrap
(kernel-make-user-operative
formals
:knl-ignore
body-forms
dyn-env)))))))))
(define
kernel-lambda-operative
(kernel-make-primitive-operative kernel-lambda-impl))
;; ── wrap / unwrap / predicates ───────────────────────────────────
(define
kernel-wrap-applicative
(kernel-make-primitive-applicative
(fn
(args)
(cond
((not (= (length args) 1))
(error "wrap: expects exactly 1 argument"))
(:else (kernel-wrap (first args)))))))
(define
kernel-unwrap-applicative
(kernel-make-primitive-applicative
(fn
(args)
(cond
((not (= (length args) 1))
(error "unwrap: expects exactly 1 argument"))
(:else (kernel-unwrap (first args)))))))
(define
kernel-operative?-applicative
(kernel-make-primitive-applicative
(fn (args) (kernel-operative? (first args)))))
(define
kernel-applicative?-applicative
(kernel-make-primitive-applicative
(fn (args) (kernel-applicative? (first args)))))
(define
kernel-base-env
(fn
()
(let
((env (kernel-make-env)))
(kernel-env-bind! env "$vau" kernel-vau-operative)
(kernel-env-bind! env "$lambda" kernel-lambda-operative)
(kernel-env-bind! env "wrap" kernel-wrap-applicative)
(kernel-env-bind! env "unwrap" kernel-unwrap-applicative)
(kernel-env-bind! env "operative?" kernel-operative?-applicative)
(kernel-env-bind! env "applicative?" kernel-applicative?-applicative)
env)))
;; ── $if / $define! / $sequence ───────────────────────────────────
(define
kernel-if-operative
(kernel-make-primitive-operative
(fn
(args dyn-env)
(cond
((not (= (length args) 3))
(error "$if: expects (condition then-expr else-expr)"))
(:else
(let
((c (kernel-eval (first args) dyn-env)))
(if
c
(kernel-eval (nth args 1) dyn-env)
(kernel-eval (nth args 2) dyn-env))))))))
(define
kernel-define!-operative
(kernel-make-primitive-operative
(fn
(args dyn-env)
(cond
((not (= (length args) 2))
(error "$define!: expects (name expr)"))
((not (string? (first args)))
(error "$define!: name must be a symbol"))
(:else
(let
((v (kernel-eval (nth args 1) dyn-env)))
(kernel-env-bind! dyn-env (first args) v)
v))))))
(define
kernel-sequence-operative
(kernel-make-primitive-operative
(fn
(args dyn-env)
(cond
((or (nil? args) (= (length args) 0)) nil)
((= (length args) 1) (kernel-eval (first args) dyn-env))
(:else
(begin
(kernel-eval (first args) dyn-env)
((get kernel-sequence-operative :impl) (rest args) dyn-env)))))))
;; ── eval / make-environment / get-current-environment ───────────
(define
kernel-quote-operative
(kernel-make-primitive-operative
(fn
(args dyn-env)
(cond
((not (= (length args) 1)) (error "$quote: expects 1 argument"))
(:else (first args))))))
;; Quasiquote: walks the template, evaluating `$unquote` forms in the
;; dynamic env and splicing `$unquote-splicing` list results.
(define knl-quasi-walk
(fn (form dyn-env)
(cond
((not (list? form)) form)
((= (length form) 0) form)
((and (string? (first form)) (= (first form) "$unquote"))
(cond
((not (= (length form) 2))
(error "$unquote: expects exactly 1 argument"))
(:else (kernel-eval (nth form 1) dyn-env))))
(:else (knl-quasi-walk-list form dyn-env)))))
(define knl-quasi-walk-list
(fn (forms dyn-env)
(cond
((or (nil? forms) (= (length forms) 0)) (list))
(:else
(let ((head (first forms)))
(cond
((and (list? head)
(= (length head) 2)
(string? (first head))
(= (first head) "$unquote-splicing"))
(let ((spliced (kernel-eval (nth head 1) dyn-env)))
(cond
((not (list? spliced))
(error "$unquote-splicing: value must be a list"))
(:else
(knl-list-concat
spliced
(knl-quasi-walk-list (rest forms) dyn-env))))))
(:else
(cons (knl-quasi-walk head dyn-env)
(knl-quasi-walk-list (rest forms) dyn-env)))))))))
(define knl-list-concat
(fn (xs ys)
(cond
((or (nil? xs) (= (length xs) 0)) ys)
(:else (cons (first xs) (knl-list-concat (rest xs) ys))))))
;; $cond — multi-clause branch.
;; ($cond (TEST1 EXPR1 ...) (TEST2 EXPR2 ...) ...)
;; Evaluates each TEST in order; first truthy one runs its EXPRs (in
;; sequence) and returns the last; if no TEST is truthy, returns nil.
;; A clause with TEST = `else` always matches (sugar for $if's default).
(define knl-cond-impl
(fn (clauses dyn-env)
(cond
((or (nil? clauses) (= (length clauses) 0)) nil)
(:else
(let ((clause (first clauses)))
(cond
((not (list? clause))
(error "$cond: each clause must be a list"))
((= (length clause) 0)
(error "$cond: empty clause"))
((and (string? (first clause)) (= (first clause) "else"))
(knl-cond-eval-body (rest clause) dyn-env))
(:else
(let ((test-val (kernel-eval (first clause) dyn-env)))
(cond
(test-val (knl-cond-eval-body (rest clause) dyn-env))
(:else (knl-cond-impl (rest clauses) dyn-env)))))))))))
(define knl-cond-eval-body
(fn (body dyn-env)
(cond
((or (nil? body) (= (length body) 0)) nil)
((= (length body) 1) (kernel-eval (first body) dyn-env))
(:else
(begin
(kernel-eval (first body) dyn-env)
(knl-cond-eval-body (rest body) dyn-env))))))
(define kernel-cond-operative
(kernel-make-primitive-operative
(fn (args dyn-env) (knl-cond-impl args dyn-env))))
;; $when COND BODY... — evaluate body iff COND is truthy; else nil.
(define kernel-when-operative
(kernel-make-primitive-operative
(fn (args dyn-env)
(cond
((< (length args) 1)
(error "$when: expects (cond body...)"))
(:else
(let ((c (kernel-eval (first args) dyn-env)))
(cond
(c (knl-cond-eval-body (rest args) dyn-env))
(:else nil))))))))
;; $and? — short-circuit AND. Operative (not applicative) so untaken
;; clauses are NOT evaluated. Empty $and? returns true (the identity).
(define knl-and?-impl
(fn (args dyn-env)
(cond
((or (nil? args) (= (length args) 0)) true)
((= (length args) 1) (kernel-eval (first args) dyn-env))
(:else
(let ((v (kernel-eval (first args) dyn-env)))
(cond
(v (knl-and?-impl (rest args) dyn-env))
(:else v)))))))
(define kernel-and?-operative
(kernel-make-primitive-operative knl-and?-impl))
;; $or? — short-circuit OR. Operative; untaken clauses NOT evaluated.
;; Empty $or? returns false (the identity).
(define knl-or?-impl
(fn (args dyn-env)
(cond
((or (nil? args) (= (length args) 0)) false)
((= (length args) 1) (kernel-eval (first args) dyn-env))
(:else
(let ((v (kernel-eval (first args) dyn-env)))
(cond
(v v)
(:else (knl-or?-impl (rest args) dyn-env))))))))
(define kernel-or?-operative
(kernel-make-primitive-operative knl-or?-impl))
;; $unless COND BODY... — evaluate body iff COND is falsy; else nil.
(define kernel-unless-operative
(kernel-make-primitive-operative
(fn (args dyn-env)
(cond
((< (length args) 1)
(error "$unless: expects (cond body...)"))
(:else
(let ((c (kernel-eval (first args) dyn-env)))
(cond
(c nil)
(:else (knl-cond-eval-body (rest args) dyn-env)))))))))
(define kernel-quasiquote-operative
(kernel-make-primitive-operative
(fn (args dyn-env)
(cond
((not (= (length args) 1))
(error "$quasiquote: expects exactly 1 argument"))
(:else (knl-quasi-walk (first args) dyn-env))))))
(define
kernel-eval-applicative
(kernel-make-primitive-applicative
(fn
(args)
(cond
((not (= (length args) 2))
(error "eval: expects (expr env)"))
((not (kernel-env? (nth args 1)))
(error "eval: second arg must be a kernel env"))
(:else (kernel-eval (first args) (nth args 1)))))))
(define
kernel-make-environment-applicative
(kernel-make-primitive-applicative
(fn
(args)
(cond
((= (length args) 0) (kernel-make-env))
((= (length args) 1)
(cond
((not (kernel-env? (first args)))
(error "make-environment: parent must be a kernel env"))
(:else (kernel-extend-env (first args)))))
(:else (error "make-environment: 0 or 1 argument"))))))
;; ── arithmetic and comparison (binary; trivial to extend later) ─
(define
kernel-get-current-env-operative
(kernel-make-primitive-operative
(fn
(args dyn-env)
(cond
((not (= (length args) 0))
(error "get-current-environment: expects 0 arguments"))
(:else dyn-env)))))
(define
knl-bin-app
(fn
(name f)
(kernel-make-primitive-applicative
(fn
(args)
(cond
((not (= (length args) 2))
(error (str name ": expects 2 arguments")))
(:else (f (first args) (nth args 1))))))))
;; Variadic left-fold helper. ZERO-RES is the identity (`(+)` → 0);
;; ONE-FN handles single-arg case (`(- x)` negates; `(+ x)` returns x).
(define knl-fold-step
(fn (f acc rest-args)
(cond
((or (nil? rest-args) (= (length rest-args) 0)) acc)
(:else
(knl-fold-step f (f acc (first rest-args)) (rest rest-args))))))
(define knl-fold-app
(fn (name f zero-res one-fn)
(kernel-make-primitive-applicative
(fn (args)
(cond
((= (length args) 0) zero-res)
((= (length args) 1) (one-fn (first args)))
(:else (knl-fold-step f (first args) (rest args))))))))
;; Variadic n-ary chained comparison: `(< 1 2 3)` ≡ `(< 1 2)` AND `(< 2 3)`.
(define knl-chain-step
(fn (cmp prev rest-args)
(cond
((or (nil? rest-args) (= (length rest-args) 0)) true)
(:else
(let ((next (first rest-args)))
(cond
((cmp prev next)
(knl-chain-step cmp next (rest rest-args)))
(:else false)))))))
(define knl-chain-cmp
(fn (name cmp)
(kernel-make-primitive-applicative
(fn (args)
(cond
((< (length args) 2)
(error (str name ": expects at least 2 arguments")))
(:else (knl-chain-step cmp (first args) (rest args))))))))
;; ── list / pair primitives ──────────────────────────────────────
(define
knl-unary-app
(fn
(name f)
(kernel-make-primitive-applicative
(fn
(args)
(cond
((not (= (length args) 1))
(error (str name ": expects 1 argument")))
(:else (f (first args))))))))
(define kernel-cons-applicative (knl-bin-app "cons" (fn (a b) (cons a b))))
(define
kernel-car-applicative
(knl-unary-app
"car"
(fn
(xs)
(cond
((or (nil? xs) (and (list? xs) (= (length xs) 0)))
(error "car: empty list"))
(:else (first xs))))))
(define
kernel-cdr-applicative
(knl-unary-app
"cdr"
(fn
(xs)
(cond
((or (nil? xs) (and (list? xs) (= (length xs) 0)))
(error "cdr: empty list"))
(:else (rest xs))))))
(define
kernel-list-applicative
(kernel-make-primitive-applicative (fn (args) args)))
(define
kernel-length-applicative
(knl-unary-app "length" (fn (xs) (length xs))))
(define
kernel-null?-applicative
(knl-unary-app
"null?"
(fn (v) (or (nil? v) (and (list? v) (= (length v) 0))))))
;; ── boolean / equality ──────────────────────────────────────────
(define
kernel-pair?-applicative
(knl-unary-app
"pair?"
(fn (v) (and (list? v) (> (length v) 0)))))
(define knl-append-step
(fn (xs ys)
(cond
((or (nil? xs) (= (length xs) 0)) ys)
(:else (cons (first xs) (knl-append-step (rest xs) ys))))))
(define knl-all-lists?
(fn (xs)
(cond
((or (nil? xs) (= (length xs) 0)) true)
((list? (first xs)) (knl-all-lists? (rest xs)))
(:else false))))
(define knl-append-all
(fn (lists)
(cond
((or (nil? lists) (= (length lists) 0)) (list))
((= (length lists) 1) (first lists))
(:else
(knl-append-step (first lists)
(knl-append-all (rest lists)))))))
(define kernel-append-applicative
(kernel-make-primitive-applicative
(fn (args)
(cond
((knl-all-lists? args) (knl-append-all args))
(:else (error "append: all arguments must be lists"))))))
(define knl-reverse-step
(fn (xs acc)
(cond
((or (nil? xs) (= (length xs) 0)) acc)
(:else (knl-reverse-step (rest xs) (cons (first xs) acc))))))
(define kernel-reverse-applicative
(knl-unary-app "reverse"
(fn (xs)
(cond
((not (list? xs)) (error "reverse: argument must be a list"))
(:else (knl-reverse-step xs (list)))))))
(define kernel-not-applicative (knl-unary-app "not" (fn (v) (not v))))
;; Type predicates (Kernel-visible). Note `string?` covers BOTH symbols
;; and string-literals in our representation (symbols are bare SX
;; strings); a `kernel-string?` applicative distinguishes the two if
;; needed.
(define kernel-number?-applicative
(knl-unary-app "number?" (fn (v) (number? v))))
(define kernel-string?-applicative
(knl-unary-app "string?" (fn (v) (string? v))))
(define kernel-list?-applicative
(knl-unary-app "list?" (fn (v) (list? v))))
(define kernel-boolean?-applicative
(knl-unary-app "boolean?" (fn (v) (boolean? v))))
(define kernel-symbol?-applicative
(knl-unary-app "symbol?" (fn (v) (string? v))))
(define kernel-eq?-applicative (knl-bin-app "eq?" (fn (a b) (= a b))))
;; ── the standard environment ────────────────────────────────────
(define
kernel-equal?-applicative
(knl-bin-app "equal?" (fn (a b) (= a b))))
;; ── List combinators: map / filter / reduce ─────────────────────
;; These re-enter the evaluator on each element, so they use the
;; with-env applicative constructor.
;; When the combiner is an applicative, we MUST unwrap before calling
;; — otherwise kernel-combine will re-evaluate the already-evaluated
;; element values (and crash if an element is itself a list).
(define knl-apply-op
(fn (combiner)
(cond
((kernel-applicative? combiner) (kernel-unwrap combiner))
(:else combiner))))
(define knl-map-step
(fn (fn-val xs dyn-env)
(let ((op (knl-apply-op fn-val)))
(knl-map-walk op xs dyn-env))))
(define knl-map-walk
(fn (op xs dyn-env)
(cond
((or (nil? xs) (= (length xs) 0)) (list))
(:else
(cons (kernel-combine op (list (first xs)) dyn-env)
(knl-map-walk op (rest xs) dyn-env))))))
(define kernel-map-applicative
(kernel-make-primitive-applicative-with-env
(fn (args dyn-env)
(cond
((not (= (length args) 2))
(error "map: expects (fn list)"))
((not (kernel-combiner? (first args)))
(error "map: first arg must be a combiner"))
((not (list? (nth args 1)))
(error "map: second arg must be a list"))
(:else (knl-map-step (first args) (nth args 1) dyn-env))))))
(define knl-filter-step
(fn (pred xs dyn-env)
(knl-filter-walk (knl-apply-op pred) xs dyn-env)))
(define knl-filter-walk
(fn (op xs dyn-env)
(cond
((or (nil? xs) (= (length xs) 0)) (list))
(:else
(let ((keep? (kernel-combine op (list (first xs)) dyn-env)))
(cond
(keep?
(cons (first xs) (knl-filter-walk op (rest xs) dyn-env)))
(:else (knl-filter-walk op (rest xs) dyn-env))))))))
(define kernel-filter-applicative
(kernel-make-primitive-applicative-with-env
(fn (args dyn-env)
(cond
((not (= (length args) 2))
(error "filter: expects (pred list)"))
((not (kernel-combiner? (first args)))
(error "filter: first arg must be a combiner"))
((not (list? (nth args 1)))
(error "filter: second arg must be a list"))
(:else (knl-filter-step (first args) (nth args 1) dyn-env))))))
(define knl-reduce-step
(fn (fn-val xs acc dyn-env)
(knl-reduce-walk (knl-apply-op fn-val) xs acc dyn-env)))
(define knl-reduce-walk
(fn (op xs acc dyn-env)
(cond
((or (nil? xs) (= (length xs) 0)) acc)
(:else
(knl-reduce-walk
op
(rest xs)
(kernel-combine op (list acc (first xs)) dyn-env)
dyn-env)))))
;; (apply COMBINER ARGS-LIST) — call COMBINER with the elements of
;; ARGS-LIST as arguments. The Kernel canonical use: turn a constructed
;; list of values into a function call. We skip the applicative's
;; auto-eval step (via unwrap) because ARGS-LIST is already values, not
;; expressions; for a bare operative, we pass through directly.
(define kernel-apply-applicative
(kernel-make-primitive-applicative-with-env
(fn (args dyn-env)
(cond
((not (= (length args) 2))
(error "apply: expects (combiner args-list)"))
((not (kernel-combiner? (first args)))
(error "apply: first arg must be a combiner"))
((not (list? (nth args 1)))
(error "apply: second arg must be a list"))
(:else
(let ((op (cond
((kernel-applicative? (first args))
(kernel-unwrap (first args)))
(:else (first args)))))
(kernel-combine op (nth args 1) dyn-env)))))))
(define kernel-reduce-applicative
(kernel-make-primitive-applicative-with-env
(fn (args dyn-env)
(cond
((not (= (length args) 3))
(error "reduce: expects (fn init list)"))
((not (kernel-combiner? (first args)))
(error "reduce: first arg must be a combiner"))
((not (list? (nth args 2)))
(error "reduce: third arg must be a list"))
(:else
(knl-reduce-step (first args) (nth args 2)
(nth args 1) dyn-env))))))
;; ── Encapsulations: Kernel's opaque-type idiom ──────────────────
;;
;; (make-encapsulation-type) → (encapsulator predicate decapsulator)
;;
;; Each call returns three applicatives over a fresh family identity.
;; - (encapsulator V) → an opaque wrapper around V.
;; - (predicate V) → true iff V was wrapped by THIS family.
;; - (decapsulator W) → the inner value; errors on wrong family.
;;
;; Family identity is a fresh empty dict; SX compares dicts by reference,
;; so two `(make-encapsulation-type)` calls return distinct families.
;;
;; Pattern usage (Phase 5 lacks destructuring, so accessors are explicit):
;; ($define! triple (make-encapsulation-type))
;; ($define! wrap-promise (car triple))
;; ($define! promise? (car (cdr triple)))
;; ($define! unwrap-promise (car (cdr (cdr triple))))
(define kernel-make-encap-type-impl
(fn (args)
(cond
((not (= (length args) 0))
(error "make-encapsulation-type: expects 0 arguments"))
(:else
(let ((family {}))
(let ((encap
(kernel-make-primitive-applicative
(fn (vargs)
(cond
((not (= (length vargs) 1))
(error "encapsulator: expects 1 argument"))
(:else
{:knl-tag :encap
:family family
:value (first vargs)})))))
(pred
(kernel-make-primitive-applicative
(fn (vargs)
(cond
((not (= (length vargs) 1))
(error "predicate: expects 1 argument"))
(:else
(let ((v (first vargs)))
(and (dict? v)
(= (get v :knl-tag) :encap)
(= (get v :family) family))))))))
(decap
(kernel-make-primitive-applicative
(fn (vargs)
(cond
((not (= (length vargs) 1))
(error "decapsulator: expects 1 argument"))
(:else
(let ((v (first vargs)))
(cond
((not (and (dict? v)
(= (get v :knl-tag) :encap)))
(error "decapsulator: not an encapsulation"))
((not (= (get v :family) family))
(error "decapsulator: wrong family"))
(:else (get v :value))))))))))
(list encap pred decap)))))))
(define kernel-make-encap-type-applicative
(kernel-make-primitive-applicative kernel-make-encap-type-impl))
;; ── Hygiene: $let, $define-in!, make-environment ────────────────
;;
;; Kernel-on-SX is hygienic *by default* because user-defined operatives
;; (Phase 3) bind their formals + any $define! in a CHILD env extending
;; the operative's static-env, never the dyn-env. The caller's env is
;; only mutated when code explicitly says so (e.g. `(eval expr env-arg)`).
;;
;; Phase 6 adds two helpers that make the property easy to lean on:
;;
;; ($let ((NAME EXPR) ...) BODY)
;; Evaluates each EXPR in the calling env, binds NAME in a fresh
;; child env, evaluates BODY in that child env. NAMES don't leak.
;;
;; ($define-in! ENV NAME EXPR)
;; Binds NAME=value-of-EXPR in the *specified* env, not the dyn-env.
;; Useful for operatives that need to mutate a sandbox env without
;; touching their caller's env.
;;
;; Shutt's full scope-set / frame-stamp hygiene (lifted symbols carrying
;; provenance markers so introduced bindings can shadow without
;; capturing) is research-grade and not implemented here. Notes for
;; `lib/guest/reflective/hygiene.sx` candidate API below the std env.
(define knl-bind-let-vals!
(fn (local bindings dyn-env)
(cond
((or (nil? bindings) (= (length bindings) 0)) nil)
(:else
(let ((b (first bindings)))
(cond
((not (and (list? b) (= (length b) 2)))
(error "$let: each binding must be (name expr)"))
((not (string? (first b)))
(error "$let: binding name must be a symbol"))
(:else
(begin
(kernel-env-bind! local
(first b)
(kernel-eval (nth b 1) dyn-env))
(knl-bind-let-vals! local (rest bindings) dyn-env)))))))))
(define kernel-let-operative
(kernel-make-primitive-operative
(fn (args dyn-env)
(cond
((< (length args) 2)
(error "$let: expects (bindings body...)"))
((not (list? (first args)))
(error "$let: bindings must be a list"))
(:else
(let ((local (kernel-extend-env dyn-env)))
(knl-bind-let-vals! local (first args) dyn-env)
(knl-eval-body (rest args) local)))))))
;; $let* — sequential let. Each binding sees prior names in scope.
;; Implemented by nesting envs one per binding; the body runs in the
;; innermost env, so later bindings shadow earlier ones if names repeat.
(define knl-let*-step
(fn (bindings env body-forms)
(cond
((or (nil? bindings) (= (length bindings) 0))
(knl-eval-body body-forms env))
(:else
(let ((b (first bindings)))
(cond
((not (and (list? b) (= (length b) 2)))
(error "$let*: each binding must be (name expr)"))
((not (string? (first b)))
(error "$let*: binding name must be a symbol"))
(:else
(let ((child (kernel-extend-env env)))
(kernel-env-bind! child
(first b)
(kernel-eval (nth b 1) env))
(knl-let*-step (rest bindings) child body-forms)))))))))
(define kernel-let*-operative
(kernel-make-primitive-operative
(fn (args dyn-env)
(cond
((< (length args) 2)
(error "$let*: expects (bindings body...)"))
((not (list? (first args)))
(error "$let*: bindings must be a list"))
(:else
(knl-let*-step (first args) dyn-env (rest args)))))))
(define kernel-define-in!-operative
(kernel-make-primitive-operative
(fn (args dyn-env)
(cond
((not (= (length args) 3))
(error "$define-in!: expects (env-expr name expr)"))
((not (string? (nth args 1)))
(error "$define-in!: name must be a symbol"))
(:else
(let ((target (kernel-eval (first args) dyn-env)))
(cond
((not (kernel-env? target))
(error "$define-in!: first arg must evaluate to an env"))
(:else
(let ((v (kernel-eval (nth args 2) dyn-env)))
(kernel-env-bind! target (nth args 1) v)
v)))))))))
(define
kernel-standard-env
(fn
()
(let
((env (kernel-base-env)))
(kernel-env-bind! env "$if" kernel-if-operative)
(kernel-env-bind! env "$define!" kernel-define!-operative)
(kernel-env-bind! env "$sequence" kernel-sequence-operative)
(kernel-env-bind! env "$quote" kernel-quote-operative)
(kernel-env-bind! env "$quasiquote" kernel-quasiquote-operative)
(kernel-env-bind! env "$cond" kernel-cond-operative)
(kernel-env-bind! env "$when" kernel-when-operative)
(kernel-env-bind! env "$unless" kernel-unless-operative)
(kernel-env-bind! env "$and?" kernel-and?-operative)
(kernel-env-bind! env "$or?" kernel-or?-operative)
(kernel-env-bind! env "eval" kernel-eval-applicative)
(kernel-env-bind!
env
"make-environment"
kernel-make-environment-applicative)
(kernel-env-bind!
env
"get-current-environment"
kernel-get-current-env-operative)
(kernel-env-bind! env "+"
(knl-fold-app "+" (fn (a b) (+ a b)) 0 (fn (x) x)))
(kernel-env-bind! env "-"
(knl-fold-app "-" (fn (a b) (- a b)) 0 (fn (x) (- 0 x))))
(kernel-env-bind! env "*"
(knl-fold-app "*" (fn (a b) (* a b)) 1 (fn (x) x)))
(kernel-env-bind! env "/"
(knl-fold-app "/" (fn (a b) (/ a b)) 1 (fn (x) (/ 1 x))))
(kernel-env-bind! env "<" (knl-chain-cmp "<" (fn (a b) (< a b))))
(kernel-env-bind! env ">" (knl-chain-cmp ">" (fn (a b) (> a b))))
(kernel-env-bind! env "<=?" (knl-chain-cmp "<=?" (fn (a b) (<= a b))))
(kernel-env-bind! env ">=?" (knl-chain-cmp ">=?" (fn (a b) (>= a b))))
(kernel-env-bind! env "=?" kernel-eq?-applicative)
(kernel-env-bind! env "equal?" kernel-equal?-applicative)
(kernel-env-bind! env "eq?" kernel-eq?-applicative)
(kernel-env-bind! env "cons" kernel-cons-applicative)
(kernel-env-bind! env "car" kernel-car-applicative)
(kernel-env-bind! env "cdr" kernel-cdr-applicative)
(kernel-env-bind! env "list" kernel-list-applicative)
(kernel-env-bind! env "length" kernel-length-applicative)
(kernel-env-bind! env "null?" kernel-null?-applicative)
(kernel-env-bind! env "pair?" kernel-pair?-applicative)
(kernel-env-bind! env "map" kernel-map-applicative)
(kernel-env-bind! env "filter" kernel-filter-applicative)
(kernel-env-bind! env "reduce" kernel-reduce-applicative)
(kernel-env-bind! env "apply" kernel-apply-applicative)
(kernel-env-bind! env "append" kernel-append-applicative)
(kernel-env-bind! env "reverse" kernel-reverse-applicative)
(kernel-env-bind! env "number?" kernel-number?-applicative)
(kernel-env-bind! env "string?" kernel-string?-applicative)
(kernel-env-bind! env "list?" kernel-list?-applicative)
(kernel-env-bind! env "boolean?" kernel-boolean?-applicative)
(kernel-env-bind! env "symbol?" kernel-symbol?-applicative)
(kernel-env-bind! env "not" kernel-not-applicative)
(kernel-env-bind! env "make-encapsulation-type"
kernel-make-encap-type-applicative)
(kernel-env-bind! env "$let" kernel-let-operative)
(kernel-env-bind! env "$let*" kernel-let*-operative)
(kernel-env-bind! env "$define-in!" kernel-define-in!-operative)
env)))

183
lib/kernel/tests/encap.sx Normal file
View File

@@ -0,0 +1,183 @@
;; lib/kernel/tests/encap.sx — exercises make-encapsulation-type.
;;
;; The Phase 5 Kernel idiom: build opaque types whose constructor,
;; predicate, and accessor are all standard Kernel applicatives. The
;; identity is per-call, so two `(make-encapsulation-type)` calls
;; produce non-interchangeable families.
(define ken-test-pass 0)
(define ken-test-fail 0)
(define ken-test-fails (list))
(define
ken-test
(fn
(name actual expected)
(if
(= actual expected)
(set! ken-test-pass (+ ken-test-pass 1))
(begin
(set! ken-test-fail (+ ken-test-fail 1))
(append! ken-test-fails {:name name :actual actual :expected expected})))))
(define ken-eval-in (fn (src env) (kernel-eval (kernel-parse src) env)))
;; A helper that builds a standard env with `encap`/`pred?`/`decap`
;; bound from a single call to make-encapsulation-type.
(define
ken-make-encap-env
(fn
()
(let
((env (kernel-standard-env)))
(ken-eval-in "($define! triple (make-encapsulation-type))" env)
(ken-eval-in "($define! encap (car triple))" env)
(ken-eval-in "($define! pred? (car (cdr triple)))" env)
(ken-eval-in "($define! decap (car (cdr (cdr triple))))" env)
env)))
;; ── construction ────────────────────────────────────────────────
(ken-test
"make: returns 3-element list"
(ken-eval-in "(length (make-encapsulation-type))" (kernel-standard-env))
3)
(ken-test
"make: first is applicative"
(kernel-applicative?
(ken-eval-in "(car (make-encapsulation-type))" (kernel-standard-env)))
true)
(ken-test
"make: second is applicative"
(kernel-applicative?
(ken-eval-in
"(car (cdr (make-encapsulation-type)))"
(kernel-standard-env)))
true)
(ken-test
"make: third is applicative"
(kernel-applicative?
(ken-eval-in
"(car (cdr (cdr (make-encapsulation-type))))"
(kernel-standard-env)))
true)
;; ── round-trip ──────────────────────────────────────────────────
(ken-test
"round-trip: number"
(ken-eval-in "(decap (encap 42))" (ken-make-encap-env))
42)
(ken-test
"round-trip: string"
(ken-eval-in "(decap (encap ($quote hello)))" (ken-make-encap-env))
"hello")
(ken-test
"round-trip: list"
(ken-eval-in "(decap (encap (list 1 2 3)))" (ken-make-encap-env))
(list 1 2 3))
;; ── predicate ───────────────────────────────────────────────────
(ken-test
"pred?: wrapped value"
(ken-eval-in "(pred? (encap 1))" (ken-make-encap-env))
true)
(ken-test
"pred?: raw value"
(ken-eval-in "(pred? 1)" (ken-make-encap-env))
false)
(ken-test
"pred?: raw string"
(ken-eval-in "(pred? ($quote foo))" (ken-make-encap-env))
false)
(ken-test
"pred?: raw list"
(ken-eval-in "(pred? (list))" (ken-make-encap-env))
false)
;; ── opacity: different families are not interchangeable ─────────
(ken-test
"opacity: foreign value rejected by predicate"
(let
((env (kernel-standard-env)))
(ken-eval-in "($define! tA (make-encapsulation-type))" env)
(ken-eval-in "($define! tB (make-encapsulation-type))" env)
(ken-eval-in "($define! encA (car tA))" env)
(ken-eval-in "($define! predB (car (cdr tB)))" env)
(ken-eval-in "(predB (encA 42))" env))
false)
(ken-test
"opacity: decap rejects foreign value"
(let
((env (kernel-standard-env)))
(ken-eval-in "($define! tA (make-encapsulation-type))" env)
(ken-eval-in "($define! tB (make-encapsulation-type))" env)
(ken-eval-in "($define! encA (car tA))" env)
(ken-eval-in "($define! decapB (car (cdr (cdr tB))))" env)
(guard (e (true :raised)) (ken-eval-in "(decapB (encA 42))" env)))
:raised)
(ken-test
"opacity: decap rejects raw value"
(guard
(e (true :raised))
(ken-eval-in "(decap 42)" (ken-make-encap-env)))
:raised)
;; ── promise: classic Kernel encapsulation use case ──────────────
;; A "promise" wraps a thunk to compute on demand and memoises the
;; first result. Built entirely with the standard encap idiom.
(ken-test
"promise: force returns thunk result"
(let
((env (kernel-standard-env)))
(ken-eval-in
"($sequence\n ($define! ptriple (make-encapsulation-type))\n ($define! make-promise (car ptriple))\n ($define! promise? (car (cdr ptriple)))\n ($define! decode-promise (car (cdr (cdr ptriple))))\n ($define! force ($lambda (p) ((decode-promise p))))\n ($define! delay ($lambda (thunk) (make-promise thunk)))\n (force (delay ($lambda () (+ 19 23)))))"
env))
42)
(ken-test
"promise: promise? recognises its own type"
(let
((env (kernel-standard-env)))
(ken-eval-in
"($sequence\n ($define! ptriple (make-encapsulation-type))\n ($define! make-promise (car ptriple))\n ($define! promise? (car (cdr ptriple)))\n (promise? (make-promise ($lambda () 42))))"
env))
true)
(ken-test
"promise: promise? false on plain value"
(let
((env (kernel-standard-env)))
(ken-eval-in
"($sequence\n ($define! ptriple (make-encapsulation-type))\n ($define! promise? (car (cdr ptriple)))\n (promise? 99))"
env))
false)
;; ── independent families don't leak ─────────────────────────────
(ken-test
"two families: distinct identity"
(let
((env (kernel-standard-env)))
(ken-eval-in
"($sequence\n ($define! t1 (make-encapsulation-type))\n ($define! t2 (make-encapsulation-type))\n ($define! enc1 (car t1))\n ($define! pred2 (car (cdr t2)))\n (pred2 (enc1 ($quote stuff))))"
env))
false)
(ken-test
"same family: re-bound shares identity"
(let
((env (kernel-standard-env)))
(ken-eval-in
"($sequence\n ($define! t (make-encapsulation-type))\n ($define! e (car t))\n ($define! p (car (cdr t)))\n ($define! d (car (cdr (cdr t))))\n (list (p (e 7)) (d (e 7))))"
env))
(list true 7))
(define ken-tests-run! (fn () {:total (+ ken-test-pass ken-test-fail) :passed ken-test-pass :failed ken-test-fail :fails ken-test-fails}))

270
lib/kernel/tests/eval.sx Normal file
View File

@@ -0,0 +1,270 @@
;; lib/kernel/tests/eval.sx — exercises lib/kernel/eval.sx.
;;
;; Phase 2 covers literal evaluation, symbol lookup, and combiner
;; dispatch (operative vs applicative). Standard-environment operatives
;; ($if, $define!, $lambda, …) arrive in Phase 4, so tests build a
;; minimal env on the fly and verify the dispatch contract directly.
(define ke-test-pass 0)
(define ke-test-fail 0)
(define ke-test-fails (list))
(define
ke-test
(fn
(name actual expected)
(if
(= actual expected)
(set! ke-test-pass (+ ke-test-pass 1))
(begin
(set! ke-test-fail (+ ke-test-fail 1))
(append! ke-test-fails {:name name :actual actual :expected expected})))))
;; ── helpers ──────────────────────────────────────────────────────
(define ke-eval-src (fn (src env) (kernel-eval (kernel-parse src) env)))
(define
ke-make-test-env
(fn
()
(let
((env (kernel-make-env)))
(kernel-env-bind!
env
"+"
(kernel-make-primitive-applicative
(fn (args) (+ (first args) (nth args 1)))))
(kernel-env-bind!
env
"list"
(kernel-make-primitive-applicative (fn (args) args)))
(kernel-env-bind!
env
"$quote"
(kernel-make-primitive-operative (fn (args dyn-env) (first args))))
(kernel-env-bind!
env
"$if"
(kernel-make-primitive-operative
(fn
(args dyn-env)
(if
(kernel-eval (first args) dyn-env)
(kernel-eval (nth args 1) dyn-env)
(kernel-eval (nth args 2) dyn-env)))))
env)))
;; ── literal evaluation ───────────────────────────────────────────
(ke-test "lit: number" (ke-eval-src "42" (kernel-make-env)) 42)
(ke-test "lit: zero" (ke-eval-src "0" (kernel-make-env)) 0)
(ke-test "lit: float" (ke-eval-src "3.14" (kernel-make-env)) 3.14)
(ke-test "lit: true" (ke-eval-src "#t" (kernel-make-env)) true)
(ke-test "lit: false" (ke-eval-src "#f" (kernel-make-env)) false)
(ke-test "lit: string" (ke-eval-src "\"hello\"" (kernel-make-env)) "hello")
(ke-test "lit: empty list" (ke-eval-src "()" (kernel-make-env)) (list))
;; ── symbol lookup ────────────────────────────────────────────────
(ke-test
"sym: bound to number"
(let
((env (kernel-make-env)))
(kernel-env-bind! env "x" 100)
(ke-eval-src "x" env))
100)
(ke-test
"sym: bound to string"
(let
((env (kernel-make-env)))
(kernel-env-bind! env "name" "kernel")
(ke-eval-src "name" env))
"kernel")
(ke-test
"sym: parent-chain lookup"
(let
((p (kernel-make-env)))
(kernel-env-bind! p "outer" 1)
(let
((c (kernel-extend-env p)))
(kernel-env-bind! c "inner" 2)
(+ (ke-eval-src "outer" c) (ke-eval-src "inner" c))))
3)
(ke-test
"sym: child shadows parent"
(let
((p (kernel-make-env)))
(kernel-env-bind! p "x" 1)
(let
((c (kernel-extend-env p)))
(kernel-env-bind! c "x" 2)
(ke-eval-src "x" c)))
2)
(ke-test
"env-has?: present"
(let
((env (kernel-make-env)))
(kernel-env-bind! env "x" 1)
(kernel-env-has? env "x"))
true)
(ke-test
"env-has?: missing"
(kernel-env-has? (kernel-make-env) "nope")
false)
;; ── tagged-value predicates ─────────────────────────────────────
(ke-test
"tag: operative?"
(kernel-operative? (kernel-make-primitive-operative (fn (a e) nil)))
true)
(ke-test
"tag: applicative?"
(kernel-applicative? (kernel-make-primitive-applicative (fn (a) nil)))
true)
(ke-test
"tag: combiner? operative"
(kernel-combiner? (kernel-make-primitive-operative (fn (a e) nil)))
true)
(ke-test
"tag: combiner? applicative"
(kernel-combiner? (kernel-make-primitive-applicative (fn (a) nil)))
true)
(ke-test "tag: combiner? number" (kernel-combiner? 42) false)
(ke-test "tag: number is not operative" (kernel-operative? 42) false)
;; ── wrap / unwrap ────────────────────────────────────────────────
(ke-test
"wrap+unwrap roundtrip"
(let
((op (kernel-make-primitive-operative (fn (a e) :sentinel))))
(= (kernel-unwrap (kernel-wrap op)) op))
true)
(ke-test
"wrap produces applicative"
(kernel-applicative?
(kernel-wrap (kernel-make-primitive-operative (fn (a e) nil))))
true)
(ke-test
"unwrap of primitive-applicative is operative"
(kernel-operative?
(kernel-unwrap (kernel-make-primitive-applicative (fn (a) nil))))
true)
;; ── combiner dispatch — applicatives evaluate their args ─────────
(ke-test
"applicative: simple call"
(ke-eval-src "(+ 2 3)" (ke-make-test-env))
5)
(ke-test
"applicative: nested"
(ke-eval-src "(+ (+ 1 2) (+ 3 4))" (ke-make-test-env))
10)
(ke-test
"applicative: receives evaluated args"
(let
((env (ke-make-test-env)))
(kernel-env-bind! env "x" 10)
(kernel-env-bind! env "y" 20)
(ke-eval-src "(+ x y)" env))
30)
(ke-test
"applicative: list builds an SX list of values"
(let
((env (ke-make-test-env)))
(kernel-env-bind! env "a" 1)
(kernel-env-bind! env "b" 2)
(ke-eval-src "(list a b 99)" env))
(list 1 2 99))
;; ── combiner dispatch — operatives DO NOT evaluate their args ───
(ke-test
"operative: $quote returns symbol unevaluated"
(ke-eval-src "($quote foo)" (ke-make-test-env))
"foo")
(ke-test
"operative: $quote returns list unevaluated"
(ke-eval-src "($quote (+ 1 2))" (ke-make-test-env))
(list "+" 1 2))
(ke-test
"operative: $if true branch"
(ke-eval-src "($if #t 1 2)" (ke-make-test-env))
1)
(ke-test
"operative: $if false branch"
(ke-eval-src "($if #f 1 2)" (ke-make-test-env))
2)
(ke-test
"operative: $if doesn't eval untaken branch"
(ke-eval-src "($if #t 99 unbound)" (ke-make-test-env))
99)
(ke-test
"operative: $if takes dynamic env for branches"
(let
((env (ke-make-test-env)))
(kernel-env-bind! env "x" 7)
(ke-eval-src "($if #t x 0)" env))
7)
;; ── operative built ON-THE-FLY can inspect raw expressions ──────
(ke-test
"operative: sees raw symbol head"
(let
((env (kernel-make-env)))
(kernel-env-bind!
env
"head"
(kernel-make-primitive-operative (fn (args dyn-env) (first args))))
(ke-eval-src "(head (+ 1 2))" env))
(list "+" 1 2))
(ke-test
"operative: sees dynamic env"
(let
((env (kernel-make-env)))
(kernel-env-bind! env "x" 999)
(kernel-env-bind!
env
"$probe"
(kernel-make-primitive-operative
(fn (args dyn-env) (kernel-env-lookup dyn-env "x"))))
(ke-eval-src "($probe ignored)" env))
999)
;; ── error cases ──────────────────────────────────────────────────
(ke-test
"error: unbound symbol"
(guard
(e (true :raised))
(kernel-eval (kernel-parse "nope") (kernel-make-env)))
:raised)
(ke-test
"error: combine non-combiner"
(guard
(e (true :raised))
(let
((env (kernel-make-env)))
(kernel-env-bind! env "x" 42)
(kernel-eval (kernel-parse "(x 1)") env)))
:raised)
(define ke-tests-run! (fn () {:total (+ ke-test-pass ke-test-fail) :passed ke-test-pass :failed ke-test-fail :fails ke-test-fails}))

220
lib/kernel/tests/hygiene.sx Normal file
View File

@@ -0,0 +1,220 @@
;; lib/kernel/tests/hygiene.sx — exercises Phase 6 hygiene helpers.
;;
;; Kernel-on-SX is hygienic by default: $vau/$lambda close over their
;; static env, and bind their formals (plus any $define!s in the body)
;; in a CHILD env. The caller's env is only mutated when user code
;; explicitly threads the env-param through `eval` or `$define-in!`.
;;
;; These tests verify the property, plus the Phase 6 helpers ($let and
;; $define-in!). Shutt's full scope-set hygiene (lifted symbols with
;; provenance markers) is research-grade and is NOT implemented — see
;; the plan's reflective-API notes for the proposed approach.
(define kh-test-pass 0)
(define kh-test-fail 0)
(define kh-test-fails (list))
(define
kh-test
(fn
(name actual expected)
(if
(= actual expected)
(set! kh-test-pass (+ kh-test-pass 1))
(begin
(set! kh-test-fail (+ kh-test-fail 1))
(append! kh-test-fails {:name name :actual actual :expected expected})))))
(define kh-eval-in (fn (src env) (kernel-eval (kernel-parse src) env)))
;; ── Default hygiene: $define! inside operative body stays local ─
(kh-test
"hygiene: vau body $define! doesn't escape"
(let
((env (kernel-standard-env)))
(kh-eval-in "($define! x 1)" env)
(kh-eval-in
"($define! my-op ($vau () _ ($sequence ($define! x 999) x)))"
env)
(kh-eval-in "(my-op)" env)
(kh-eval-in "x" env))
1)
(kh-test
"hygiene: vau body $define! visible inside body"
(let
((env (kernel-standard-env)))
(kh-eval-in "($define! x 1)" env)
(kh-eval-in
"($define! my-op ($vau () _ ($sequence ($define! x 999) x)))"
env)
(kh-eval-in "(my-op)" env))
999)
(kh-test
"hygiene: lambda body $define! doesn't escape"
(let
((env (kernel-standard-env)))
(kh-eval-in "($define! y 50)" env)
(kh-eval-in "($define! f ($lambda () ($sequence ($define! y 7) y)))" env)
(kh-eval-in "(f)" env)
(kh-eval-in "y" env))
50)
(kh-test
"hygiene: caller's binding visible inside operative"
(let
((env (kernel-standard-env)))
(kh-eval-in "($define! caller-x 88)" env)
(kh-eval-in "($define! my-op ($vau () _ caller-x))" env)
(kh-eval-in "(my-op)" env))
88)
;; ── $let — proper hygienic scoping ──────────────────────────────
(kh-test
"let: returns body value"
(kh-eval-in "($let ((x 5)) (+ x 1))" (kernel-standard-env))
6)
(kh-test
"let: multiple bindings"
(kh-eval-in "($let ((x 3) (y 4)) (+ x y))" (kernel-standard-env))
7)
(kh-test
"let: bindings shadow outer"
(let
((env (kernel-standard-env)))
(kh-eval-in "($define! x 1)" env)
(kh-eval-in "($let ((x 99)) x)" env))
99)
(kh-test
"let: bindings don't leak after"
(let
((env (kernel-standard-env)))
(kh-eval-in "($define! x 1)" env)
(kh-eval-in "($let ((x 99)) x)" env)
(kh-eval-in "x" env))
1)
(kh-test
"let: parallel — RHS sees outer, not inner"
(let
((env (kernel-standard-env)))
(kh-eval-in "($define! x 1)" env)
(kh-eval-in "($let ((x 10) (y x)) y)" env))
1)
(kh-test
"let: nested"
(kh-eval-in "($let ((x 1)) ($let ((y 2)) (+ x y)))" (kernel-standard-env))
3)
(kh-test
"let: error on malformed binding"
(guard
(e (true :raised))
(kh-eval-in "($let ((x)) x)" (kernel-standard-env)))
:raised)
(kh-test
"let: error on non-symbol name"
(guard
(e (true :raised))
(kh-eval-in "($let ((1 2)) 1)" (kernel-standard-env)))
:raised)
;; ── $define-in! — explicit env targeting ────────────────────────
(kh-test
"define-in!: binds in chosen env, not dyn-env"
(let
((env (kernel-standard-env)))
(kh-eval-in "($define! sandbox (make-environment))" env)
(kh-eval-in "($define-in! sandbox z 77)" env)
(kernel-env-has? (kh-eval-in "sandbox" env) "z"))
true)
(kh-test
"define-in!: doesn't pollute caller"
(let
((env (kernel-standard-env)))
(kh-eval-in "($define! sandbox (make-environment))" env)
(kh-eval-in "($define-in! sandbox z 77)" env)
(kernel-env-has? env "z"))
false)
(kh-test
"define-in!: error on non-env target"
(guard
(e (true :raised))
(let
((env (kernel-standard-env)))
(kh-eval-in "($define-in! 42 x 1)" env)))
:raised)
;; ── Closure does NOT see post-definition caller binds ───────────
;; The classic "lexical scope wins over dynamic" test.
(kh-test
"lexical: closure sees its own static env"
(let
((env (kernel-standard-env)))
(kh-eval-in "($define! x 1)" env)
(kh-eval-in "($define! get-x ($lambda () x))" env)
(kh-eval-in "($define! x 999)" env)
(kh-eval-in "(get-x)" env))
999)
(kh-test
"lexical: $let-bound name invisible outside"
(guard
(e (true :raised))
(let
((env (kernel-standard-env)))
(kh-eval-in "($let ((private 42)) private)" env)
(kh-eval-in "private" env)))
:raised)
;; ── Operative + $let: hygiene compose ───────────────────────────
(kh-test
"let-inside-vau: temp doesn't escape body"
(let
((env (kernel-standard-env)))
(kh-eval-in "($define! x 1)" env)
(kh-eval-in "($define! op ($vau () _ ($let ((x 5)) x)))" env)
(kh-eval-in "(op)" env)
(kh-eval-in "x" env))
1)
;; ── $let* — sequential let ──────────────────────────────────────
(kh-test "let*: empty bindings"
(kh-eval-in "($let* () 42)" (kernel-standard-env)) 42)
(kh-test "let*: single binding"
(kh-eval-in "($let* ((x 5)) (+ x 1))" (kernel-standard-env)) 6)
(kh-test "let*: later sees earlier"
(kh-eval-in "($let* ((x 1) (y (+ x 1)) (z (+ y 1))) z)"
(kernel-standard-env)) 3)
(kh-test "let*: bindings don't leak after"
(let ((env (kernel-standard-env)))
(kh-eval-in "($define! x 1)" env)
(kh-eval-in "($let* ((x 99) (y (+ x 1))) y)" env)
(kh-eval-in "x" env)) 1)
(kh-test "let*: same-name later binding shadows earlier"
(kh-eval-in "($let* ((x 1) (x 2)) x)" (kernel-standard-env)) 2)
(kh-test "let*: multi-expression body"
(kh-eval-in "($let* ((x 5)) ($define! double (+ x x)) double)"
(kernel-standard-env)) 10)
(kh-test "let*: error on malformed binding"
(guard (e (true :raised))
(kh-eval-in "($let* ((x)) x)" (kernel-standard-env)))
:raised)
(kh-test "let: multi-body"
(kh-eval-in "($let ((x 5)) ($define! tmp (+ x 1)) tmp)"
(kernel-standard-env)) 6)
(define kh-tests-run! (fn () {:total (+ kh-test-pass kh-test-fail) :passed kh-test-pass :failed kh-test-fail :fails kh-test-fails}))

View File

@@ -0,0 +1,162 @@
;; lib/kernel/tests/metacircular.sx — Kernel-in-Kernel demo.
;;
;; Demonstrates reflective completeness: a Kernel program implements
;; a recognisable subset of Kernel's own evaluation rules and produces
;; matching values for a battery of test programs.
;;
;; This is a SHALLOW metacircular: it dispatches on expression shape
;; itself (numbers, booleans, lists, symbols), recursively meta-evals
;; each argument of an applicative call, and delegates only to the
;; host evaluator for the leaf cases (operatives, symbol lookup). The
;; point is to show that env-as-value, first-class operatives, and
;; first-class evaluators all line up — enough so a Kernel program
;; can itself reason about Kernel programs.
(define kmc-test-pass 0)
(define kmc-test-fail 0)
(define kmc-test-fails (list))
(define
kmc-test
(fn
(name actual expected)
(if
(= actual expected)
(set! kmc-test-pass (+ kmc-test-pass 1))
(begin
(set! kmc-test-fail (+ kmc-test-fail 1))
(append! kmc-test-fails {:name name :actual actual :expected expected})))))
;; Build a Kernel env with m-eval and m-apply defined. The two refer
;; to each other and to standard primitives, so we use the standard
;; env as the static-env for both.
(define
kmc-make-env
(fn
()
(let
((env (kernel-standard-env)))
(kernel-eval
(kernel-parse
"($define! m-eval\n ($lambda (expr env)\n ($cond\n ((number? expr) expr)\n ((boolean? expr) expr)\n ((null? expr) expr)\n ((symbol? expr) (eval expr env))\n ((list? expr)\n ($let ((head-val (m-eval (car expr) env)))\n ($cond\n ((applicative? head-val)\n (apply head-val\n (map ($lambda (a) (m-eval a env)) (cdr expr))))\n (else (eval expr env)))))\n (else expr))))")
env)
env)))
(define
kmc-eval
(fn
(src)
(let
((env (kmc-make-env)))
(kernel-eval
(kernel-parse
(str "(m-eval (quote " src ") (get-current-environment))"))
env))))
;; ── literals self-evaluate via m-eval ──────────────────────────
(kmc-test
"m-eval: integer literal"
(kernel-eval
(kernel-parse "(m-eval 42 (get-current-environment))")
(kmc-make-env))
42)
(kmc-test
"m-eval: boolean true"
(kernel-eval
(kernel-parse "(m-eval #t (get-current-environment))")
(kmc-make-env))
true)
(kmc-test
"m-eval: boolean false"
(kernel-eval
(kernel-parse "(m-eval #f (get-current-environment))")
(kmc-make-env))
false)
(kmc-test
"m-eval: empty list"
(kernel-eval
(kernel-parse "(m-eval () (get-current-environment))")
(kmc-make-env))
(list))
;; ── symbol lookup goes through env ─────────────────────────────
(kmc-test
"m-eval: symbol lookup"
(let
((env (kmc-make-env)))
(kernel-eval (kernel-parse "($define! shared-x 99)") env)
(kernel-eval
(kernel-parse "(m-eval ($quote shared-x) (get-current-environment))")
env))
99)
;; ── applicative calls are dispatched by m-eval recursively ─────
(kmc-test
"m-eval: addition"
(kernel-eval
(kernel-parse "(m-eval ($quote (+ 1 2)) (get-current-environment))")
(kmc-make-env))
3)
(kmc-test
"m-eval: nested arithmetic"
(kernel-eval
(kernel-parse
"(m-eval ($quote (+ (* 2 3) (- 10 4))) (get-current-environment))")
(kmc-make-env))
12)
(kmc-test
"m-eval: variadic +"
(kernel-eval
(kernel-parse "(m-eval ($quote (+ 1 2 3 4 5)) (get-current-environment))")
(kmc-make-env))
15)
(kmc-test
"m-eval: list construction"
(kernel-eval
(kernel-parse "(m-eval ($quote (list 1 2 3)) (get-current-environment))")
(kmc-make-env))
(list 1 2 3))
(kmc-test "m-eval: cons reverse-style"
(kernel-eval
(kernel-parse "(m-eval ($quote (cons 0 (list 1 2))) (get-current-environment))")
(kmc-make-env)) (list 0 1 2))
(kmc-test "m-eval: nested apply"
(kernel-eval
(kernel-parse "(m-eval ($quote (apply + (list 10 20 30))) (get-current-environment))")
(kmc-make-env)) 60)
;; ── operatives delegate to host eval (transparently for the caller) ─
(kmc-test
"m-eval: $if true branch (via delegation)"
(kernel-eval
(kernel-parse "(m-eval ($quote ($if #t 1 2)) (get-current-environment))")
(kmc-make-env))
1)
(kmc-test
"m-eval: $if false branch"
(kernel-eval
(kernel-parse "(m-eval ($quote ($if #f 1 2)) (get-current-environment))")
(kmc-make-env))
2)
;; ── m-eval can call a user-defined lambda ──────────────────────
(kmc-test
"m-eval: user lambda call"
(let
((env (kmc-make-env)))
(kernel-eval (kernel-parse "($define! sq ($lambda (x) (* x x)))") env)
(kernel-eval
(kernel-parse "(m-eval ($quote (sq 7)) (get-current-environment))")
env))
49)
(define kmc-tests-run! (fn () {:total (+ kmc-test-pass kmc-test-fail) :passed kmc-test-pass :failed kmc-test-fail :fails kmc-test-fails}))

158
lib/kernel/tests/parse.sx Normal file
View File

@@ -0,0 +1,158 @@
;; lib/kernel/tests/parse.sx — exercises lib/kernel/parser.sx.
(define knl-test-pass 0)
(define knl-test-fail 0)
(define knl-test-fails (list))
(define
knl-test
(fn
(name actual expected)
(if
(= actual expected)
(set! knl-test-pass (+ knl-test-pass 1))
(begin
(set! knl-test-fail (+ knl-test-fail 1))
(append! knl-test-fails {:name name :actual actual :expected expected})))))
;; ── atoms: numbers ────────────────────────────────────────────────
(knl-test "num: integer" (kernel-parse "42") 42)
(knl-test "num: zero" (kernel-parse "0") 0)
(knl-test "num: negative integer" (kernel-parse "-7") -7)
(knl-test "num: positive sign" (kernel-parse "+5") 5)
(knl-test "num: float" (kernel-parse "3.14") 3.14)
(knl-test "num: negative float" (kernel-parse "-2.5") -2.5)
(knl-test "num: leading dot" (kernel-parse ".5") 0.5)
(knl-test "num: exponent" (kernel-parse "1e3") 1000)
(knl-test "num: exponent with sign" (kernel-parse "2.5e-1") 0.25)
(knl-test "num: capital E exponent" (kernel-parse "1E2") 100)
;; ── atoms: booleans ───────────────────────────────────────────────
(knl-test "bool: true" (kernel-parse "#t") true)
(knl-test "bool: false" (kernel-parse "#f") false)
;; ── atoms: empty list (Kernel nil) ────────────────────────────────
(knl-test "nil: ()" (kernel-parse "()") (list))
(knl-test "nil: (= () (list))" (= (kernel-parse "()") (list)) true)
;; ── atoms: symbols ────────────────────────────────────────────────
(knl-test "sym: word" (kernel-parse "foo") "foo")
(knl-test "sym: hyphenated" (kernel-parse "foo-bar") "foo-bar")
(knl-test "sym: dollar-bang" (kernel-parse "$define!") "$define!")
(knl-test "sym: question" (kernel-parse "null?") "null?")
(knl-test "sym: lt-eq" (kernel-parse "<=") "<=")
(knl-test "sym: bare plus" (kernel-parse "+") "+")
(knl-test "sym: bare minus" (kernel-parse "-") "-")
(knl-test "sym: plus-letter" (kernel-parse "+a") "+a")
(knl-test "sym: arrow" (kernel-parse "->") "->")
(knl-test "sym: dot-prefixed" (kernel-parse ".foo") ".foo")
;; ── atoms: strings ────────────────────────────────────────────────
(knl-test "str: empty" (kernel-string-value (kernel-parse "\"\"")) "")
(knl-test
"str: hello"
(kernel-string-value (kernel-parse "\"hello\""))
"hello")
(knl-test "str: predicate" (kernel-string? (kernel-parse "\"x\"")) true)
(knl-test "str: not symbol" (kernel-string? (kernel-parse "x")) false)
(knl-test
"str: escape newline"
(kernel-string-value (kernel-parse "\"a\\nb\""))
"a\nb")
(knl-test
"str: escape tab"
(kernel-string-value (kernel-parse "\"a\\tb\""))
"a\tb")
(knl-test
"str: escape quote"
(kernel-string-value (kernel-parse "\"a\\\"b\""))
"a\"b")
(knl-test
"str: escape backslash"
(kernel-string-value (kernel-parse "\"a\\\\b\""))
"a\\b")
;; ── lists ─────────────────────────────────────────────────────────
(knl-test "list: flat" (kernel-parse "(a b c)") (list "a" "b" "c"))
(knl-test
"list: nested"
(kernel-parse "(a (b c) d)")
(list "a" (list "b" "c") "d"))
(knl-test
"list: deeply nested"
(kernel-parse "(((x)))")
(list (list (list "x"))))
(knl-test
"list: mixed atoms"
(kernel-parse "(1 #t foo)")
(list 1 true "foo"))
(knl-test
"list: empty inside"
(kernel-parse "(a () b)")
(list "a" (list) "b"))
;; ── whitespace + comments ─────────────────────────────────────────
(knl-test "ws: leading" (kernel-parse " 42") 42)
(knl-test "ws: trailing" (kernel-parse "42 ") 42)
(knl-test "ws: tabs/newlines" (kernel-parse "\n\t 42 \n") 42)
(knl-test "comment: line" (kernel-parse "; nope\n42") 42)
(knl-test "comment: trailing" (kernel-parse "42 ; tail") 42)
(knl-test
"comment: inside list"
(kernel-parse "(a ; mid\n b)")
(list "a" "b"))
;; ── parse-all ─────────────────────────────────────────────────────
(knl-test "all: empty input" (kernel-parse-all "") (list))
(knl-test "all: only whitespace" (kernel-parse-all " ") (list))
(knl-test "all: only comment" (kernel-parse-all "; nope") (list))
(knl-test
"all: three forms"
(kernel-parse-all "1 2 3")
(list 1 2 3))
(knl-test
"all: mixed"
(kernel-parse-all "($if #t 1 2) foo")
(list (list "$if" true 1 2) "foo"))
;; ── classic Kernel programs (smoke) ───────────────────────────────
(knl-test
"klisp: vau form"
(kernel-parse "($vau (x e) e (eval x e))")
(list "$vau" (list "x" "e") "e" (list "eval" "x" "e")))
(knl-test
"klisp: define lambda"
(kernel-parse "($define! sq ($lambda (x) (* x x)))")
(list "$define!" "sq" (list "$lambda" (list "x") (list "*" "x" "x"))))
;; ── round-trip identity for primitive symbols ─────────────────────
(knl-test "identity: $vau" (kernel-parse "$vau") "$vau")
(knl-test "identity: $lambda" (kernel-parse "$lambda") "$lambda")
(knl-test "identity: wrap" (kernel-parse "wrap") "wrap")
(knl-test "identity: unwrap" (kernel-parse "unwrap") "unwrap")
;; ── reader macros ─────────────────────────────────────────────────
(knl-test "reader: 'foo → ($quote foo)"
(kernel-parse "'foo") (list "$quote" "foo"))
(knl-test "reader: '(a b c)"
(kernel-parse "'(a b c)") (list "$quote" (list "a" "b" "c")))
(knl-test "reader: nested quotes"
(kernel-parse "''x")
(list "$quote" (list "$quote" "x")))
(knl-test "reader: ` quasiquote"
(kernel-parse "`x") (list "$quasiquote" "x"))
(knl-test "reader: , unquote"
(kernel-parse ",x") (list "$unquote" "x"))
(knl-test "reader: ,@ unquote-splicing"
(kernel-parse ",@x") (list "$unquote-splicing" "x"))
(knl-test "reader: quasi-mix"
(kernel-parse "`(a ,b ,@c)")
(list "$quasiquote"
(list "a"
(list "$unquote" "b")
(list "$unquote-splicing" "c"))))
(knl-test "reader: quote separates from neighbouring atom"
(kernel-parse "(a 'b c)")
(list "a" (list "$quote" "b") "c"))
(define knl-tests-run! (fn () {:total (+ knl-test-pass knl-test-fail) :passed knl-test-pass :failed knl-test-fail :fails knl-test-fails}))

View File

@@ -0,0 +1,445 @@
;; lib/kernel/tests/standard.sx — exercises the Kernel standard env.
;;
;; Phase 4 tests verify that the standard env is rich enough to run
;; classic Kernel programs: factorial via recursion, list operations,
;; first-class environment manipulation. Each test starts from a fresh
;; standard env via `(kernel-standard-env)`.
(define ks-test-pass 0)
(define ks-test-fail 0)
(define ks-test-fails (list))
(define
ks-test
(fn
(name actual expected)
(if
(= actual expected)
(set! ks-test-pass (+ ks-test-pass 1))
(begin
(set! ks-test-fail (+ ks-test-fail 1))
(append! ks-test-fails {:name name :actual actual :expected expected})))))
(define
ks-eval
(fn (src) (kernel-eval (kernel-parse src) (kernel-standard-env))))
(define ks-eval-in (fn (src env) (kernel-eval (kernel-parse src) env)))
(define
ks-eval-all
(fn (src env) (kernel-eval-program (kernel-parse-all src) env)))
;; ── $if ──────────────────────────────────────────────────────────
(ks-test "if: true branch" (ks-eval "($if #t 1 2)") 1)
(ks-test "if: false branch" (ks-eval "($if #f 1 2)") 2)
(ks-test "if: predicate"
(ks-eval "($if (<=? 1 2) ($quote yes) ($quote no))") "yes")
(ks-test
"if: untaken branch not evaluated"
(ks-eval "($if #t 42 nope)")
42)
;; ── $define! + arithmetic ───────────────────────────────────────
(ks-test
"define!: returns value"
(let ((env (kernel-standard-env))) (ks-eval-in "($define! x 5)" env))
5)
(ks-test
"define!: bound in env"
(let
((env (kernel-standard-env)))
(ks-eval-in "($define! x 5)" env)
(ks-eval-in "x" env))
5)
(ks-test "arith: +" (ks-eval "(+ 2 3)") 5)
(ks-test "arith: -" (ks-eval "(- 10 4)") 6)
(ks-test "arith: *" (ks-eval "(* 6 7)") 42)
(ks-test "arith: /" (ks-eval "(/ 20 5)") 4)
(ks-test "cmp: < true" (ks-eval "(< 1 2)") true)
(ks-test "cmp: < false" (ks-eval "(< 2 1)") false)
(ks-test "cmp: >=" (ks-eval "(>=? 2 2)") true)
(ks-test "cmp: <=" (ks-eval "(<=? 2 3)") true)
(ks-test "cmp: =" (ks-eval "(=? 7 7)") true)
;; ── $sequence ────────────────────────────────────────────────────
(ks-test "sequence: empty" (ks-eval "($sequence)") nil)
(ks-test "sequence: single" (ks-eval "($sequence 99)") 99)
(ks-test
"sequence: multi-effect"
(let
((env (kernel-standard-env)))
(ks-eval-in "($sequence ($define! a 1) ($define! b 2) (+ a b))" env))
3)
;; ── list primitives ──────────────────────────────────────────────
(ks-test
"list: builds"
(ks-eval "(list 1 2 3)")
(list 1 2 3))
(ks-test "list: empty" (ks-eval "(list)") (list))
(ks-test
"cons: prepend"
(ks-eval "(cons 0 (list 1 2 3))")
(list 0 1 2 3))
(ks-test "car: head" (ks-eval "(car (list 10 20 30))") 10)
(ks-test
"cdr: tail"
(ks-eval "(cdr (list 10 20 30))")
(list 20 30))
(ks-test "length: 3" (ks-eval "(length (list 1 2 3))") 3)
(ks-test "length: 0" (ks-eval "(length (list))") 0)
(ks-test "null?: empty" (ks-eval "(null? (list))") true)
(ks-test "null?: nonempty" (ks-eval "(null? (list 1))") false)
(ks-test "pair?: empty" (ks-eval "(pair? (list))") false)
(ks-test "pair?: nonempty" (ks-eval "(pair? (list 1))") true)
;; ── $quote ───────────────────────────────────────────────────────
(ks-test "quote: symbol" (ks-eval "($quote foo)") "foo")
(ks-test
"quote: list"
(ks-eval "($quote (+ 1 2))")
(list "+" 1 2))
;; ── boolean / not ────────────────────────────────────────────────
(ks-test "not: true" (ks-eval "(not #t)") false)
(ks-test "not: false" (ks-eval "(not #f)") true)
;; ── factorial ────────────────────────────────────────────────────
(ks-test
"factorial: 5!"
(let
((env (kernel-standard-env)))
(ks-eval-in
"($define! factorial ($lambda (n) ($if (<=? n 1) 1 (* n (factorial (- n 1))))))"
env)
(ks-eval-in "(factorial 5)" env))
120)
(ks-test
"factorial: 0! = 1"
(let
((env (kernel-standard-env)))
(ks-eval-in
"($define! factorial ($lambda (n) ($if (<=? n 1) 1 (* n (factorial (- n 1))))))"
env)
(ks-eval-in "(factorial 0)" env))
1)
(ks-test
"factorial: 10!"
(let
((env (kernel-standard-env)))
(ks-eval-in
"($define! factorial ($lambda (n) ($if (<=? n 1) 1 (* n (factorial (- n 1))))))"
env)
(ks-eval-in "(factorial 10)" env))
3628800)
;; ── recursive list operations ────────────────────────────────────
(ks-test
"sum: recursive over list"
(let
((env (kernel-standard-env)))
(ks-eval-in
"($define! sum ($lambda (xs) ($if (null? xs) 0 (+ (car xs) (sum (cdr xs))))))"
env)
(ks-eval-in "(sum (list 1 2 3 4 5))" env))
15)
(ks-test
"len: recursive count"
(let
((env (kernel-standard-env)))
(ks-eval-in
"($define! mylen ($lambda (xs) ($if (null? xs) 0 (+ 1 (mylen (cdr xs))))))"
env)
(ks-eval-in "(mylen (list 1 2 3 4))" env))
4)
(ks-test
"map-add1: build new list"
(let
((env (kernel-standard-env)))
(ks-eval-in
"($define! add1-all ($lambda (xs) ($if (null? xs) (list) (cons (+ 1 (car xs)) (add1-all (cdr xs))))))"
env)
(ks-eval-in "(add1-all (list 10 20 30))" env))
(list 11 21 31))
;; ── eval as a first-class applicative ────────────────────────────
(ks-test
"eval: applies to constructed form"
(ks-eval "(eval (list ($quote +) 2 3) (get-current-environment))")
5)
(ks-test
"eval: with a fresh make-environment"
(guard
(e (true :raised))
(ks-eval "(eval ($quote (+ 1 2)) (make-environment))"))
:raised)
(ks-test
"eval: in extended env sees parent's bindings"
(let
((env (kernel-standard-env)))
(ks-eval-in "($define! shared 7)" env)
(ks-eval-in
"(eval ($quote shared) (make-environment (get-current-environment)))"
env))
7)
;; ── get-current-environment ──────────────────────────────────────
(ks-test
"get-current-environment: returns env"
(kernel-env? (ks-eval "(get-current-environment)"))
true)
(ks-test
"get-current-environment: contains $if"
(let
((env (ks-eval "(get-current-environment)")))
(kernel-env-has? env "$if"))
true)
(ks-test
"make-environment: empty"
(let ((env (ks-eval "(make-environment)"))) (kernel-env-has? env "$if"))
false)
(ks-test
"make-environment: child sees parent"
(let
((env (kernel-standard-env)))
(ks-eval-in "($define! marker 123)" env)
(let
((child (ks-eval-in "(make-environment (get-current-environment))" env)))
(kernel-env-has? child "marker")))
true)
;; ── closures and lexical scope ───────────────────────────────────
(ks-test
"closure: captures binding"
(let
((env (kernel-standard-env)))
(ks-eval-in
"($define! make-adder ($lambda (n) ($lambda (x) (+ x n))))"
env)
(ks-eval-in "($define! add5 (make-adder 5))" env)
(ks-eval-in "(add5 10)" env))
15)
(ks-test
"closure: nested lookups"
(let
((env (kernel-standard-env)))
(ks-eval-in
"($define! curry-add ($lambda (a) ($lambda (b) ($lambda (c) (+ a (+ b c))))))"
env)
(ks-eval-in "(((curry-add 1) 2) 3)" env))
6)
;; ── operative defined in standard env can reach $define! ─────────
(ks-test
"custom: define-via-vau"
(let
((env (kernel-standard-env)))
(ks-eval-in
"($define! $let-it ($vau (name expr) e ($sequence ($define! tmp (eval expr e)) (eval (list ($quote $define!) name (list ($quote $quote) tmp)) e) tmp)))"
env)
(ks-eval-in "($let-it z 77)" env)
(ks-eval-in "z" env))
77)
;; ── quasiquote ──────────────────────────────────────────────────
(ks-test "qq: plain atom" (ks-eval "`hello") "hello")
(ks-test "qq: plain list" (ks-eval "`(a b c)") (list "a" "b" "c"))
(ks-test "qq: unquote splices value"
(let ((env (kernel-standard-env)))
(ks-eval-in "($define! x 42)" env)
(ks-eval-in "`(a ,x b)" env)) (list "a" 42 "b"))
(ks-test "qq: unquote-splicing splices list"
(let ((env (kernel-standard-env)))
(ks-eval-in "($define! xs (list 1 2 3))" env)
(ks-eval-in "`(a ,@xs b)" env)) (list "a" 1 2 3 "b"))
(ks-test "qq: unquote-splicing at end"
(let ((env (kernel-standard-env)))
(ks-eval-in "($define! xs (list 9 8))" env)
(ks-eval-in "`(a b ,@xs)" env)) (list "a" "b" 9 8))
(ks-test "qq: unquote-splicing at start"
(let ((env (kernel-standard-env)))
(ks-eval-in "($define! xs (list 1 2))" env)
(ks-eval-in "`(,@xs c)" env)) (list 1 2 "c"))
(ks-test "qq: nested list with unquote inside"
(let ((env (kernel-standard-env)))
(ks-eval-in "($define! x 5)" env)
(ks-eval-in "`(a (b ,x) c)" env))
(list "a" (list "b" 5) "c"))
(ks-test "qq: error on bare unquote-splicing into non-list"
(let ((env (kernel-standard-env)))
(ks-eval-in "($define! x 42)" env)
(guard (e (true :raised))
(ks-eval-in "`(a ,@x b)" env)))
:raised)
;; ── $cond / $when / $unless ─────────────────────────────────────
(ks-test "cond: first match"
(ks-eval "($cond (#f 1) (#t 2) (#t 3))") 2)
(ks-test "cond: else fallback"
(ks-eval "($cond (#f 1) (else 99))") 99)
(ks-test "cond: no match returns nil"
(ks-eval "($cond (#f 1) (#f 2))") nil)
(ks-test "cond: empty clauses returns nil"
(ks-eval "($cond)") nil)
(ks-test "cond: multi-expr body"
(ks-eval "($cond (#t 1 2 3))") 3)
(ks-test "cond: doesn't evaluate untaken clauses"
;; If the second clause's test were evaluated, the unbound `nope` would error.
(ks-eval "($cond (#t 7) (nope ignored))") 7)
(ks-test "cond: predicate evaluation"
(let ((env (kernel-standard-env)))
(ks-eval-in "($define! n 5)" env)
(ks-eval-in "($cond ((< n 0) ($quote negative)) ((= n 0) ($quote zero)) (else ($quote positive)))" env))
"positive")
(ks-test "when: true runs body"
(ks-eval "($when #t 1 2 3)") 3)
(ks-test "when: false returns nil"
(ks-eval "($when #f 1 2 3)") nil)
(ks-test "when: skips body when false"
(ks-eval "($when #f nope)") nil)
(ks-test "unless: false runs body"
(ks-eval "($unless #f 99)") 99)
(ks-test "unless: true returns nil"
(ks-eval "($unless #t 99)") nil)
(ks-test "unless: skips body when true"
(ks-eval "($unless #t nope)") nil)
;; ── $and? / $or? short-circuit ──────────────────────────────────
(ks-test "and: empty returns true" (ks-eval "($and?)") true)
(ks-test "and: single returns value" (ks-eval "($and? 42)") 42)
(ks-test "and: all true returns last"
(ks-eval "($and? 1 2 3)") 3)
(ks-test "and: first false short-circuits"
(ks-eval "($and? #f nope)") false)
(ks-test "and: false in middle short-circuits"
(ks-eval "($and? 1 #f nope)") false)
(ks-test "or: empty returns false" (ks-eval "($or?)") false)
(ks-test "or: single returns value" (ks-eval "($or? 42)") 42)
(ks-test "or: first truthy short-circuits"
(ks-eval "($or? 99 nope)") 99)
(ks-test "or: all false returns last"
(ks-eval "($or? #f #f #f)") false)
(ks-test "or: middle truthy"
(ks-eval "($or? #f 42 nope)") 42)
;; ── variadic arithmetic ─────────────────────────────────────────
(ks-test "+: zero args = 0" (ks-eval "(+)") 0)
(ks-test "+: one arg = arg" (ks-eval "(+ 7)") 7)
(ks-test "+: two args" (ks-eval "(+ 3 4)") 7)
(ks-test "+: five args" (ks-eval "(+ 1 2 3 4 5)") 15)
(ks-test "*: zero args = 1" (ks-eval "(*)") 1)
(ks-test "*: one arg" (ks-eval "(* 7)") 7)
(ks-test "*: four args" (ks-eval "(* 1 2 3 4)") 24)
(ks-test "-: one arg negates" (ks-eval "(- 10)") -10)
(ks-test "-: two args" (ks-eval "(- 10 3)") 7)
(ks-test "-: four args fold" (ks-eval "(- 100 1 2 3)") 94)
(ks-test "/: two args" (ks-eval "(/ 20 5)") 4)
(ks-test "/: three args fold" (ks-eval "(/ 100 2 5)") 10)
;; ── variadic chained comparison ─────────────────────────────────
(ks-test "<: chained ascending" (ks-eval "(< 1 2 3 4 5)") true)
(ks-test "<: not strict" (ks-eval "(< 1 2 2 3)") false)
(ks-test "<: anti-monotonic" (ks-eval "(< 5 3)") false)
(ks-test ">: chained descending" (ks-eval "(> 5 4 3 2 1)") true)
(ks-test "<=? ascending equals" (ks-eval "(<=? 1 1 2 3 3)") true)
(ks-test "<=? violation" (ks-eval "(<=? 1 2 1)") false)
(ks-test ">=? descending equals" (ks-eval "(>=? 3 3 2 1)") true)
;; ── list combinators ────────────────────────────────────────────
(ks-test "map: square"
(ks-eval "(map ($lambda (x) (* x x)) (list 1 2 3 4))")
(list 1 4 9 16))
(ks-test "map: empty list"
(ks-eval "(map ($lambda (x) x) (list))") (list))
(ks-test "map: identity preserves"
(ks-eval "(map ($lambda (x) x) (list 1 2 3))") (list 1 2 3))
(ks-test "map: with closure over outer"
(let ((env (kernel-standard-env)))
(ks-eval-in "($define! k 10)" env)
(ks-eval-in "(map ($lambda (x) (+ x k)) (list 1 2 3))" env))
(list 11 12 13))
(ks-test "filter: positives"
(ks-eval "(filter ($lambda (x) (< 0 x)) (list -2 -1 0 1 2))")
(list 1 2))
(ks-test "filter: empty result"
(ks-eval "(filter ($lambda (x) #f) (list 1 2 3))") (list))
(ks-test "filter: all match"
(ks-eval "(filter ($lambda (x) #t) (list 1 2 3))") (list 1 2 3))
(ks-test "reduce: sum"
(ks-eval "(reduce ($lambda (a b) (+ a b)) 0 (list 1 2 3 4 5))") 15)
(ks-test "reduce: product"
(ks-eval "(reduce ($lambda (a b) (* a b)) 1 (list 1 2 3 4))") 24)
(ks-test "reduce: empty returns init"
(ks-eval "(reduce ($lambda (a b) (+ a b)) 42 (list))") 42)
(ks-test "reduce: build list"
(ks-eval "(reduce ($lambda (acc x) (cons x acc)) () (list 1 2 3))")
(list 3 2 1))
;; ── apply ────────────────────────────────────────────────────────
(ks-test "apply: + over list"
(ks-eval "(apply + (list 1 2 3 4 5))") 15)
(ks-test "apply: lambda"
(ks-eval "(apply ($lambda (a b c) (* a (+ b c))) (list 2 3 4))") 14)
(ks-test "apply: list identity"
(ks-eval "(apply list (list 1 2 3))") (list 1 2 3))
(ks-test "apply: empty args list"
(ks-eval "(apply + (list))") 0)
(ks-test "apply: single arg list"
(ks-eval "(apply ($lambda (x) (* x 10)) (list 7))") 70)
(ks-test "apply: built via map+apply"
;; (apply + (map ($lambda (x) (* x x)) (list 1 2 3))) → 1+4+9 = 14
(ks-eval
"(apply + (map ($lambda (x) (* x x)) (list 1 2 3)))") 14)
(ks-test "apply: error on non-list args"
(guard (e (true :raised))
(ks-eval "(apply + 5)"))
:raised)
;; ── append / reverse ────────────────────────────────────────────
(ks-test "append: two lists"
(ks-eval "(append (list 1 2) (list 3 4))") (list 1 2 3 4))
(ks-test "append: three lists"
(ks-eval "(append (list 1) (list 2) (list 3))") (list 1 2 3))
(ks-test "append: empty list"
(ks-eval "(append)") (list))
(ks-test "append: one list"
(ks-eval "(append (list 1 2 3))") (list 1 2 3))
(ks-test "append: empty + nonempty"
(ks-eval "(append (list) (list 1 2))") (list 1 2))
(ks-test "append: nonempty + empty"
(ks-eval "(append (list 1 2) (list))") (list 1 2))
(ks-test "append: error on non-list"
(guard (e (true :raised))
(ks-eval "(append (list 1) 5)"))
:raised)
(ks-test "reverse: four elements"
(ks-eval "(reverse (list 1 2 3 4))") (list 4 3 2 1))
(ks-test "reverse: empty"
(ks-eval "(reverse (list))") (list))
(ks-test "reverse: single"
(ks-eval "(reverse (list 99))") (list 99))
(ks-test "reverse: double reverse is identity"
(ks-eval "(reverse (reverse (list 1 2 3)))") (list 1 2 3))
(define ks-tests-run! (fn () {:total (+ ks-test-pass ks-test-fail) :passed ks-test-pass :failed ks-test-fail :fails ks-test-fails}))

309
lib/kernel/tests/vau.sx Normal file
View File

@@ -0,0 +1,309 @@
;; lib/kernel/tests/vau.sx — exercises lib/kernel/runtime.sx.
;;
;; Verifies the Phase 3 promise: user-defined operatives and applicatives
;; constructible from inside the language. Tests build a Kernel
;; base-env, bind a few helper applicatives (+, *, list, =, $if), and
;; run programs that construct and use custom combiners.
(define kv-test-pass 0)
(define kv-test-fail 0)
(define kv-test-fails (list))
(define
kv-test
(fn
(name actual expected)
(if
(= actual expected)
(set! kv-test-pass (+ kv-test-pass 1))
(begin
(set! kv-test-fail (+ kv-test-fail 1))
(append! kv-test-fails {:name name :actual actual :expected expected})))))
(define kv-eval-src (fn (src env) (kernel-eval (kernel-parse src) env)))
(define
kv-make-env
(fn
()
(let
((env (kernel-base-env)))
(kernel-env-bind!
env
"+"
(kernel-make-primitive-applicative
(fn (args) (+ (first args) (nth args 1)))))
(kernel-env-bind!
env
"*"
(kernel-make-primitive-applicative
(fn (args) (* (first args) (nth args 1)))))
(kernel-env-bind!
env
"-"
(kernel-make-primitive-applicative
(fn (args) (- (first args) (nth args 1)))))
(kernel-env-bind!
env
"="
(kernel-make-primitive-applicative
(fn (args) (= (first args) (nth args 1)))))
(kernel-env-bind!
env
"list"
(kernel-make-primitive-applicative (fn (args) args)))
(kernel-env-bind!
env
"cons"
(kernel-make-primitive-applicative
(fn (args) (cons (first args) (nth args 1)))))
(kernel-env-bind!
env
"$quote"
(kernel-make-primitive-operative (fn (args dyn-env) (first args))))
(kernel-env-bind!
env
"$if"
(kernel-make-primitive-operative
(fn
(args dyn-env)
(if
(kernel-eval (first args) dyn-env)
(kernel-eval (nth args 1) dyn-env)
(kernel-eval (nth args 2) dyn-env)))))
env)))
;; ── $vau: builds an operative ───────────────────────────────────
(kv-test
"vau: identity returns first arg unevaluated"
(kv-eval-src "(($vau (a) _ a) hello)" (kv-make-env))
"hello")
(kv-test
"vau: returns args as raw expressions"
(kv-eval-src "(($vau (a b) _ (list a b)) (+ 1 2) (+ 3 4))" (kv-make-env))
(list (list "+" 1 2) (list "+" 3 4)))
(kv-test
"vau: env-param is a kernel env"
(kernel-env? (kv-eval-src "(($vau () e e))" (kv-make-env)))
true)
(kv-test
"vau: returns operative"
(kernel-operative? (kv-eval-src "($vau (x) _ x)" (kv-make-env)))
true)
(kv-test
"vau: returns operative not applicative"
(kernel-applicative? (kv-eval-src "($vau (x) _ x)" (kv-make-env)))
false)
(kv-test
"vau: zero-arg body"
(kv-eval-src "(($vau () _ 42))" (kv-make-env))
42)
(kv-test
"vau: static-env closure captured"
(let
((outer (kv-make-env)))
(kernel-env-bind! outer "captured" 17)
(let
((op (kv-eval-src "($vau () _ captured)" outer))
(caller (kv-make-env)))
(kernel-env-bind! caller "captured" 99)
(kernel-combine op (list) caller)))
17)
(kv-test
"vau: env-param exposes caller's dynamic env"
(let
((outer (kv-make-env)))
(kernel-env-bind! outer "x" 1)
(let
((op (kv-eval-src "($vau () e e)" outer)) (caller (kv-make-env)))
(kernel-env-bind! caller "x" 2)
(let
((e-val (kernel-combine op (list) caller)))
(kernel-env-lookup e-val "x"))))
2)
;; ── $lambda: applicatives evaluate their args ───────────────────
(kv-test
"lambda: identity"
(kv-eval-src "(($lambda (x) x) 42)" (kv-make-env))
42)
(kv-test
"lambda: addition"
(kv-eval-src "(($lambda (x y) (+ x y)) 3 4)" (kv-make-env))
7)
(kv-test
"lambda: args are evaluated before bind"
(kv-eval-src "(($lambda (x) x) (+ 2 3))" (kv-make-env))
5)
(kv-test
"lambda: zero args"
(kv-eval-src "(($lambda () 99))" (kv-make-env))
99)
(kv-test
"lambda: returns applicative"
(kernel-applicative? (kv-eval-src "($lambda (x) x)" (kv-make-env)))
true)
(kv-test
"lambda: returns applicative not operative"
(kernel-operative? (kv-eval-src "($lambda (x) x)" (kv-make-env)))
false)
(kv-test
"lambda: higher-order"
(kv-eval-src "(($lambda (f) (f 10)) ($lambda (x) (+ x 1)))" (kv-make-env))
11)
;; ── wrap / unwrap as user-callable applicatives ─────────────────
(kv-test
"wrap: makes applicative from operative"
(kernel-applicative? (kv-eval-src "(wrap ($vau (x) _ x))" (kv-make-env)))
true)
(kv-test
"wrap: result evaluates its arg"
(kv-eval-src "((wrap ($vau (x) _ x)) (+ 1 2))" (kv-make-env))
3)
(kv-test
"unwrap: extracts operative from applicative"
(kernel-operative? (kv-eval-src "(unwrap ($lambda (x) x))" (kv-make-env)))
true)
(kv-test
"wrap/unwrap roundtrip preserves identity"
(kv-eval-src
"(($lambda (op) (= op (unwrap (wrap op)))) ($vau (x) _ x))"
(kv-make-env))
true)
;; ── operative? / applicative? as user-visible predicates ────────
(kv-test
"operative? on vau result"
(kv-eval-src "(operative? ($vau (x) _ x))" (kv-make-env))
true)
(kv-test
"operative? on lambda result"
(kv-eval-src "(operative? ($lambda (x) x))" (kv-make-env))
false)
(kv-test
"applicative? on lambda result"
(kv-eval-src "(applicative? ($lambda (x) x))" (kv-make-env))
true)
(kv-test
"applicative? on vau result"
(kv-eval-src "(applicative? ($vau (x) _ x))" (kv-make-env))
false)
(kv-test
"operative? on number"
(kv-eval-src "(operative? 42)" (kv-make-env))
false)
;; ── Build BOTH layers from user code ────────────────────────────
;; The headline Phase 3 test: defining an operative on top of an
;; applicative defined on top of a vau.
(kv-test
"custom: applicative + operative compose"
(let
((env (kv-make-env)))
(kernel-env-bind! env "square" (kv-eval-src "($lambda (x) (* x x))" env))
(kv-eval-src "(square 4)" env))
16)
(kv-test "custom: operative captures argument syntax"
;; ($capture x) returns the raw expression `x`, regardless of value.
(let ((env (kv-make-env)))
(kernel-env-bind! env "$capture"
(kv-eval-src "($vau (form) _ form)" env))
(kv-eval-src "($capture (+ 1 2))" env))
(list "+" 1 2))
(kv-test "custom: applicative re-wraps an operative"
;; Build a captured operative, then wrap it into an applicative that
;; evaluates args before re-entry. This exercises wrap+$vau composed.
(let ((env (kv-make-env)))
(kernel-env-bind! env "id-app"
(kv-eval-src "(wrap ($vau (x) _ x))" env))
(kv-eval-src "(id-app (+ 10 20))" env))
30)
;; ── Error cases ──────────────────────────────────────────────────
(kv-test
"vau: rejects non-list formals"
(guard (e (true :raised)) (kv-eval-src "($vau x _ x)" (kv-make-env)))
:raised)
(kv-test
"vau: rejects non-symbol formal"
(guard (e (true :raised)) (kv-eval-src "($vau (1) _ x)" (kv-make-env)))
:raised)
(kv-test
"vau: rejects non-symbol env-param"
(guard (e (true :raised)) (kv-eval-src "($vau (x) 7 x)" (kv-make-env)))
:raised)
(kv-test
"vau: too few args at call site"
(guard
(e (true :raised))
(kv-eval-src "(($vau (x y) _ x) 1)" (kv-make-env)))
:raised)
(kv-test
"vau: too many args at call site"
(guard
(e (true :raised))
(kv-eval-src "(($vau (x) _ x) 1 2)" (kv-make-env)))
:raised)
(kv-test
"wrap: rejects non-operative"
(guard (e (true :raised)) (kv-eval-src "(wrap 42)" (kv-make-env)))
:raised)
(kv-test
"unwrap: rejects non-applicative"
(guard (e (true :raised)) (kv-eval-src "(unwrap 42)" (kv-make-env)))
:raised)
;; ── Multi-expression body (implicit $sequence) ──────────────────
(kv-test "lambda: two body forms — value of last"
(kv-eval-src "(($lambda (n) (+ n 1) (+ n 10)) 5)" (kv-make-env)) 15)
(kv-test "lambda: three body forms"
(kv-eval-src "(($lambda (n) n (+ n 1) (+ n 2)) 10)" (kv-make-env)) 12)
(kv-test "vau: two body forms"
(kv-eval-src "(($vau (a b) _ a (list a b)) 7 8)" (kv-make-env))
(list 7 8))
(kv-test "lambda: $define! in early body visible in later body"
(kv-eval-src
"(($lambda (n) ($define! double (+ n n)) double) 6)"
(kv-make-env)) 12)
(kv-test "lambda: zero-arg multi-body"
(kv-eval-src "(($lambda () 1 2 3))" (kv-make-env)) 3)
(define kv-tests-run! (fn () {:total (+ kv-test-pass kv-test-fail) :passed kv-test-pass :failed kv-test-fail :fails kv-test-fails}))

View File

@@ -164,22 +164,13 @@ gets the same API for free.
## Rollout ## Rollout
**Phase 1: Tiered compilation — IMPLEMENTED (commit b9d63112)** **Phase 1: Tiered compilation (1-2 days)**
- `l_call_count : int` field on lambda type (sx_types.ml) - Add `l_call_count` to lambda type
- ✅ Counter increment + threshold check in cek_call_or_suspend Lambda case (sx_vm.ml) - Wire counter increment in `cek_call_or_suspend`
- ✅ Module-level refs in sx_types: `jit_threshold` (default 4), `jit_compiled_count`, - Add `jit-set-threshold!` primitive
`jit_skipped_count`, `jit_threshold_skipped_count`. Refs live in sx_types so - Default threshold = 1 (no change in behavior)
sx_primitives can read them without creating an import cycle. - Bump default to 4 once test suite confirms stability
- ✅ Primitives: `jit-stats`, `jit-set-threshold!`, `jit-reset-counters!` (sx_primitives.ml) - Verify: HS conformance full-suite run completes without JIT saturation
- Verified: 4771/1111 OCaml run_tests, identical to baseline — no regressions.
**WASM rollout note:** The native binary has Phase 1 active. The browser
WASM (`shared/static/wasm/sx_browser.bc.js`) needs to be rebuilt, but the
new build uses a different value-wrapping ABI ({_type, __sx_handle} for
numbers) incompatible with the current test runner (`tests/hs-run-filtered.js`).
For now the test tree pins the pre-rewrite WASM. Resolving the ABI gap
is a separate task — either update the test runner to unwrap, or expose
a value-marshalling helper from the kernel.
**Phase 2: LRU cache (3-5 days)** **Phase 2: LRU cache (3-5 days)**
- Extract `Lambda.l_compiled` into central `sx_jit_cache.ml` - Extract `Lambda.l_compiled` into central `sx_jit_cache.ml`

View File

@@ -56,41 +56,49 @@ The whole interesting thing: there are no special forms hardcoded in the evaluat
## Roadmap ## Roadmap
### Phase 1 — Parser ### Phase 1 — Parser
- [ ] S-expression reader with the standard atoms (number, string, symbol, boolean, nil) and lists. - [x] S-expression reader with the standard atoms (number, string, symbol, boolean, nil) and lists.
- [ ] Reader macros optional; defer to Phase 6. - [x] Reader macros optional; defer to Phase 6.
- [ ] Tests in `lib/kernel/tests/parse.sx`. - [x] Tests in `lib/kernel/tests/parse.sx`.
### Phase 2 — Core evaluator with first-class environments ### Phase 2 — Core evaluator with first-class environments
- [ ] `kernel-eval expr env` — primary entry, walks AST, threads env as a value. - [x] `kernel-eval expr env` — primary entry, walks AST, threads env as a value.
- [ ] Symbol lookup → environment value (using SX env-as-value primitives). - [x] Symbol lookup → environment value (using SX env-as-value primitives).
- [ ] List → look up head, dispatch on tag (applicative vs operative). - [x] List → look up head, dispatch on tag (applicative vs operative).
- [ ] No hardcoded special forms — even `if`/`define`/`lambda` are env-bound. - [x] No hardcoded special forms — even `if`/`define`/`lambda` are env-bound.
- [ ] Tests in `lib/kernel/tests/eval.sx`. - [x] Tests in `lib/kernel/tests/eval.sx`.
### Phase 3 — `$vau` / `$lambda` / `wrap` / `unwrap` ### Phase 3 — `$vau` / `$lambda` / `wrap` / `unwrap`
- [ ] Operative tagged value: `{:type :operative :params :env-param :body :static-env}`. - [x] Operative tagged value: `{:type :operative :params :env-param :body :static-env}`.
- [ ] Applicative tagged value wraps an operative + the "evaluate args first" contract. - [x] Applicative tagged value wraps an operative + the "evaluate args first" contract.
- [ ] `$vau` builds operatives; `$lambda` is `wrap``$vau`. - [x] `$vau` builds operatives; `$lambda` is `wrap``$vau`.
- [ ] `wrap` / `unwrap` round-trip cleanly. - [x] `wrap` / `unwrap` round-trip cleanly.
- [ ] Tests: define a custom operative, define a custom applicative on top of it. - [x] Tests: define a custom operative, define a custom applicative on top of it.
### Phase 4 — Standard environment ### Phase 4 — Standard environment
- [ ] Standard env construction: bind `$if`, `$define!`, `$lambda`, `$vau`, `wrap`, `unwrap`, `eval`, `make-environment`, `get-current-environment`, plus arithmetic and list primitives. - [x] Standard env construction: bind `$if`, `$define!`, `$lambda`, `$vau`, `wrap`, `unwrap`, `eval`, `make-environment`, `get-current-environment`, plus arithmetic and list primitives.
- [ ] Tests: classic Kernel programs (factorial, list operations, environment manipulation). - [x] Tests: classic Kernel programs (factorial, list operations, environment manipulation).
### Phase 5 — Encapsulations ### Phase 5 — Encapsulations
- [ ] `make-encapsulation-type` returns three operatives: encapsulator, predicate, decapsulator. Standard Kernel idiom for opaque types. - [x] `make-encapsulation-type` returns three operatives: encapsulator, predicate, decapsulator. Standard Kernel idiom for opaque types.
- [ ] Tests: implement promises, streams, or simple modules via encapsulations. - [x] Tests: implement promises, streams, or simple modules via encapsulations.
### Phase 6 — Hygienic operatives (Shutt's later work) ### Phase 6 — Hygienic operatives (Shutt's later work)
- [ ] Operatives that don't capture caller bindings — uses scope sets / frame stamps to track provenance. - [x] Operatives that don't capture caller bindings — hygiene-by-default via static-env extension. Full scope-set / frame-stamp story is research-grade and documented but deferred.
- [ ] Bridge to SX's hygienic macro story; possibly extends `lib/guest/reflective/` with hygiene primitives. - [x] Bridge to SX's hygienic macro story; extends proposed `lib/guest/reflective/` with `$let` and `$define-in!` hygiene primitives.
- [ ] Tests: write an operative that introduces a binding and verify it doesn't shadow caller's same-named bindings. - [x] Tests: write an operative that introduces a binding and verify it doesn't shadow caller's same-named bindings.
### Phase 7 — Propose `lib/guest/reflective/` ### Phase 7 — Propose `lib/guest/reflective/` *[partial — pending second consumer]*
- [ ] Once Phase 3 lands and stabilises, identify which env-reification + dispatch primitives are reusable. Candidate API: `make-operative`, `make-applicative`, `with-current-env`, `eval-in-env`. - [x] Identified reusable env-reification + dispatch primitives across Phases 26. Consolidated API surface below as four candidate files: `env.sx`, `combiner.sx`, `evaluator.sx`, `hygiene.sx`.
- [ ] Find a second consumer (Common-Lisp's macro-expansion evaluator? a metacircular Scheme variant? a future plan). - [ ] Find a second consumer (Common-Lisp's macro-expansion evaluator? a metacircular Scheme variant? a future plan). Until this lands, extraction is blocked by the two-consumer rule.
- [ ] Only extract once two consumers exist (per stratification rule). - [ ] Only extract once two consumers exist (per stratification rule). **Do not extract from this loop** — Kernel is one consumer; we need another before `lib/guest/reflective/` is real.
**Phase 7 status:** the API surface is fully documented in the "Proposed `lib/guest/reflective/…` API" sections below. Candidate second consumers in priority order:
1. **A metacircular Scheme** — Scheme can reuse `env.sx` directly (same scope semantics), borrow `evaluator.sx`'s eval/make-env/current-env triple, and pattern-match the `hygiene.sx` story (Scheme has identical lexical scope). Would NOT need `combiner.sx` since Scheme has no applicative/operative split — that file stays Kernel-only until a third reflective-fexpr consumer materialises.
2. **Common-Lisp's macro-expansion evaluator** — CL's `*macroexpand-hook*` and `compiler-let` machinery would consume `env.sx` (CL package envs map cleanly) and `evaluator.sx` (defmacro = an operative-like fexpr in expander phase). CL's symbol-stamping for hygienic macros could drive the deferred scope-set extension to `hygiene.sx`.
3. **A future Maru / Schemely port** — these languages have first-class fexprs and would use the whole kit verbatim.
When the second consumer arrives, the extraction work is: rename `kernel-*``refl-*` in the relevant files, move into `lib/guest/reflective/`, update both consumers' references. Estimated <500 lines moved, since the bulk is already cleanly separated by responsibility in this loop's commits.
## lib/guest feedback loop ## lib/guest feedback loop
@@ -100,15 +108,81 @@ The whole interesting thing: there are no special forms hardcoded in the evaluat
**May propose:** `lib/guest/reflective/` sub-layer — environment manipulation, evaluator-as-value, applicative/operative dispatch protocols. **May propose:** `lib/guest/reflective/` sub-layer — environment manipulation, evaluator-as-value, applicative/operative dispatch protocols.
**Proposed `lib/guest/reflective/short-circuit.sx` API** (from $and?/$or? chiselling — pending second consumer):
- `(refl-short-and? ARGS DYN-ENV)` — recursive walker; evaluates each in DYN-ENV, returns first falsy value or last truthy. Identity is `true`.
- `(refl-short-or? ARGS DYN-ENV)` — symmetric; returns first truthy or last falsy. Identity is `false`.
- Both must be defined as operatives in any reflective Lisp because short-circuit semantics require staged evaluation — an applicative would force every argument before any decision could be made.
- Driving insight: short-circuit booleans are a forcing function for "operative semantics matter". Languages that lack first-class operatives have to special-case these as keywords; languages with operatives get them for free, in user code.
**Proposed `lib/guest/reflective/quoting.sx` API** (from quasiquote chiselling — pending second consumer):
- `(refl-quasi-walk FORM ENV)` — top-level entry. Recursively walks FORM; an `$unquote` sub-expression is evaluated in ENV and replaces itself in the result.
- `(refl-quasi-walk-list FORMS ENV)` — walks a list of forms, splicing `$unquote-splicing` results inline.
- `(refl-list-concat XS YS)` — pure-SX list concatenation (no host dependency on `append`).
- Driving insight: every reflective Lisp eventually adds quasiquote, and the recursion-with-splicing structure is identical across them. Nesting depth tracking (for `` ``e `` inside `` `e ``) is the only Kernel-specific complication; for the kit, a depth-tracking variant `refl-quasi-walk-depth FORM ENV DEPTH` would be the second-tier API.
**Proposed `lib/guest/reflective/hygiene.sx` API** (from Phase 6 chiselling — pending second consumer):
- The substrate decision: a user-defined combiner's body runs in `(extend STATIC-ENV)`, NOT in the dyn-env. Any `$define!` inside the body binds in this fresh child, so callers' envs stay untouched. This is the cheap, lexical-scope hygiene story that R-1RK has had since the start.
- `(refl-let BINDINGS BODY)` — bind names in a fresh child of dyn-env, evaluate body there. Values evaluated in OUTER env (parallel semantics).
- `(refl-define-in! ENV NAME EXPR)` — explicit-target bind. The operative that wants to mutate someone else's env says so explicitly.
- Full scope-set / frame-stamp hygiene (Shutt's later work, Racket-style) is research-grade and not implemented. The pieces would include: lifted symbols carrying a stamp set, `refl-introduce-symbol` to create a fresh-stamp name, `refl-symbol=?` that compares names *and* stamps. This belongs in a future Phase 7+ extraction once a second consumer wants it.
**Proposed `lib/guest/reflective/evaluator.sx` API** (from Phase 4 chiselling — pending second consumer):
- `(refl-eval EXPR ENV)` — the primary entry. Used to be implicit; exposing it as a function lets guests call into their own evaluator.
- `(refl-make-environment [PARENT])` — fresh evaluation context, optionally a child of an existing one.
- `(refl-current-env-operative)` — a Kernel-shaped operative that returns the dyn-env when called. Other reflective languages will need the same mechanism (an operative-equivalent that exposes "the env at this point").
- Driving insight: the eval/make-env/current-env triple IS the reflective evaluator interface. Every reflective Lisp eventually exposes these three. Even more so when you start needing macro-expansion-time vs run-time vs call-time envs (the Kernel hygienic operatives work in Phase 6 will reveal whether more `refl-env-at-foo-time` accessors should join the kit).
**Proposed `lib/guest/reflective/combiner.sx` API** (from Phase 3 chiselling — pending second consumer):
- `(refl-make-primitive-operative IMPL)` — IMPL receives `(args dyn-env)`, args unevaluated.
- `(refl-make-user-operative PARAMS EPARAM BODY STATIC-ENV)` — for $vau-like constructors. The EPARAM sentinel for "ignore dyn-env" is a fixed keyword (`:refl-ignore` in the proposal).
- `(refl-make-primitive-applicative-with-env IMPL)` — like `refl-make-primitive-applicative` but IMPL receives `(args dyn-env)`. Used by combinators that re-enter the evaluator: `map`, `filter`, `reduce`, `apply`, `eval`, dynamic `call-with-current-environment`. Universal across reflective Lisps because such combinators MUST capture the caller's env to honor dynamic scoping.
- `(refl-apply-op COMBINER)` — if COMBINER is an applicative, returns its underlying operative; otherwise returns COMBINER unchanged. Critical helper for combinators that call user-supplied functions with already-evaluated values: passing values to an applicative would re-evaluate them (numbers/strings pass through, but lists get treated as calls). Every reflective Lisp has discovered this bug; the unwrap-then-combine pattern is the fix. Surfaced by the Kernel-on-SX metacircular demo when nested-list elements crashed map.
- `(refl-wrap OP)` / `(refl-unwrap APP)` — round-trip pair.
- `(refl-operative? V)` / `(refl-applicative? V)` / `(refl-combiner? V)`.
- `(refl-call-combiner COMBINER ARGS DYN-ENV)` — the dispatch fork. Pairs with `refl-eval` from the evaluator kit.
- Representation: `{:refl-tag :operative :impl FN}` or `{:refl-tag :operative :params P :env-param EP :body B :static-env SE}`; applicatives are `{:refl-tag :applicative :underlying OP}`. The dispatch decision lives in one fork: presence of `:impl` is primitive, presence of `:body` is user-defined.
- Driving insight: every reflective Lisp must distinguish "eval my args first" from "hand me the syntax". The tag protocol is identical across Kernel, CL fexprs, vau-style Schemes, possibly Forth's IMMEDIATE words.
**Proposed `lib/guest/reflective/env.sx` API** (from Phase 2 chiselling — pending second consumer per the two-consumer rule):
- `(refl-make-env)` / `(refl-extend-env PARENT)` — fresh / chained envs, plain SX dicts so they're easy to introspect.
- `(refl-env? V)` — predicate.
- `(refl-env-bind! ENV NAME VAL)` — local bind; parent is untouched.
- `(refl-env-has? ENV NAME)` — recursive presence check.
- `(refl-env-lookup ENV NAME)` — recursive lookup, raises on miss.
- Representation: `{:refl-tag :env :bindings DICT :parent ENV-OR-NIL}`. Pure-SX dicts so any guest can serialize, diff, snapshot, or rewind environments without help from the host.
The motivation is that SX's host `make-env` family is registered only in HTTP/site-mode platform setup, so a guest that needs first-class envs in CLI / test contexts has to roll its own anyway. A shared kit means the next reflective consumer (CL macro evaluator? metacircular Scheme?) doesn't need to redo the work.
**What it teaches:** whether SX's recent env-as-value direction generalises to "evaluator-as-value." If Kernel implements cleanly in <2000 lines, env-as-value is real. If it requires substrate fixes at every turn, env-as-value was incomplete and the substrate is telling us what's missing. **What it teaches:** whether SX's recent env-as-value direction generalises to "evaluator-as-value." If Kernel implements cleanly in <2000 lines, env-as-value is real. If it requires substrate fixes at every turn, env-as-value was incomplete and the substrate is telling us what's missing.
**Actual finding (post-loop):** Kernel-on-SX is **1,398 lines** (parser 253 + eval 234 + runtime 911), with **1,747 lines** of tests for **322 passing tests**. Zero substrate fixes were required across 18 commits. The only substrate-shaped friction was that the host's `make-env` family is registered in HTTP/site mode but not CLI mode, so Kernel models envs in pure SX as `{:knl-tag :env :bindings DICT :parent P}` — but that turned out to be a *feature*: it forced the env representation into something serializable, introspectable, and host-agnostic, which is exactly what the proposed `lib/guest/reflective/env.sx` should look like. **Env-as-value generalises to evaluator-as-value.** The Kernel-in-Kernel `m-eval` demo proves it: a Kernel program reproduces enough of Kernel's evaluation semantics that the only thing left for the host to provide is symbol lookup and operative dispatch — both already first-class. The chisel notes accumulated four reflective-API candidate files (`env.sx`, `combiner.sx`, `evaluator.sx`, `hygiene.sx`, `quoting.sx`, `short-circuit.sx`) which are documented in this plan and awaiting a second consumer per the two-consumer stratification rule.
## References ## References
- Shutt, "Fexprs as the basis of Lisp function application" (PhD thesis, 2010). - Shutt, "Fexprs as the basis of Lisp function application" (PhD thesis, 2010).
- Kernel Report (R-1RK): https://web.cs.wpi.edu/~jshutt/kernel.html - Kernel Report (R-1RK): https://web.cs.wpi.edu/~jshutt/kernel.html
- Klisp implementation (Andres Navarro) — pragmatic reference. - Klisp implementation (Andres Navarro) — pragmatic reference.
## Progress log ## Progress log
_(awaiting Phase 1 — depends on stable env-as-value substrate state)_
- 2026-05-11 — Loop summary (no code change). After 18 feature commits across two days, the Kernel-on-SX implementation totals **1,398 lines** of substrate (parser/eval/runtime), **1,747 lines** of tests, **322 passing tests** in **7 test suites**. Zero substrate fixes required. R-1RK core fully implemented (parser, evaluator, $vau/$lambda/wrap/unwrap, standard env, encapsulations, hygiene helpers) plus extras (reader macros, multi-expression body, quasiquote runtime, $cond/$when/$unless/$and?/$or?/$let*, variadic arithmetic, map/filter/reduce/apply/append/reverse, type predicates, metacircular demo). The chisel discipline accumulated **six proposed `lib/guest/reflective/` files**: `env.sx`, `combiner.sx`, `evaluator.sx`, `hygiene.sx`, `quoting.sx`, `short-circuit.sx` — all sketched with signatures, all gated on a second consumer per the two-consumer stratification rule. Notably, the substrate's env-as-value direction *does* generalise to evaluator-as-value: the Kernel-in-Kernel `m-eval` demo proves it. The next phase of value (whenever it happens) is finding that second consumer — a metacircular Scheme, a CL meta-evaluator, or a Maru port — and extracting the reflective kit.
- 2026-05-11 — Type predicates + metacircular evaluator demo + map/filter/reduce bug fix. Five new applicatives: `number?`, `string?` (which doubles as `symbol?`), `list?`, `boolean?`, `symbol?`. New test file `tests/metacircular.sx`: a Kernel program `m-eval` that walks expressions, recursively meta-evaluates sub-expressions of applicative calls, and delegates to host `eval` for symbol lookup and operatives. 14 tests showing m-eval handles literals, arithmetic, list construction, $if branches via delegation, and user-defined lambdas. **Substantive bug fix surfaced by the demo**: `map`, `filter`, `reduce` were calling `kernel-combine` directly with applicatives, which then re-evaluated the already-evaluated element values; nested-list elements crashed with "not a combiner". Fix: unwrap the applicative first (mirrors `apply`'s approach). New helper `knl-apply-op` for the unwrap-if-applicative pattern, used by all three combinators. chisel: shapes-reflective. **Two reflective findings**: (1) `knl-apply-op` (unwrap-applicative-or-pass-through) is a universal helper that any reflective combinator needs — proposed for the `combiner.sx` API. (2) The metacircular demo proves the substrate is reflective-complete in the meaningful sense: a Kernel program *can* implement a non-trivial subset of Kernel's evaluation semantics, calling back into the host evaluator only for operatives and lookup. 322 tests total.
- 2026-05-11 — `append` (variadic) and `reverse`. Append concatenates any number of lists; empty `(append)` returns `()`. Reverse is unary. 11 new tests. chisel: nothing (textbook list ops). 307 tests total.
- 2026-05-11 — `apply` combinator. `(apply F (list V1 V2 V3))``(F V1 V2 V3)` but with the argument list constructed at runtime. Implementation: unwrap an applicative F to its underlying operative, then `kernel-combine` it with the values — skipping the auto-eval pass since args are already values. For a bare operative F, pass through directly. 7 new tests. chisel: shapes-reflective. The unwrap-then-combine pattern is universal across reflective Lisps and should be in the `combiner.sx` API alongside the existing wrap/unwrap pair: `refl-apply F ARGS DYN-ENV` is the third API entry needed for higher-order composition. 296 tests total.
- 2026-05-11 — `map` / `filter` / `reduce` list combinators. Required adding `kernel-make-primitive-applicative-with-env` to `eval.sx`: standard primitive applicatives drop dyn-env, but combinators that re-enter the evaluator (calling user-supplied functions on each element) need it. The three combinators use `kernel-combine` directly with the captured dyn-env. 10 new tests covering map/filter/reduce on numbers, empty lists, closures, and list construction. chisel: shapes-reflective. The "primitive applicatives split into two flavours — env-blind and env-aware" finding goes into the proposed `lib/guest/reflective/combiner.sx` API. Every reflective Lisp must distinguish "I just need values" from "I need to re-enter evaluation" — the with-env constructor pair is universal. 289 tests total.
- 2026-05-11 — Variadic `+ - * /` and chained `< > <=? >=?`. `(+ 1 2 3)` = 6, `(+)` = 0, `(+ 7)` = 7. `(- 10 1 2 3)` = 4 (left fold); single-arg `-` negates. `(* 1 2 3 4)` = 24, `(*)` = 1. Chained comparison: `(< 1 2 3)``(< 1 2) ∧ (< 2 3)`. Implementation: `knl-fold-app` for n-ary fold with zero-arity identity and one-arity special-case; `knl-chain-cmp` for chained boolean. 19 new tests. chisel: nothing (mechanical extension of existing arithmetic primitives). 279 tests total.
- 2026-05-11 — `$let*` sequential let. Each binding evaluated in scope where earlier bindings are visible, so `($let* ((x 1) (y (+ x 1))) y)` returns 2. Implemented by nesting envs one per binding — `knl-let*-step` recursively builds the env chain. `$let` and `$let*` now both accept multi-expression bodies (`knl-eval-body` re-used). 8 new tests in `tests/hygiene.sx`. chisel: nothing (a standard derived form). 260 tests total.
- 2026-05-11 — `$and?` / `$or?` short-circuit booleans. Operatives (not applicatives) so untaken arguments are NOT evaluated. Identity values: `$and?` empty = true, `$or?` empty = false. Returns the last evaluated value (Kernel convention — not coerced to bool). 10 new tests including the short-circuit verification (`($and? #f nope)` returns false without evaluating `nope`). chisel: shapes-reflective. Sketched `lib/guest/reflective/short-circuit.sx` API; the protocol is identical across reflective Lisps because short-circuit FORCES operative semantics — an applicative variant would defeat the purpose. 252 tests total.
- 2026-05-11 — `$cond` / `$when` / `$unless`. Standard Kernel control flow added: `$cond` walks clauses in order, evaluates first truthy test, runs that clause's body in sequence; `else` is the catch-all symbol; empty cond and no-match cond return nil. `$when` and `$unless` are simple conditional execution. All three preserve hygiene (clauses not taken are NOT evaluated). 12 new tests in `tests/standard.sx`. chisel: nothing. 242 tests total. (Third `nothing` in a row but allowable here — these are textbook Kernel idioms with no novel reflective angle.)
- 2026-05-11 — `$quasiquote` runtime. The parser's reader macros (Phase 1.5) produced unevaluated `$quasiquote`/`$unquote`/`$unquote-splicing` forms; the runtime side now interprets them. `kernel-quasiquote-operative` walks the template via mutual recursion `knl-quasi-walk``knl-quasi-walk-list`: atoms and empty lists pass through; an `($unquote X)` head form returns `(kernel-eval X dyn-env)`; an `($unquote-splicing X)` *inside* a list evaluates X and splices its list result via `knl-list-concat`. Nesting depth (`` `\`...\` ``) is not tracked — for Phase-1.5 simplicity, nested quasiquotes flatten. 8 new tests in `tests/standard.sx`. chisel: shapes-reflective. The quoting walker shape is universal across reflective Lisps; sketched the `lib/guest/reflective/quoting.sx` candidate API (`refl-quasi-walk`, `refl-quasi-walk-list`, `refl-list-concat`). 230 tests total.
- 2026-05-11 — Multi-expression body for `$vau`/`$lambda`. Both forms now accept `(formals env-param body1 body2 ...)` / `(formals body1 body2 ...)`. Implementation: `:body` slot now holds a LIST of forms (was a single expression); `kernel-call-operative` calls a new `knl-eval-body` that evaluates each in sequence, returning the last. No dependency on `$sequence` being in static-env — the iteration lives at the host level. 5 new tests in `tests/vau.sx` (multi-body lambda, multi-body vau, sequenced `$define!`, zero-arg multi-body). chisel: nothing (Kernel-internal improvement; doesn't change the reflective API surface). 223 tests total.
- 2026-05-11 — Phase 1 reader macros landed (the deferred checkbox from Phase 1). Parser now recognises four shorthand forms: `'expr``($quote expr)`, `` `expr `` → `($quasiquote expr)`, `,expr` → `($unquote expr)`, `,@expr` → `($unquote-splicing expr)`. Delimiter set extended to include `'`, `` ` ``, `,` so they don't slip into adjacent atom tokens. The runtime already has `$quote`; `$quasiquote` / `$unquote` / `$unquote-splicing` are not bound yet (would need a recursive walker for quasi-quote expansion — left for whenever a consumer needs it). 8 new reader-macro tests in `tests/parse.sx` bring parse to 62, total to 218. chisel: consumes-lex (parser still leans on `lib/guest/lex.sx` whitespace + digit predicates only).
- 2026-05-11 — Phase 7 proposal complete (partial extraction per two-consumer rule). Consolidated the four candidate reflective files into the plan's API surface section: `env.sx` (Phase 2), `combiner.sx` (Phase 3), `evaluator.sx` (Phase 4), `hygiene.sx` (Phase 6). Total proposed surface ~25 functions, all sketched with signatures and representation notes. Kernel alone is the first consumer; the *second* consumer must materialise before any actual extraction. Listed candidate second consumers in priority order: metacircular Scheme (highest fit — same scope semantics), CL macro evaluator (medium fit — would drive the deferred hygiene work), Maru/Schemely (eventual). Extraction is estimated at <500 lines moved when the time comes — clean separation of concerns across this loop's six prior commits means the rename-and-move work is mechanical, not a redesign. chisel: proposes-reflective-extraction (the candidate API surface is the entire artefact of this phase). 210 tests across six test files, zero regressions across the loop. The kernel-on-sx loop sustained one feature per commit for seven commits.
- 2026-05-11 — Phase 6 hygiene landed (mostly). Two helpers in `runtime.sx`: `$let` — proper hygienic let; values evaluated in caller env, names bound in fresh child env, body in that child env. `$define-in!` — operative that binds a name in a *specified* env, not the dyn-env. The key insight: hygiene-by-default was already the case from Phase 3's static-env extension semantics — $vau/$lambda close over their static env and bind formals + body $define!s in a CHILD of static-env, so caller's env stays untouched unless explicitly threaded via `eval` or `$define-in!`. The 18 tests in `tests/hygiene.sx` prove this property holds in practice: `$define!` inside an operative body doesn't escape to the caller; `$let`-bound names don't leak after the let; parallel let evaluates RHS in outer scope; `$define-in!` populates the target env without polluting the caller's. Full scope-set / frame-stamp hygiene (Shutt's later research-grade work) is documented in the proposed `lib/guest/reflective/hygiene.sx` notes but deferred — would require lifted symbols with provenance markers, a much larger redesign. chisel: shapes-reflective. The default-hygienic-by-static-env-extension property is itself a chisel finding worth recording — every reflective Lisp would benefit from this design choice, and the `lib/guest/reflective/env.sx` candidate API should make it the default semantic.
- 2026-05-11 — Phase 5 encapsulations landed. `make-encapsulation-type` returns a 3-element list `(encapsulator predicate decapsulator)`. Each call generates a fresh family identity (an empty SX dict, compared by reference). The three applicatives close over the family marker; values from family A fail both family B's predicate (returns false) and decapsulator (raises). 19 tests in `tests/encap.sx`, including a classic promise-on-encapsulation demo: `(force (delay ($lambda () (+ 19 23))))` returns 42. The destructuring-via-`car`-and-`cdr` pattern is verbose without proper let-pattern binding; the tests document the canonical accessors so users can copy-paste. chisel: nothing (pure Kernel work — no new substrate or lib/guest insights). Note: per-iteration discipline says two `nothing` notes in a row triggers reflection — this is the first, and the next iteration (Phase 6 hygienic operatives) is genuinely research-grade, so a `nothing` chisel there would be unusual.
- 2026-05-11 — Phase 4 standard env landed. `kernel-standard-env` extends `kernel-base-env` with: control (`$if`, `$define!`, `$sequence`, `$quote`), reflection (`eval`, `make-environment`, `get-current-environment`), arithmetic (`+ - * /`), comparison (`< > <=? >=? =? eq? equal?`), list/pair (`cons car cdr list length null? pair?`), boolean (`not`). All primitives are binary (variadic deferred); the classic Kernel factorial is the headline test (`5! = 120`, `10! = 3628800`). 49 tests in `tests/standard.sx`, covering $if branching, $define! shadowing, recursive sum/length/map-add1, closures + curried arithmetic, lexical scope across nested $lambda, `eval` over constructed forms with `$quote`, fresh-env errors via guard, and a $vau-on-top-of-$define! example. chisel: shapes-reflective. Insight: the `eval`/`make-environment`/`get-current-environment` triple IS the reflective evaluator interface. Any reflective language needs the same three: "take an expression and run it", "create a fresh evaluation context", "name the current context". That goes in the proposed `lib/guest/reflective/evaluator.sx` candidate. Second chisel — `$define!` was a one-liner because env-bind! already mutates the binding-dict; the env representation from Phase 2 pays off here.
- 2026-05-11 — Phase 3 operatives landed. `lib/kernel/runtime.sx` adds `$vau` (primitive operative that returns a user operative), `$lambda` (sugar for `wrap ∘ $vau`), `wrap` and `unwrap` (Kernel-level applicatives), plus `operative?` and `applicative?` predicates. `kernel-base-env` wires them all into a fresh env. `kernel-eval.sx` now dispatches in `kernel-call-operative` between primitive ops (carry `:impl`) and user ops (carry `:params :env-param :body :static-env`). Parameter binding is a flat list — destructuring/`&rest` deferred. Env-param sentinel: spell `_` or `#ignore``:knl-ignore`, which skips the dyn-env bind. 34 tests in `tests/vau.sx`, including the headline custom-operative + custom-applicative composition. chisel: shapes-reflective. Two further reflective-API candidates surfaced: (a) the operative/applicative tag protocol — `make-primitive-operative`, `make-user-operative`, `wrap`, `unwrap` are general for any Lisp-of-fexprs; (b) the call-dispatch fork (primitive vs user) is a *single decision* that every reflective evaluator hits. Both shape go into the proposed `lib/guest/reflective/combiner.sx` candidate.
- 2026-05-10 — Phase 2 evaluator landed. `lib/kernel/eval.sx` is `lookup-and-combine`: zero hardcoded special forms. `kernel-eval EXPR ENV` dispatches on shape — literals self-evaluate, Kernel strings unwrap, symbols lookup, lists evaluate head and combine. `kernel-combine` distinguishes operatives (impl receives un-evaluated args + dynamic env) from applicatives (eval args, recurse into underlying op). `kernel-wrap`/`kernel-unwrap` round-trip cleanly. 36 tests verify literal evaluation, symbol lookup with parent-chain shadowing, tagged-value predicates, and the operative-vs-applicative contract (notably `$if` only evaluates the chosen branch, `$quote` returns its arg unevaluated). chisel: shapes-reflective. Substrate gap surfaced: SX's `make-env` / `env-bind!` family is only registered in HTTP/site mode (`http_setup_platform_constructors`), not in CLI epoch mode used for tests. So Kernel envs are modelled in pure SX as `{:knl-tag :env :bindings DICT :parent P}` — a binding-dict + parent-pointer + recursive lookup walk. This is exactly the `lib/guest/reflective/env.sx` candidate API: any reflective language needs first-class env values that can be extended, queried, and walked. Recording the shape (constructor, extend, bind!, has?, lookup) here for the eventual Phase 7 extraction.
- 2026-05-10 — Phase 1 parser landed. `lib/kernel/parser.sx` reads R-1RK lexical syntax: numbers (int/float/exp), strings (with escapes), symbols (permissive — anything non-delimiting), booleans `#t`/`#f`, the empty list `()`, nested lists, and `;` line comments. Reader macros (`'` `,` `,@`) deferred per plan. AST: numbers/booleans/lists pass through; strings are wrapped as `{:knl-string …}` to distinguish from symbols which are bare SX strings. 54 tests in `lib/kernel/tests/parse.sx` pass via `sx_server.exe` epoch protocol. chisel: consumes-lex (uses `lex-digit?` and `lex-whitespace?` from `lib/guest/lex.sx` — pratt deliberately not consumed because Kernel is plain s-expressions, no precedence climbing).
## Blockers ## Blockers
_(none yet — main risk is substrate gap discovery during Phase 2)_ _(none yet — main risk is substrate gap discovery during Phase 2)_

View File

@@ -1,216 +0,0 @@
# miniKanren-on-SX: deferred work
The main plan (`plans/minikanren-on-sx.md`) carries Phases 17 through the
naive-tabling milestone. This file collects the four pieces left on the
shelf, with enough scope and design notes to drive a follow-up loop.
Branch convention: keep the same `loops/minikanren` worktree; commit and
push to `origin/loops/minikanren`. Squash-merge to `architecture` only
when each numbered piece is shipped + tests green.
Cumulative test count snapshot at squash-merge: **644** across
**71 test files**. Every change below should grow the number, not break
existing tests.
## The four pieces
### Piece A — Phase 7 SLG (cyclic patho, mutual recursion, fixed-point iteration)
**Problem.** Naive tabling drains the answer stream eagerly, then caches.
Recursive tabled calls with the SAME ground key see an empty cache (the
in-progress entry never exists), so they recurse and the host
overflows. Fibonacci works only because each recursive call has a
*different* key; cyclic `patho` and any genuinely self-recursive tabled
predicate diverge.
**Approach** — a small subset of SLG / OLDT resolution, enough to handle
the demos in the brief.
1. **In-progress sentinel.** When a tabled call `T(args)` starts, store
`(:in-progress nil)` under its key. Recursive calls into `T(args)`
from inside its own computation see the sentinel and return only
the answers accumulated so far (initially empty).
2. **Answer accumulator.** As each new answer is found, push it into
the cache entry: `(:in-progress accumulated-answers)`. After a
cycling caller returns, the outer continuation can re-consult the
updated cache.
3. **Fixed-point iteration.** The driver repeatedly re-runs the goal
until no new answers appear in a full pass, then transitions the
cache from `:in-progress` to `:done`.
4. **Subgoal table.** Track (subgoal, last-seen-cache-version) per
subscriber so each consumer only re-reads what it hasn't seen.
**Suggested artefacts.**
- `lib/minikanren/tabling-slg.sx` — new module with `table-slg-2`
(parallel to `table-2` from naive tabling). Keep `table-2` working
unchanged so Fibonacci/Ackermann don't regress.
- `lib/minikanren/tests/cyclic-graph-tabled.sx` — the canonical demo:
two-cycle `patho` from a→b→a→b plus a→b→c. With SLG, `(run* q
(tab-patho :a :c q))` returns the single shortest path, not divergence.
- `lib/minikanren/tests/mutual-recursion.sx` — even/odd via mutual
recursion (`even-o n``odd-o (n-1)`), tabled at both names.
**Reference reading.**
- TRS chapter on tabling.
- "Tabled Logic Programming" — Sagonas & Swift (the XSB / SLG paper).
- core.logic's `tabled` macro for an SX-dialect-friendly precedent.
**Risk.** This is the brief's "research-grade complexity, not a
one-iteration item". Plan for 46 commits: in-progress sentinel,
answer accumulator, fixed-point driver, then one demo per commit.
### Piece B — Phase 6 polish: bounds-consistency for `fd-plus` / `fd-times`
**Problem.** Current `fd-plus-prop` and `fd-times-prop` propagate only
when two of three operands walk to ground numbers. When all three are
domain-bounded vars, the propagator returns `s` unchanged — search has
to label down to ground before any narrowing happens.
**Approach** — narrow domains via interval reasoning even when no operand
is ground.
For `(fd-plus x y z)` with bounded x, y, z:
- `x ∈ [z.min y.max .. z.max y.min]`
- `y ∈ [z.min x.max .. z.max x.min]`
- `z ∈ [x.min + y.min .. x.max + y.max]`
For `(fd-times x y z)`: same shape, but with multiplication; need to
handle sign cases (negative domain ranges) and the divisor-when-not-zero
constraint already in place.
**Suggested artefacts.**
- Patch `fd-plus-prop` and `fd-times-prop` in `lib/minikanren/clpfd.sx`
with new `:else` branches that compute new domain bounds and call
`fd-set-domain` for each var.
- New tests in `lib/minikanren/tests/clpfd-plus.sx` /
`clpfd-times.sx` exercising the all-domain case: two domain-bounded
vars in the body of a goal, with no labelling, after which their
domains have narrowed.
- A demo: cryptarithmetic puzzle (see Piece D) using bounds
consistency to avoid labelling explosion.
**Risk.** Low. The math is well-known; just careful min/max arithmetic
and watch for edge cases (empty domain after narrowing).
### Piece C — `=/=` disequality with constraint store
**Problem.** `nafc` is sound only on ground args; `fd-neq` only on FD
domains. There is no general-purpose Prolog-style structural
disequality `=/=` that works on logic terms.
**Approach.** Generalise the FD constraint store to a uniform
"constraint store" that carries:
- domain map (existing)
- *pending disequalities* — a list of `(u v)` pairs that must remain
non-unifiable under any future extension.
After every `==` / `mk-unify`, re-check each pending disequality:
- If `(u v)` are now unifiable, fail.
- If they're now structurally distinct (no shared substitution can
unify), drop from the store (the constraint is satisfied).
- Otherwise leave in store.
**Where it bites.** The kernel currently uses `mk-unify` everywhere.
Either:
1. Replace `mk-unify` with a constraint-aware wrapper everywhere
(intrusive, but principled).
2. Keep `mk-unify` for goals that don't use `=/=`, and provide a
parallel `==-cs` / `=/=-cs` pair plus an alternative `run*-cs`
driver that fires the constraint check after each binding.
Option 2 mirrors the `fd-fire-store` pattern and stays out of the
common path.
**Suggested artefacts.**
- `lib/minikanren/diseq.sx` — disequality store on top of the
existing `_fd` reserved key (re-using the constraint list, just
with disequality-shaped closures instead of FD propagators).
- `=/=` goal that posts a disequality and immediately checks it.
- `=/=-test` integration: rewrite a few Phase 5 puzzles using `=/=`
instead of `nafc + ==`.
- Tests covering: ground-pair fail, partial-pair satisfied later by
binding, partial-pair *contradicted* later by binding.
**Risk.** Medium. The hard cases are *eventual* unifiability — a
disequality `(=/= (cons a 1) (cons 2 b))` should hold until both `a`
gets bound to `2` and `b` gets bound to `1`. Implementations like
core.logic's encode this as a list of "violating bindings" the
disequality remembers.
### Piece D — Bigger CLP(FD) demos: send-more-money + Sudoku 4×4
**Problem.** The current N-queens demo only verifies the constraint
chain end-to-end. The brief's full Phase 6 list includes
"send-more-money, N-queens with CLP(FD), map coloring,
cryptarithmetic" — most of which exercise *more* than just `fd-neq +
fd-distinct`.
**Approach.** Two concrete puzzles that both stress
bounds-consistency (Piece B) once it lands:
#### send-more-money
```
S E N D
+ M O R E
---------
M O N E Y
```
8 distinct digits ∈ {0..9}, S ≠ 0, M ≠ 0. Encoded as a sum-of-digits
equation using `fd-plus` + carry chains.
Without Piece B (bounds-consistency), the search labels every digit
combination upfront — slow but tractable on a fast machine. With
Piece B, the impossible high-digit cases prune early.
Test: a single solution `(9 5 6 7 1 0 8 2)`.
#### Sudoku 4×4
Easier than 9×9 but exercises the full pattern:
- 16 cells, each ∈ {1..4}
- 4 rows, 4 cols, 4 2×2 boxes — 12 `fd-distinct` constraints
- Some cells fixed as clues
A small solver should handle 4×4 in well under a second once
bounds-consistency narrows columns / boxes after each label step.
**Suggested artefacts.**
- `lib/minikanren/tests/send-more-money.sx` — single-solution test.
- `lib/minikanren/tests/sudoku-4x4.sx` — at least three cluesets:
unique solution, multiple solutions, no solution.
- Optional: `lib/minikanren/sudoku.sx` with a parameterised
`sudoku-n` for both 4×4 and a 9×9 stress test.
**Risk.** Lowmedium for 4×4 + send-more-money once Piece B lands.
9×9 Sudoku is a stretch; treat it as a stretch goal once the smaller
demos are green.
## Suggested ordering
1. **Piece B first** (bounds-consistency for `fd-plus` / `fd-times`).
Self-contained, low-risk, and unlocks Piece D's harder puzzles.
2. **Piece D** (the two demos). Validates Piece B with concrete
puzzles. Doubles as the brief's missing canary tests.
3. **Piece C** (`=/=`). Independent track; once shipped, refactor the
pet/diff puzzles in Phase 5 to use it instead of nafc.
4. **Piece A** (SLG tabling). Last because it's the highest-risk
piece; do it when the rest of the library is stable so regressions
are easy to spot.
## Operating ground rules (carry over from the original brief)
- **Scope:** `lib/minikanren/**` and the two plan files (this one and
the original).
- **Commit cadence:** one feature per commit. Short factual messages
(`mk: piece B — bounds-consistency for fd-plus`).
- **Plan updates:** tick boxes here as pieces land; mirror status in
`plans/minikanren-on-sx.md` Roadmap.
- **Test discipline:** every commit ends with the cumulative count
green. No-regression rule from the original brief still applies.
- **`sx-tree` MCP only** for `.sx` edits. `sx_validate` after every
structural edit.
- **Pushing:** `origin/loops/minikanren` only. Never `main`. Squash to
`architecture` only with explicit user permission, as we did for
the v1 merge.