Merge lib/tcl/uplevel into architecture: kernel + reflective env extraction (Phase 1-7 kernel, 322+427 tests)
This commit is contained in:
138
lib/guest/reflective/env.sx
Normal file
138
lib/guest/reflective/env.sx
Normal file
@@ -0,0 +1,138 @@
|
||||
;; lib/guest/reflective/env.sx — first-class environment kit.
|
||||
;;
|
||||
;; Extracted from Kernel-on-SX (lib/kernel/eval.sx) when Tcl's
|
||||
;; uplevel/upvar machinery (lib/tcl/runtime.sx) materialised as a
|
||||
;; second consumer needing the same scope-chain semantics.
|
||||
;;
|
||||
;; Canonical wire shape
|
||||
;; --------------------
|
||||
;; {:refl-tag :env :bindings DICT :parent ENV-OR-NIL}
|
||||
;;
|
||||
;; - :bindings is a mutable SX dict keyed by symbol name.
|
||||
;; - :parent is either another env or nil (root).
|
||||
;; - Lookup walks the parent chain until a hit or nil.
|
||||
;; - Default cfg uses dict-set! to mutate bindings in place.
|
||||
;;
|
||||
;; Consumers with their own shape (e.g., Tcl's {:level :locals :parent})
|
||||
;; pass an adapter cfg dict — same trick as lib/guest/match.sx's cfg
|
||||
;; for unification over guest-specific term shapes.
|
||||
;;
|
||||
;; Adapter cfg keys
|
||||
;; ----------------
|
||||
;; :bindings-of — fn (scope) → DICT
|
||||
;; :parent-of — fn (scope) → SCOPE-OR-NIL
|
||||
;; :extend — fn (scope) → SCOPE (push a fresh child)
|
||||
;; :bind! — fn (scope name val) → scope (functional or mutable)
|
||||
;; :env? — fn (v) → bool (predicate; cheap shape check)
|
||||
;;
|
||||
;; Public API — canonical shape, mutable, raises on miss
|
||||
;;
|
||||
;; (refl-make-env)
|
||||
;; (refl-extend-env PARENT)
|
||||
;; (refl-env? V)
|
||||
;; (refl-env-bind! ENV NAME VAL)
|
||||
;; (refl-env-has? ENV NAME)
|
||||
;; (refl-env-lookup ENV NAME)
|
||||
;; (refl-env-lookup-or-nil ENV NAME)
|
||||
;;
|
||||
;; Public API — adapter-cfg, any shape
|
||||
;;
|
||||
;; (refl-env-extend-with CFG SCOPE)
|
||||
;; (refl-env-bind!-with CFG SCOPE NAME VAL)
|
||||
;; (refl-env-has?-with CFG SCOPE NAME)
|
||||
;; (refl-env-lookup-with CFG SCOPE NAME)
|
||||
;; (refl-env-lookup-or-nil-with CFG SCOPE NAME)
|
||||
;;
|
||||
;; (refl-canonical-cfg) — the default cfg, exposed so consumers
|
||||
;; can compare or extend it.
|
||||
|
||||
;; ── Canonical-shape predicates and constructors ─────────────────
|
||||
|
||||
(define refl-env? (fn (v) (and (dict? v) (= (get v :refl-tag) :env))))
|
||||
|
||||
(define refl-make-env (fn () {:parent nil :refl-tag :env :bindings {}}))
|
||||
|
||||
(define refl-extend-env (fn (parent) {:parent parent :refl-tag :env :bindings {}}))
|
||||
|
||||
(define
|
||||
refl-env-bind!
|
||||
(fn (env name val) (dict-set! (get env :bindings) name val) env))
|
||||
|
||||
(define
|
||||
refl-env-has?
|
||||
(fn
|
||||
(env name)
|
||||
(cond
|
||||
((nil? env) false)
|
||||
((not (refl-env? env)) false)
|
||||
((dict-has? (get env :bindings) name) true)
|
||||
(:else (refl-env-has? (get env :parent) name)))))
|
||||
|
||||
(define
|
||||
refl-env-lookup
|
||||
(fn
|
||||
(env name)
|
||||
(cond
|
||||
((nil? env) (error (str "refl-env-lookup: unbound symbol: " name)))
|
||||
((not (refl-env? env))
|
||||
(error (str "refl-env-lookup: corrupt env: " env)))
|
||||
((dict-has? (get env :bindings) name) (get (get env :bindings) name))
|
||||
(:else (refl-env-lookup (get env :parent) name)))))
|
||||
|
||||
(define
|
||||
refl-env-lookup-or-nil
|
||||
(fn
|
||||
(env name)
|
||||
(cond
|
||||
((nil? env) nil)
|
||||
((not (refl-env? env)) nil)
|
||||
((dict-has? (get env :bindings) name) (get (get env :bindings) name))
|
||||
(:else (refl-env-lookup-or-nil (get env :parent) name)))))
|
||||
|
||||
;; ── Adapter-cfg variants — any wire shape ───────────────────────
|
||||
|
||||
(define refl-env-extend-with (fn (cfg scope) ((get cfg :extend) scope)))
|
||||
|
||||
(define
|
||||
refl-env-bind!-with
|
||||
(fn (cfg scope name val) ((get cfg :bind!) scope name val)))
|
||||
|
||||
(define
|
||||
refl-env-has?-with
|
||||
(fn
|
||||
(cfg scope name)
|
||||
(cond
|
||||
((nil? scope) false)
|
||||
((not ((get cfg :env?) scope)) false)
|
||||
((dict-has? ((get cfg :bindings-of) scope) name) true)
|
||||
(:else (refl-env-has?-with cfg ((get cfg :parent-of) scope) name)))))
|
||||
|
||||
(define
|
||||
refl-env-lookup-with
|
||||
(fn
|
||||
(cfg scope name)
|
||||
(cond
|
||||
((nil? scope) (error (str "refl-env-lookup: unbound symbol: " name)))
|
||||
((not ((get cfg :env?) scope))
|
||||
(error (str "refl-env-lookup: corrupt scope: " scope)))
|
||||
((dict-has? ((get cfg :bindings-of) scope) name)
|
||||
(get ((get cfg :bindings-of) scope) name))
|
||||
(:else (refl-env-lookup-with cfg ((get cfg :parent-of) scope) name)))))
|
||||
|
||||
(define
|
||||
refl-env-lookup-or-nil-with
|
||||
(fn
|
||||
(cfg scope name)
|
||||
(cond
|
||||
((nil? scope) nil)
|
||||
((not ((get cfg :env?) scope)) nil)
|
||||
((dict-has? ((get cfg :bindings-of) scope) name)
|
||||
(get ((get cfg :bindings-of) scope) name))
|
||||
(:else
|
||||
(refl-env-lookup-or-nil-with cfg ((get cfg :parent-of) scope) name)))))
|
||||
|
||||
;; ── Default canonical cfg ───────────────────────────────────────
|
||||
;; Exposed so consumers can use it explicitly, compose with it, or
|
||||
;; check adapter-correctness against the canonical implementation.
|
||||
|
||||
(define refl-canonical-cfg {:bind! (fn (e n v) (refl-env-bind! e n v)) :parent-of (fn (e) (get e :parent)) :env? (fn (v) (refl-env? v)) :bindings-of (fn (e) (get e :bindings)) :extend (fn (e) (refl-extend-env e))})
|
||||
214
lib/kernel/eval.sx
Normal file
214
lib/kernel/eval.sx
Normal file
@@ -0,0 +1,214 @@
|
||||
;; 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
|
||||
;; -------------
|
||||
;; {:refl-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. Shape
|
||||
;; and operations are inherited from lib/guest/reflective/env.sx
|
||||
;; (canonical wire shape) — Kernel-side names are thin wrappers.
|
||||
;;
|
||||
;; {: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 — delegated to lib/guest/reflective/env.sx ──────
|
||||
;; The env values themselves now carry `:refl-tag :env` (shared with the
|
||||
;; reflective kit). Kernel's API names stay; bodies are thin wrappers.
|
||||
|
||||
(define kernel-env? refl-env?)
|
||||
(define kernel-make-env refl-make-env)
|
||||
(define kernel-extend-env refl-extend-env)
|
||||
(define kernel-env-bind! refl-env-bind!)
|
||||
(define kernel-env-has? refl-env-has?)
|
||||
(define kernel-env-lookup refl-env-lookup)
|
||||
|
||||
;; ── 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
253
lib/kernel/parser.sx
Normal 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
911
lib/kernel/runtime.sx
Normal file
@@ -0,0 +1,911 @@
|
||||
;; lib/kernel/runtime.sx — the operative–applicative 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
183
lib/kernel/tests/encap.sx
Normal 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
270
lib/kernel/tests/eval.sx
Normal 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
220
lib/kernel/tests/hygiene.sx
Normal 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}))
|
||||
162
lib/kernel/tests/metacircular.sx
Normal file
162
lib/kernel/tests/metacircular.sx
Normal 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
158
lib/kernel/tests/parse.sx
Normal 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}))
|
||||
445
lib/kernel/tests/standard.sx
Normal file
445
lib/kernel/tests/standard.sx
Normal 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
309
lib/kernel/tests/vau.sx
Normal 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}))
|
||||
@@ -69,6 +69,7 @@ for tcl_file in "${TCL_FILES[@]}"; do
|
||||
(epoch 2)
|
||||
(load "lib/tcl/parser.sx")
|
||||
(epoch 3)
|
||||
(load "lib/guest/reflective/env.sx")
|
||||
(load "lib/tcl/runtime.sx")
|
||||
(epoch 4)
|
||||
(load "$helper")
|
||||
|
||||
@@ -1,25 +1,33 @@
|
||||
; Tcl-on-SX runtime evaluator
|
||||
; State: {:frame frame :commands cmd-table :result last-result :output accumulated-output}
|
||||
; Requires lib/fiber.sx to be loaded first (provides make-fiber, fiber-resume, fiber-done?)
|
||||
; Requires lib/fiber.sx and lib/guest/reflective/env.sx to be loaded first.
|
||||
;
|
||||
; Frames keep their Tcl-specific shape ({:level :locals :parent}) but
|
||||
; route lookup/bind through the shared reflective env kit via the
|
||||
; adapter cfg below — second consumer for that kit alongside Kernel.
|
||||
|
||||
(define make-frame (fn (level parent) {:level level :locals {} :parent parent}))
|
||||
|
||||
(define
|
||||
frame-lookup
|
||||
(fn
|
||||
(frame name)
|
||||
(if
|
||||
(nil? frame)
|
||||
nil
|
||||
(let
|
||||
((val (get (get frame :locals) name)))
|
||||
(if (nil? val) (frame-lookup (get frame :parent) name) val)))))
|
||||
; Tcl-side adapter for lib/guest/reflective/env.sx. Frames are
|
||||
; functionally updated (assoc returns a fresh dict), and lookup-miss
|
||||
; returns nil (Tcl convention) — the *-with kit honours both.
|
||||
(define tcl-frame-cfg
|
||||
{:bindings-of (fn (f) (get f :locals))
|
||||
:parent-of (fn (f) (get f :parent))
|
||||
:extend (fn (f) (make-frame (+ (get f :level) 1) f))
|
||||
:bind! (fn (f n v) (assoc f :locals (assoc (get f :locals) n v)))
|
||||
:env? (fn (v)
|
||||
(and (dict? v)
|
||||
(number? (get v :level))
|
||||
(dict? (get v :locals))))})
|
||||
|
||||
(define
|
||||
frame-set-top
|
||||
(fn
|
||||
(frame name val)
|
||||
(assoc frame :locals (assoc (get frame :locals) name val))))
|
||||
(define frame-lookup
|
||||
(fn (frame name)
|
||||
(refl-env-lookup-or-nil-with tcl-frame-cfg frame name)))
|
||||
|
||||
(define frame-set-top
|
||||
(fn (frame name val)
|
||||
(refl-env-bind!-with tcl-frame-cfg frame name val)))
|
||||
|
||||
(define make-tcl-interp (fn () {:result "" :output "" :code 0 :errorinfo "" :errorcode "" :frame (make-frame 0 nil) :frame-stack (list) :procs {} :commands {} :current-ns "::" :coro-yield-fn nil}))
|
||||
|
||||
|
||||
@@ -42,6 +42,7 @@ cat > "$TMPFILE" << EPOCHS
|
||||
(load "lib/tcl/tests/parse.sx")
|
||||
(epoch 4)
|
||||
(load "lib/fiber.sx")
|
||||
(load "lib/guest/reflective/env.sx")
|
||||
(load "lib/tcl/runtime.sx")
|
||||
(epoch 5)
|
||||
(load "lib/tcl/tests/eval.sx")
|
||||
|
||||
Reference in New Issue
Block a user