giles
2981a479e8
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 35s
lib/guest/reflective/class-chain.sx — class inheritance walker with
adapter cfg for single-parent (Smalltalk) and multi-parent (CLOS)
hierarchies. Three primitives:
- refl-class-chain-find-with CFG CN PROBE
DFS through parents, returns first non-nil probe result.
Smalltalk method lookup uses this.
- refl-class-chain-depth-with CFG CN ANCESTOR
Min hop distance via any parent path, or nil if unreachable.
CLOS method specificity uses this.
- refl-class-chain-ancestors-with CFG CN
Flat DFS-ordered list of all reachable ancestor names.
Adapter cfg has two keys: :parents-of (CN → list of parent names,
possibly empty) and :class? (predicate; short-circuits walk on
non-existent class names mid-chain).
Migrations:
- lib/smalltalk/runtime.sx: st-method-lookup-walk now a 9-line
thin probe through the kit (was 20 lines of inline recursion);
st-class-cfg wraps the single-parent :superclass field into a
1-element list for the cfg.
- lib/common-lisp/clos.sx: clos-specificity is a one-line wrapper
around refl-class-chain-depth-with (was 28 lines); clos-class-cfg
reads the multi-parent :parents field.
Both consumers green:
- Smalltalk: 847/847 (unchanged)
- CL: 222/240 (unchanged baseline; 18 pre-existing failures, all
in stdlib functions like cl-set-memberp, unrelated to CLOS).
This is the second extracted reflective kit (env.sx was first).
The adapter-cfg pattern continues to bridge structurally divergent
consumers (Smalltalk single-inheritance vs CLOS multiple-inheritance
with method-precedence distance) via a uniform :parents-of callback.
485 lines
17 KiB
Plaintext
485 lines
17 KiB
Plaintext
;; lib/common-lisp/clos.sx — CLOS: classes, instances, generic functions
|
|
;;
|
|
;; Class records: {:clos-type "class" :name "NAME" :slots {...} :parents [...] :methods [...]}
|
|
;; Instance: {:clos-type "instance" :class "NAME" :slots {slot: val ...}}
|
|
;; Method: {:qualifiers [...] :specializers [...] :fn (fn (args next-fn) ...)}
|
|
;;
|
|
;; SX primitive notes:
|
|
;; dict->list: use (map (fn (k) (list k (get d k))) (keys d))
|
|
;; dict-set (pure): use assoc
|
|
;; fn?/callable?: use callable?
|
|
|
|
;; ── dict helpers ───────────────────────────────────────────────────────────
|
|
|
|
(define
|
|
clos-dict->list
|
|
(fn (d) (map (fn (k) (list k (get d k))) (keys d))))
|
|
|
|
;; ── class registry ─────────────────────────────────────────────────────────
|
|
|
|
(define
|
|
clos-class-registry
|
|
(dict
|
|
"t"
|
|
{:parents (list) :clos-type "class" :slots (dict) :methods (list) :name "t"}
|
|
"null"
|
|
{:parents (list "t") :clos-type "class" :slots (dict) :methods (list) :name "null"}
|
|
"integer"
|
|
{:parents (list "t") :clos-type "class" :slots (dict) :methods (list) :name "integer"}
|
|
"float"
|
|
{:parents (list "t") :clos-type "class" :slots (dict) :methods (list) :name "float"}
|
|
"string"
|
|
{:parents (list "t") :clos-type "class" :slots (dict) :methods (list) :name "string"}
|
|
"symbol"
|
|
{:parents (list "t") :clos-type "class" :slots (dict) :methods (list) :name "symbol"}
|
|
"cons"
|
|
{:parents (list "t") :clos-type "class" :slots (dict) :methods (list) :name "cons"}
|
|
"list"
|
|
{:parents (list "t") :clos-type "class" :slots (dict) :methods (list) :name "list"}))
|
|
|
|
;; ── clos-generic-registry ─────────────────────────────────────────────────
|
|
|
|
(define clos-generic-registry (dict))
|
|
|
|
;; ── class-of ──────────────────────────────────────────────────────────────
|
|
|
|
(define
|
|
clos-class-of
|
|
(fn
|
|
(x)
|
|
(cond
|
|
((nil? x) "null")
|
|
((integer? x) "integer")
|
|
((float? x) "float")
|
|
((string? x) "string")
|
|
((symbol? x) "symbol")
|
|
((and (list? x) (> (len x) 0)) "cons")
|
|
((and (list? x) (= (len x) 0)) "null")
|
|
((and (dict? x) (= (get x "clos-type") "instance")) (get x "class"))
|
|
(:else "t"))))
|
|
|
|
;; ── subclass-of? ──────────────────────────────────────────────────────────
|
|
;;
|
|
;; Captures clos-class-registry at define time to avoid free-variable issues.
|
|
|
|
(define
|
|
clos-subclass-of?
|
|
(let
|
|
((registry clos-class-registry))
|
|
(fn
|
|
(class-name super-name)
|
|
(if
|
|
(= class-name super-name)
|
|
true
|
|
(let
|
|
((rec (get registry class-name)))
|
|
(if
|
|
(nil? rec)
|
|
false
|
|
(some
|
|
(fn (p) (clos-subclass-of? p super-name))
|
|
(get rec "parents"))))))))
|
|
|
|
;; ── instance-of? ──────────────────────────────────────────────────────────
|
|
|
|
(define
|
|
clos-instance-of?
|
|
(fn (obj class-name) (clos-subclass-of? (clos-class-of obj) class-name)))
|
|
|
|
;; ── defclass ──────────────────────────────────────────────────────────────
|
|
;;
|
|
;; slot-specs: list of dicts with keys: name initarg initform accessor reader writer
|
|
;; Each missing key defaults to nil.
|
|
|
|
(define clos-slot-spec (fn (spec) (if (string? spec) {:initform nil :initarg nil :reader nil :writer nil :accessor nil :name spec} spec)))
|
|
|
|
(define
|
|
clos-defclass
|
|
(fn
|
|
(name parents slot-specs)
|
|
(let
|
|
((slots (dict)))
|
|
(for-each
|
|
(fn
|
|
(pname)
|
|
(let
|
|
((prec (get clos-class-registry pname)))
|
|
(when
|
|
(not (nil? prec))
|
|
(for-each
|
|
(fn
|
|
(k)
|
|
(when
|
|
(nil? (get slots k))
|
|
(dict-set! slots k (get (get prec "slots") k))))
|
|
(keys (get prec "slots"))))))
|
|
parents)
|
|
(for-each
|
|
(fn
|
|
(s)
|
|
(let
|
|
((spec (clos-slot-spec s)))
|
|
(dict-set! slots (get spec "name") spec)))
|
|
slot-specs)
|
|
(let
|
|
((class-rec {:parents parents :clos-type "class" :slots slots :methods (list) :name name}))
|
|
(dict-set! clos-class-registry name class-rec)
|
|
(clos-install-accessors-for name slots)
|
|
name))))
|
|
|
|
;; ── accessor installation (forward-declared, defined after defmethod) ──────
|
|
|
|
(define
|
|
clos-install-accessors-for
|
|
(fn
|
|
(class-name slots)
|
|
(for-each
|
|
(fn
|
|
(k)
|
|
(let
|
|
((spec (get slots k)))
|
|
(let
|
|
((reader (get spec "reader")))
|
|
(when
|
|
(not (nil? reader))
|
|
(clos-add-reader-method reader class-name k)))
|
|
(let
|
|
((accessor (get spec "accessor")))
|
|
(when
|
|
(not (nil? accessor))
|
|
(clos-add-reader-method accessor class-name k)))))
|
|
(keys slots))))
|
|
|
|
;; placeholder — real impl filled in after defmethod is defined
|
|
(define clos-add-reader-method (fn (method-name class-name slot-name) nil))
|
|
|
|
;; ── make-instance ─────────────────────────────────────────────────────────
|
|
|
|
(define
|
|
clos-make-instance
|
|
(fn
|
|
(class-name &rest initargs)
|
|
(let
|
|
((class-rec (get clos-class-registry class-name)))
|
|
(if
|
|
(nil? class-rec)
|
|
(error (str "No class named: " class-name))
|
|
(let
|
|
((slots (dict)))
|
|
(for-each
|
|
(fn
|
|
(k)
|
|
(let
|
|
((spec (get (get class-rec "slots") k)))
|
|
(let
|
|
((initform (get spec "initform")))
|
|
(when
|
|
(not (nil? initform))
|
|
(dict-set!
|
|
slots
|
|
k
|
|
(if (callable? initform) (initform) initform))))))
|
|
(keys (get class-rec "slots")))
|
|
(define
|
|
apply-args
|
|
(fn
|
|
(args)
|
|
(when
|
|
(>= (len args) 2)
|
|
(let
|
|
((key (str (first args))) (val (first (rest args))))
|
|
(let
|
|
((skey (if (= (slice key 0 1) ":") (slice key 1 (len key)) key)))
|
|
(let
|
|
((matched false))
|
|
(for-each
|
|
(fn
|
|
(sk)
|
|
(let
|
|
((spec (get (get class-rec "slots") sk)))
|
|
(let
|
|
((ia (get spec "initarg")))
|
|
(when
|
|
(or
|
|
(= ia key)
|
|
(= ia (str ":" skey))
|
|
(= sk skey))
|
|
(dict-set! slots sk val)
|
|
(set! matched true)))))
|
|
(keys (get class-rec "slots")))))
|
|
(apply-args (rest (rest args)))))))
|
|
(apply-args initargs)
|
|
{:clos-type "instance" :slots slots :class class-name})))))
|
|
|
|
;; ── slot-value ────────────────────────────────────────────────────────────
|
|
|
|
(define
|
|
clos-slot-value
|
|
(fn
|
|
(instance slot-name)
|
|
(if
|
|
(and (dict? instance) (= (get instance "clos-type") "instance"))
|
|
(get (get instance "slots") slot-name)
|
|
(error (str "Not a CLOS instance: " (inspect instance))))))
|
|
|
|
(define
|
|
clos-set-slot-value!
|
|
(fn
|
|
(instance slot-name value)
|
|
(if
|
|
(and (dict? instance) (= (get instance "clos-type") "instance"))
|
|
(dict-set! (get instance "slots") slot-name value)
|
|
(error (str "Not a CLOS instance: " (inspect instance))))))
|
|
|
|
(define
|
|
clos-slot-boundp
|
|
(fn
|
|
(instance slot-name)
|
|
(and
|
|
(dict? instance)
|
|
(= (get instance "clos-type") "instance")
|
|
(not (nil? (get (get instance "slots") slot-name))))))
|
|
|
|
;; ── find-class / change-class ─────────────────────────────────────────────
|
|
|
|
(define clos-find-class (fn (name) (get clos-class-registry name)))
|
|
|
|
(define
|
|
clos-change-class!
|
|
(fn
|
|
(instance new-class-name)
|
|
(if
|
|
(and (dict? instance) (= (get instance "clos-type") "instance"))
|
|
(dict-set! instance "class" new-class-name)
|
|
(error (str "Not a CLOS instance: " (inspect instance))))))
|
|
|
|
;; ── defgeneric ────────────────────────────────────────────────────────────
|
|
|
|
(define
|
|
clos-defgeneric
|
|
(fn
|
|
(name options)
|
|
(let
|
|
((combination (or (get options "method-combination") "standard")))
|
|
(when
|
|
(nil? (get clos-generic-registry name))
|
|
(dict-set! clos-generic-registry name {:methods (list) :combination combination :name name}))
|
|
name)))
|
|
|
|
;; ── defmethod ─────────────────────────────────────────────────────────────
|
|
;;
|
|
;; method-fn: (fn (args next-fn) body)
|
|
;; args = list of all call arguments
|
|
;; next-fn = (fn () next-method-result) or nil
|
|
|
|
(define
|
|
clos-defmethod
|
|
(fn
|
|
(generic-name qualifiers specializers method-fn)
|
|
(when
|
|
(nil? (get clos-generic-registry generic-name))
|
|
(clos-defgeneric generic-name {}))
|
|
(let
|
|
((grec (get clos-generic-registry generic-name))
|
|
(new-method {:fn method-fn :qualifiers qualifiers :specializers specializers}))
|
|
(let
|
|
((kept (filter (fn (m) (not (and (= (get m "qualifiers") qualifiers) (= (get m "specializers") specializers)))) (get grec "methods"))))
|
|
(dict-set!
|
|
clos-generic-registry
|
|
generic-name
|
|
(assoc grec "methods" (append kept (list new-method))))
|
|
generic-name))))
|
|
|
|
;; Now install the real accessor-method installer
|
|
(set!
|
|
clos-add-reader-method
|
|
(fn
|
|
(method-name class-name slot-name)
|
|
(clos-defmethod
|
|
method-name
|
|
(list)
|
|
(list class-name)
|
|
(fn (args next-fn) (clos-slot-value (first args) slot-name)))))
|
|
|
|
;; ── method specificity ─────────────────────────────────────────────────────
|
|
|
|
(define
|
|
clos-method-matches?
|
|
(fn
|
|
(method args)
|
|
(let
|
|
((specs (get method "specializers")))
|
|
(if
|
|
(> (len specs) (len args))
|
|
false
|
|
(define
|
|
check-all
|
|
(fn
|
|
(i)
|
|
(if
|
|
(>= i (len specs))
|
|
true
|
|
(let
|
|
((spec (nth specs i)) (arg (nth args i)))
|
|
(if
|
|
(= spec "t")
|
|
(check-all (+ i 1))
|
|
(if
|
|
(clos-instance-of? arg spec)
|
|
(check-all (+ i 1))
|
|
false))))))
|
|
(check-all 0)))))
|
|
|
|
;; CLOS-side adapter for lib/guest/reflective/class-chain.sx. Classes
|
|
;; live in clos-class-registry; :parents is a list of parent class
|
|
;; names (CLOS supports multiple inheritance).
|
|
(define clos-class-cfg
|
|
{:parents-of (fn (cn)
|
|
(let ((rec (clos-find-class cn)))
|
|
(cond ((nil? rec) (list))
|
|
(:else (or (get rec "parents") (list))))))
|
|
:class? (fn (n) (not (nil? (clos-find-class n))))})
|
|
|
|
;; Precedence distance: how far class-name is from spec-name up the
|
|
;; hierarchy. Delegates to refl-class-chain-depth-with which handles
|
|
;; the multi-parent DFS with min-depth selection.
|
|
(define clos-specificity
|
|
(fn (class-name spec-name)
|
|
(refl-class-chain-depth-with clos-class-cfg class-name spec-name)))
|
|
|
|
(define
|
|
clos-method-more-specific?
|
|
(fn
|
|
(m1 m2 args)
|
|
(let
|
|
((s1 (get m1 "specializers")) (s2 (get m2 "specializers")))
|
|
(define
|
|
cmp
|
|
(fn
|
|
(i)
|
|
(if
|
|
(>= i (len s1))
|
|
false
|
|
(let
|
|
((c1 (clos-specificity (clos-class-of (nth args i)) (nth s1 i)))
|
|
(c2
|
|
(clos-specificity (clos-class-of (nth args i)) (nth s2 i))))
|
|
(cond
|
|
((and (nil? c1) (nil? c2)) (cmp (+ i 1)))
|
|
((nil? c1) false)
|
|
((nil? c2) true)
|
|
((< c1 c2) true)
|
|
((> c1 c2) false)
|
|
(:else (cmp (+ i 1))))))))
|
|
(cmp 0))))
|
|
|
|
(define
|
|
clos-sort-methods
|
|
(fn
|
|
(methods args)
|
|
(define
|
|
insert
|
|
(fn
|
|
(m sorted)
|
|
(if
|
|
(empty? sorted)
|
|
(list m)
|
|
(if
|
|
(clos-method-more-specific? m (first sorted) args)
|
|
(cons m sorted)
|
|
(cons (first sorted) (insert m (rest sorted)))))))
|
|
(reduce (fn (acc m) (insert m acc)) (list) methods)))
|
|
|
|
;; ── call-generic (standard method combination) ─────────────────────────────
|
|
|
|
(define
|
|
clos-call-generic
|
|
(fn
|
|
(generic-name args)
|
|
(let
|
|
((grec (get clos-generic-registry generic-name)))
|
|
(if
|
|
(nil? grec)
|
|
(error (str "No generic function: " generic-name))
|
|
(let
|
|
((applicable (filter (fn (m) (clos-method-matches? m args)) (get grec "methods"))))
|
|
(if
|
|
(empty? applicable)
|
|
(error
|
|
(str
|
|
"No applicable method for "
|
|
generic-name
|
|
" with classes "
|
|
(inspect (map clos-class-of args))))
|
|
(let
|
|
((primary (filter (fn (m) (empty? (get m "qualifiers"))) applicable))
|
|
(before
|
|
(filter
|
|
(fn (m) (= (get m "qualifiers") (list "before")))
|
|
applicable))
|
|
(after
|
|
(filter
|
|
(fn (m) (= (get m "qualifiers") (list "after")))
|
|
applicable))
|
|
(around
|
|
(filter
|
|
(fn (m) (= (get m "qualifiers") (list "around")))
|
|
applicable)))
|
|
(let
|
|
((sp (clos-sort-methods primary args))
|
|
(sb (clos-sort-methods before args))
|
|
(sa (clos-sort-methods after args))
|
|
(sw (clos-sort-methods around args)))
|
|
(define
|
|
make-primary-chain
|
|
(fn
|
|
(methods)
|
|
(if
|
|
(empty? methods)
|
|
(fn
|
|
()
|
|
(error (str "No next primary method: " generic-name)))
|
|
(fn
|
|
()
|
|
((get (first methods) "fn")
|
|
args
|
|
(make-primary-chain (rest methods)))))))
|
|
(define
|
|
make-around-chain
|
|
(fn
|
|
(around-methods inner-thunk)
|
|
(if
|
|
(empty? around-methods)
|
|
inner-thunk
|
|
(fn
|
|
()
|
|
((get (first around-methods) "fn")
|
|
args
|
|
(make-around-chain
|
|
(rest around-methods)
|
|
inner-thunk))))))
|
|
(for-each (fn (m) ((get m "fn") args (fn () nil))) sb)
|
|
(let
|
|
((primary-thunk (make-primary-chain sp)))
|
|
(let
|
|
((result (if (empty? sw) (primary-thunk) ((make-around-chain sw primary-thunk)))))
|
|
(for-each
|
|
(fn (m) ((get m "fn") args (fn () nil)))
|
|
(reverse sa))
|
|
result))))))))))
|
|
|
|
;; ── call-next-method / next-method-p ──────────────────────────────────────
|
|
|
|
(define clos-call-next-method (fn (next-fn) (next-fn)))
|
|
|
|
(define clos-next-method-p (fn (next-fn) (not (nil? next-fn))))
|
|
|
|
;; ── with-slots ────────────────────────────────────────────────────────────
|
|
|
|
(define
|
|
clos-with-slots
|
|
(fn
|
|
(instance slot-names body-fn)
|
|
(let
|
|
((vals (map (fn (s) (clos-slot-value instance s)) slot-names)))
|
|
(apply body-fn vals)))) |