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.
130 lines
4.3 KiB
Plaintext
130 lines
4.3 KiB
Plaintext
;; lib/guest/reflective/class-chain.sx — class inheritance walker.
|
|
;;
|
|
;; Extracted from Smalltalk's `st-method-lookup-walk` (single-parent
|
|
;; class chain for message-send dispatch) and CLOS's `clos-specificity`
|
|
;; (multi-parent class graph for method-precedence distance). Both walk
|
|
;; a class-name → parent-name(s) graph applying a probe at each node;
|
|
;; the cfg adapter normalises single-parent and multi-parent classes
|
|
;; into a uniform `:parents-of` callback that returns a (possibly
|
|
;; empty) list of parent class names.
|
|
;;
|
|
;; Adapter cfg
|
|
;; -----------
|
|
;; :parents-of — fn (class-name) → list of parent class names.
|
|
;; Empty list = no parents (root). Single-parent guests
|
|
;; return a 1-element list; multi-parent guests (CLOS)
|
|
;; may return any number.
|
|
;; :class? — fn (name) → bool. False short-circuits the walk —
|
|
;; used to skip non-existent class names mid-chain.
|
|
;;
|
|
;; Public API
|
|
;; (refl-class-chain-find-with CFG CLASS-NAME PROBE)
|
|
;; Depth-first walk from CLASS-NAME up its parent chain. At each
|
|
;; class, calls `(probe class-name)`. Returns the first non-nil
|
|
;; probe result, or nil if no class produces one. Probes evaluate
|
|
;; left-to-right across siblings in multi-parent guests.
|
|
;;
|
|
;; (refl-class-chain-depth-with CFG CLASS-NAME ANCESTOR-NAME)
|
|
;; Minimum hop count from CLASS-NAME to ANCESTOR-NAME along any
|
|
;; parent path. CLASS-NAME itself counts as depth 0. Returns nil
|
|
;; if ANCESTOR-NAME is unreachable.
|
|
;;
|
|
;; (refl-class-chain-ancestors-with CFG CLASS-NAME)
|
|
;; Flat list of all reachable ancestor names in DFS order (no
|
|
;; dedup; multi-parent guests may want to dedup themselves).
|
|
;;
|
|
;; Consumer migrations
|
|
;; -------------------
|
|
;; - Smalltalk: see `lib/smalltalk/runtime.sx` — `st-method-lookup-walk`
|
|
;; becomes a one-line probe through `refl-class-chain-find-with`.
|
|
;; - CLOS: see `lib/common-lisp/clos.sx` — `clos-specificity` becomes a
|
|
;; thin wrapper around `refl-class-chain-depth-with`.
|
|
|
|
(define
|
|
refl-find-in-parents-with
|
|
(fn
|
|
(cfg parents probe)
|
|
(cond
|
|
((or (nil? parents) (= (length parents) 0)) nil)
|
|
(:else
|
|
(let
|
|
((hit (refl-class-chain-find-with cfg (first parents) probe)))
|
|
(cond
|
|
((not (nil? hit)) hit)
|
|
(:else (refl-find-in-parents-with cfg (rest parents) probe))))))))
|
|
|
|
(define
|
|
refl-class-chain-find-with
|
|
(fn
|
|
(cfg class-name probe)
|
|
(cond
|
|
((nil? class-name) nil)
|
|
((not ((get cfg :class?) class-name)) nil)
|
|
(:else
|
|
(let
|
|
((hit (probe class-name)))
|
|
(cond
|
|
((not (nil? hit)) hit)
|
|
(:else
|
|
(refl-find-in-parents-with
|
|
cfg
|
|
((get cfg :parents-of) class-name)
|
|
probe))))))))
|
|
|
|
(define
|
|
refl-class-chain-depth-walk
|
|
(fn
|
|
(cfg cur target depth)
|
|
(cond
|
|
((= cur target) depth)
|
|
((nil? cur) nil)
|
|
((not ((get cfg :class?) cur)) nil)
|
|
(:else
|
|
(let
|
|
((parents ((get cfg :parents-of) cur)))
|
|
(let
|
|
((results (map (fn (p) (refl-class-chain-depth-walk cfg p target (+ depth 1))) parents)))
|
|
(let
|
|
((non-nil (filter (fn (x) (not (nil? x))) results)))
|
|
(cond
|
|
((or (nil? non-nil) (= (length non-nil) 0)) nil)
|
|
(:else
|
|
(reduce
|
|
(fn (a b) (if (< a b) a b))
|
|
(first non-nil)
|
|
(rest non-nil)))))))))))
|
|
|
|
(define
|
|
refl-class-chain-depth-with
|
|
(fn
|
|
(cfg class-name ancestor-name)
|
|
(refl-class-chain-depth-walk cfg class-name ancestor-name 0)))
|
|
|
|
(define
|
|
refl-class-chain-ancestors-with
|
|
(fn (cfg class-name) (refl-ancestors-walk cfg class-name (list))))
|
|
|
|
(define
|
|
refl-ancestors-walk
|
|
(fn
|
|
(cfg cn acc)
|
|
(cond
|
|
((nil? cn) acc)
|
|
((not ((get cfg :class?) cn)) acc)
|
|
(:else
|
|
(let
|
|
((parents ((get cfg :parents-of) cn)))
|
|
(refl-ancestors-walk-list cfg parents (append acc (list cn))))))))
|
|
|
|
(define
|
|
refl-ancestors-walk-list
|
|
(fn
|
|
(cfg parents acc)
|
|
(cond
|
|
((or (nil? parents) (= (length parents) 0)) acc)
|
|
(:else
|
|
(refl-ancestors-walk-list
|
|
cfg
|
|
(rest parents)
|
|
(refl-ancestors-walk cfg (first parents) acc))))))
|