kernel: Phase 4 standard env + factorial + 49 tests [shapes-reflective]
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 30s
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.
This commit is contained in:
@@ -1,34 +1,18 @@
|
||||
;; lib/kernel/runtime.sx — the operative–applicative substrate.
|
||||
;; lib/kernel/runtime.sx — the operative–applicative substrate and the
|
||||
;; standard Kernel environment.
|
||||
;;
|
||||
;; Builds the first user-visible operatives so Kernel programs can
|
||||
;; construct their own combiners:
|
||||
;; 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.
|
||||
;;
|
||||
;; $vau — primitive operative that returns a user operative
|
||||
;; $lambda — primitive operative; sugar for (wrap ($vau …))
|
||||
;; wrap — primitive applicative; wraps an operative
|
||||
;; unwrap — primitive applicative; extracts the underlying op
|
||||
;;
|
||||
;; In Kernel, $lambda is *defined* in terms of $vau and wrap:
|
||||
;; ($define! $lambda
|
||||
;; ($vau (formals . body) #ignore
|
||||
;; (wrap (eval (list $vau formals #ignore (cons $sequence body)) env))))
|
||||
;; Phase 3 supplies it natively (single-expression body) so tests can
|
||||
;; build applicatives without a working $define!/$sequence yet. The
|
||||
;; native-then-portable migration is a Phase 4 concern.
|
||||
;;
|
||||
;; The env-param sentinel
|
||||
;; ----------------------
|
||||
;; A user operative records an `:env-param` slot. If the source said
|
||||
;; `#ignore`, the slot holds the keyword :knl-ignore and kernel-call-
|
||||
;; operative skips binding the dynamic env. The parser doesn't recognise
|
||||
;; `#ignore` yet (Phase 1 covered #t/#f only); guests must spell it
|
||||
;; `_` for now — the spelling-to-sentinel conversion lives here in
|
||||
;; knl-eparam-sentinel.
|
||||
;; 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) — fresh env with $vau, $lambda, wrap, unwrap
|
||||
;;
|
||||
;; Consumes: lib/kernel/eval.sx (everything tagged kernel-*).
|
||||
;; (kernel-base-env) — Phase 3 combiners
|
||||
;; (kernel-standard-env) — Phase 4 standard environment
|
||||
|
||||
(define
|
||||
knl-eparam-sentinel
|
||||
@@ -39,7 +23,6 @@
|
||||
((= sym "#ignore") :knl-ignore)
|
||||
(:else sym))))
|
||||
|
||||
;; Validate that a formals list is a plain list of symbol names.
|
||||
(define
|
||||
knl-formals-ok?
|
||||
(fn
|
||||
@@ -51,13 +34,6 @@
|
||||
(:else false))))
|
||||
|
||||
;; ── $vau ─────────────────────────────────────────────────────────
|
||||
;; ($vau FORMALS ENV-PARAM BODY) → user operative.
|
||||
;;
|
||||
;; FORMALS — unevaluated list of parameter symbols.
|
||||
;; ENV-PARAM — symbol (or `_` / `#ignore`).
|
||||
;; BODY — single expression (Phase 3 limitation; $sequence later).
|
||||
;;
|
||||
;; The returned operative closes over the env where $vau was invoked.
|
||||
|
||||
(define
|
||||
kernel-vau-impl
|
||||
@@ -88,11 +64,6 @@
|
||||
(kernel-make-primitive-operative kernel-vau-impl))
|
||||
|
||||
;; ── $lambda ──────────────────────────────────────────────────────
|
||||
;; ($lambda FORMALS BODY) → user applicative.
|
||||
;;
|
||||
;; Equivalent to (wrap ($vau FORMALS #ignore BODY)) — args are evaluated
|
||||
;; before the operative body runs, and the operative ignores the dynamic
|
||||
;; environment.
|
||||
|
||||
(define
|
||||
kernel-lambda-impl
|
||||
@@ -115,7 +86,7 @@
|
||||
kernel-lambda-operative
|
||||
(kernel-make-primitive-operative kernel-lambda-impl))
|
||||
|
||||
;; ── wrap / unwrap as Kernel applicatives ─────────────────────────
|
||||
;; ── wrap / unwrap / predicates ───────────────────────────────────
|
||||
|
||||
(define
|
||||
kernel-wrap-applicative
|
||||
@@ -137,7 +108,6 @@
|
||||
(error "unwrap: expects exactly 1 argument"))
|
||||
(:else (kernel-unwrap (first args)))))))
|
||||
|
||||
;; Convenience predicates as applicatives too — tests want them.
|
||||
(define
|
||||
kernel-operative?-applicative
|
||||
(kernel-make-primitive-applicative
|
||||
@@ -148,10 +118,6 @@
|
||||
(kernel-make-primitive-applicative
|
||||
(fn (args) (kernel-applicative? (first args)))))
|
||||
|
||||
;; ── Base environment ─────────────────────────────────────────────
|
||||
;; A fresh env with the Phase 3 combiners bound. Standard env (Phase 4)
|
||||
;; will extend this with $if, $define!, arithmetic, list ops, etc.
|
||||
|
||||
(define
|
||||
kernel-base-env
|
||||
(fn
|
||||
@@ -165,3 +131,221 @@
|
||||
(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))))))
|
||||
|
||||
(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))))))))
|
||||
|
||||
;; ── 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 kernel-not-applicative (knl-unary-app "not" (fn (v) (not 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))))
|
||||
|
||||
(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 "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-bin-app "+" (fn (a b) (+ a b))))
|
||||
(kernel-env-bind! env "-" (knl-bin-app "-" (fn (a b) (- a b))))
|
||||
(kernel-env-bind! env "*" (knl-bin-app "*" (fn (a b) (* a b))))
|
||||
(kernel-env-bind! env "/" (knl-bin-app "/" (fn (a b) (/ a b))))
|
||||
(kernel-env-bind! env "<" (knl-bin-app "<" (fn (a b) (< a b))))
|
||||
(kernel-env-bind! env ">" (knl-bin-app ">" (fn (a b) (> a b))))
|
||||
(kernel-env-bind! env "<=?" (knl-bin-app "<=?" (fn (a b) (<= a b))))
|
||||
(kernel-env-bind! env ">=?" (knl-bin-app ">=?" (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 "not" kernel-not-applicative)
|
||||
env)))
|
||||
|
||||
257
lib/kernel/tests/standard.sx
Normal file
257
lib/kernel/tests/standard.sx
Normal file
@@ -0,0 +1,257 @@
|
||||
;; 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)
|
||||
|
||||
(define ks-tests-run! (fn () {:total (+ ks-test-pass ks-test-fail) :passed ks-test-pass :failed ks-test-fail :fails ks-test-fails}))
|
||||
Reference in New Issue
Block a user