reflective: extract class-chain.sx — Smalltalk + CLOS method dispatch share parent-walk

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.
2026-05-12 21:09:07 +00:00
parent 9efbf4ad38
commit 2981a479e8
6 changed files with 177 additions and 53 deletions
--- a/lib/common-lisp/clos.sx
+++ b/lib/common-lisp/clos.sx
@@ -330,37 +330,22 @@
                    false))))))
        (check-all 0)))))

-;; Precedence distance: how far class-name is from spec-name up the hierarchy.
-(define
-  clos-specificity
-  (let
-    ((registry clos-class-registry))
-    (fn
-      (class-name spec-name)
-      (define
-        walk
-        (fn
-          (cn depth)
-          (if
-            (= cn spec-name)
-            depth
-            (let
-              ((rec (get registry cn)))
-              (if
-                (nil? rec)
-                nil
-                (let
-                  ((results (map (fn (p) (walk p (+ depth 1))) (get rec "parents"))))
-                  (let
-                    ((non-nil (filter (fn (x) (not (nil? x))) results)))
-                    (if
-                      (empty? non-nil)
-                      nil
-                      (reduce
-                        (fn (a b) (if (< a b) a b))
-                        (first non-nil)
-                        (rest non-nil))))))))))
-      (walk class-name 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?
--- a/lib/common-lisp/test.sh
+++ b/lib/common-lisp/test.sh
@@ -368,7 +368,7 @@ run_program_suite \

 # ── Phase 4: CLOS unit tests ─────────────────────────────────────────────────
 CLOS_FILE=$(mktemp); trap "rm -f $CLOS_FILE" EXIT
-printf '(epoch 1)\n(load "spec/stdlib.sx")\n(epoch 2)\n(load "lib/common-lisp/runtime.sx")\n(epoch 3)\n(load "lib/common-lisp/clos.sx")\n(epoch 4)\n(load "lib/common-lisp/tests/clos.sx")\n(epoch 5)\n(eval "passed")\n(epoch 6)\n(eval "failed")\n(epoch 7)\n(eval "failures")\n' > "$CLOS_FILE"
+printf '(epoch 1)\n(load "spec/stdlib.sx")\n(epoch 2)\n(load "lib/common-lisp/runtime.sx")\n(epoch 3)\n(load "lib/guest/reflective/class-chain.sx")\n(load "lib/common-lisp/clos.sx")\n(epoch 4)\n(load "lib/common-lisp/tests/clos.sx")\n(epoch 5)\n(eval "passed")\n(epoch 6)\n(eval "failed")\n(epoch 7)\n(eval "failures")\n' > "$CLOS_FILE"
 CLOS_OUT=$(timeout 30 "$SX_SERVER" < "$CLOS_FILE" 2>/dev/null)
 rm -f "$CLOS_FILE"
 CLOS_PASSED=$(echo "$CLOS_OUT" | grep -A1 "^(ok-len 5 " | tail -1 || true)
@@ -389,7 +389,7 @@ fi
 run_clos_suite() {
  local prog="$1" pass_var="$2" fail_var="$3" failures_var="$4"
  local PROG_FILE=$(mktemp)
-  printf '(epoch 1)\n(load "spec/stdlib.sx")\n(epoch 2)\n(load "lib/common-lisp/runtime.sx")\n(epoch 3)\n(load "lib/common-lisp/clos.sx")\n(epoch 4)\n(load "%s")\n(epoch 5)\n(eval "%s")\n(epoch 6)\n(eval "%s")\n(epoch 7)\n(eval "%s")\n' \
+  printf '(epoch 1)\n(load "spec/stdlib.sx")\n(epoch 2)\n(load "lib/common-lisp/runtime.sx")\n(epoch 3)\n(load "lib/guest/reflective/class-chain.sx")\n(load "lib/common-lisp/clos.sx")\n(epoch 4)\n(load "%s")\n(epoch 5)\n(eval "%s")\n(epoch 6)\n(eval "%s")\n(epoch 7)\n(eval "%s")\n' \
    "$prog" "$pass_var" "$fail_var" "$failures_var" > "$PROG_FILE"
  local OUT; OUT=$(timeout 20 "$SX_SERVER" < "$PROG_FILE" 2>/dev/null)
  rm -f "$PROG_FILE"
--- a/lib/guest/reflective/class-chain.sx
+++ b/lib/guest/reflective/class-chain.sx
@@ -0,0 +1,129 @@
+;; 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))))))
--- a/lib/smalltalk/compare.sh
+++ b/lib/smalltalk/compare.sh
@@ -40,6 +40,7 @@ run_sx () {
 (epoch 1)
 (load "lib/smalltalk/tokenizer.sx")
 (load "lib/smalltalk/parser.sx")
+(load "lib/guest/reflective/class-chain.sx")
 (load "lib/smalltalk/runtime.sx")
 (load "lib/guest/reflective/env.sx")
 (load "lib/smalltalk/eval.sx")
--- a/lib/smalltalk/runtime.sx
+++ b/lib/smalltalk/runtime.sx
@@ -221,30 +221,37 @@
                    (st-ic-bump-generation!)
                    true))))))))))

