rose-ash/lib/kernel/runtime.sx

;; 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
      ((not (= (length args) 3))
        (error "$vau: expects (formals env-param body)"))
      (:else
        (let
          ((formals (first args))
            (eparam-raw (nth args 1))
            (body (nth args 2)))
          (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
                dyn-env))))))))

(define
  kernel-vau-operative
  (kernel-make-primitive-operative kernel-vau-impl))

;; ── $lambda ──────────────────────────────────────────────────────

(define
  kernel-lambda-impl
  (fn
    (args dyn-env)
    (cond
      ((not (= (length args) 2))
        (error "$lambda: expects (formals body)"))
      (:else
        (let
          ((formals (first args)) (body (nth args 1)))
          (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 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))))))

(define
  kernel-eval-applicative
  (kernel-make-primitive-applicative
    (fn
      (args)
      (cond
        ((not (= (length args) 2))
          (error "eval: expects (expr env)"))
        ((not (kernel-env? (nth args 1)))
          (error "eval: second arg must be a kernel env"))
        (:else (kernel-eval (first args) (nth args 1)))))))

(define
  kernel-make-environment-applicative
  (kernel-make-primitive-applicative
    (fn
      (args)
      (cond
        ((= (length args) 0) (kernel-make-env))
        ((= (length args) 1)
          (cond
            ((not (kernel-env? (first args)))
              (error "make-environment: parent must be a kernel env"))
            (:else (kernel-extend-env (first args)))))
        (:else (error "make-environment: 0 or 1 argument"))))))

;; ── arithmetic and comparison (binary; trivial to extend later) ─

(define
  kernel-get-current-env-operative
  (kernel-make-primitive-operative
    (fn
      (args dyn-env)
      (cond
        ((not (= (length args) 0))
          (error "get-current-environment: expects 0 arguments"))
        (:else dyn-env)))))

(define
  knl-bin-app
  (fn
    (name f)
    (kernel-make-primitive-applicative
      (fn
        (args)
        (cond
          ((not (= (length args) 2))
            (error (str name ": expects 2 arguments")))
          (:else (f (first args) (nth args 1))))))))

;; ── list / pair primitives ──────────────────────────────────────

(define
  knl-unary-app
  (fn
    (name f)
    (kernel-make-primitive-applicative
      (fn
        (args)
        (cond
          ((not (= (length args) 1))
            (error (str name ": expects 1 argument")))
          (:else (f (first args))))))))

(define kernel-cons-applicative (knl-bin-app "cons" (fn (a b) (cons a b))))

(define
  kernel-car-applicative
  (knl-unary-app
    "car"
    (fn
      (xs)
      (cond
        ((or (nil? xs) (and (list? xs) (= (length xs) 0)))
          (error "car: empty list"))
        (:else (first xs))))))

(define
  kernel-cdr-applicative
  (knl-unary-app
    "cdr"
    (fn
      (xs)
      (cond
        ((or (nil? xs) (and (list? xs) (= (length xs) 0)))
          (error "cdr: empty list"))
        (:else (rest xs))))))

(define
  kernel-list-applicative
  (kernel-make-primitive-applicative (fn (args) args)))

(define
  kernel-length-applicative
  (knl-unary-app "length" (fn (xs) (length xs))))

(define
  kernel-null?-applicative
  (knl-unary-app
    "null?"
    (fn (v) (or (nil? v) (and (list? v) (= (length v) 0))))))

;; ── boolean / equality ──────────────────────────────────────────

(define
  kernel-pair?-applicative
  (knl-unary-app
    "pair?"
    (fn (v) (and (list? v) (> (length v) 0)))))

(define kernel-not-applicative (knl-unary-app "not" (fn (v) (not v))))

(define kernel-eq?-applicative (knl-bin-app "eq?" (fn (a b) (= a b))))

;; ── the standard environment ────────────────────────────────────

(define
  kernel-equal?-applicative
  (knl-bin-app "equal?" (fn (a b) (= a b))))

(define
  kernel-standard-env
  (fn
    ()
    (let
      ((env (kernel-base-env)))
      (kernel-env-bind! env "$if" kernel-if-operative)
      (kernel-env-bind! env "$define!" kernel-define!-operative)
      (kernel-env-bind! env "$sequence" kernel-sequence-operative)
      (kernel-env-bind! env "$quote"    kernel-quote-operative)
      (kernel-env-bind! env "eval" kernel-eval-applicative)
      (kernel-env-bind!
        env
        "make-environment"
        kernel-make-environment-applicative)
      (kernel-env-bind!
        env
        "get-current-environment"
        kernel-get-current-env-operative)
      (kernel-env-bind! env "+" (knl-bin-app "+" (fn (a b) (+ a b))))
      (kernel-env-bind! env "-" (knl-bin-app "-" (fn (a b) (- a b))))
      (kernel-env-bind! env "*" (knl-bin-app "*" (fn (a b) (* a b))))
      (kernel-env-bind! env "/" (knl-bin-app "/" (fn (a b) (/ a b))))
      (kernel-env-bind! env "<" (knl-bin-app "<" (fn (a b) (< a b))))
      (kernel-env-bind! env ">" (knl-bin-app ">" (fn (a b) (> a b))))
      (kernel-env-bind! env "<=?" (knl-bin-app "<=?" (fn (a b) (<= a b))))
      (kernel-env-bind! env ">=?" (knl-bin-app ">=?" (fn (a b) (>= a b))))
      (kernel-env-bind! env "=?" kernel-eq?-applicative)
      (kernel-env-bind! env "equal?" kernel-equal?-applicative)
      (kernel-env-bind! env "eq?" kernel-eq?-applicative)
      (kernel-env-bind! env "cons" kernel-cons-applicative)
      (kernel-env-bind! env "car" kernel-car-applicative)
      (kernel-env-bind! env "cdr" kernel-cdr-applicative)
      (kernel-env-bind! env "list" kernel-list-applicative)
      (kernel-env-bind! env "length" kernel-length-applicative)
      (kernel-env-bind! env "null?" kernel-null?-applicative)
      (kernel-env-bind! env "pair?" kernel-pair?-applicative)
      (kernel-env-bind! env "not" kernel-not-applicative)
      env)))