rose-ash/lib/kernel/tests/metacircular.sx

;; 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-suite (refl-make-test-suite))
(define kmc-test  (fn (n a e) (refl-test kmc-suite n a e)))

;; 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 () (refl-test-report kmc-suite)))