+;; Smalltalk-side adapter for lib/guest/reflective/class-chain.sx.
+;; Smalltalk has single inheritance: :parents-of returns a 1-element
+;; list (or empty) wrapping the single :superclass field.
+(define st-class-cfg
+  {:parents-of (fn (cn)
+                 (let ((p (st-class-superclass cn)))
+                   (cond ((nil? p) (list))
+                         (:else (list p)))))
+   :class?     (fn (n) (st-class-exists? n))})
+
 ;; Walk-only lookup. Returns the method record (with :defining-class) or nil.
 ;; class-side? = true searches :class-methods, false searches :methods.
+;; Parent-chain walk delegates to refl-class-chain-find-with; the probe
+;; tests this class's method dict and returns the entry (or nil).
 (define
  st-method-lookup-walk
-  (fn
-    (cls-name selector class-side?)
-    (let
-      ((found nil))
-      (begin
-        (define
-          ml-loop
-          (fn
-            (cur)
-            (when
-              (and (= found nil) (not (= cur nil)) (st-class-exists? cur))
-              (let
-                ((c (st-class-get cur)))
-                (let
-                  ((dict (if class-side? (get c :class-methods) (get c :methods))))
-                  (cond
-                    ((has-key? dict selector) (set! found (get dict selector)))
-                    (else (ml-loop (get c :superclass)))))))))
-        (ml-loop cls-name)
-        found))))
+  (fn (cls-name selector class-side?)
+    (refl-class-chain-find-with
+      st-class-cfg
+      cls-name
+      (fn (cn)
+        (let ((c (st-class-get cn)))
+          (cond
+            ((nil? c) nil)
+            (:else
+              (let ((dict (if class-side?
+                            (get c :class-methods)
+                            (get c :methods))))
+                (cond
+                  ((has-key? dict selector) (get dict selector))
+                  (:else nil))))))))))

 ;; Cached lookup. Misses are stored as :not-found so doesNotUnderstand paths
 ;; don't re-walk on every send.
--- a/lib/smalltalk/test.sh
+++ b/lib/smalltalk/test.sh
@@ -59,6 +59,7 @@ EPOCHS
 (epoch 2)
 (load "lib/smalltalk/parser.sx")
 (epoch 3)
+(load "lib/guest/reflective/class-chain.sx")
 (load "lib/smalltalk/runtime.sx")
 (epoch 4)
 (load "lib/guest/reflective/env.sx")
@@ -115,6 +116,7 @@ EPOCHS
 (epoch 2)
 (load "lib/smalltalk/parser.sx")
 (epoch 3)
+(load "lib/guest/reflective/class-chain.sx")
 (load "lib/smalltalk/runtime.sx")
 (epoch 4)
 (load "lib/guest/reflective/env.sx")