Protocol dispatch through a deftype/reify's declared interfaces

value-host-tags reported only ("Object") for a reify and (tag "Object") for a
bare deftype, so an extend-protocol filed under an interface name could never
reach one — clojure.lang.IReduceInit, java.lang.Iterable, or an ancestor like
Associative for a type declaring IPersistentVector. Both now report their
declared interfaces plus the modeled ancestry the class graph already holds
(register-inline-protocol! files each declared interface as a super of the
type's tag), which is what instanceof answers on the JVM. A defrecord's extra
declared interfaces join its automatic map set the same way.

satisfies? agreed with the old dispatch, not with the JVM: it checked only the
type's own registry and answered false where an interface extension applied.
It now falls through to the same interface walk.

The type's own tag is still tried first, so an extend-type on the type wins,
and Object extensions still catch types that declare nothing.

Author: Yogthos

CHANGELOG.md

@@ -34,6 +34,19 @@ and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0
   (`kvreduce`, lowercase) before throwing. `sequence` still requires a seqable
   source, as on the JVM.
 
+- **Protocol dispatch reaches a deftype or reify through its declared
+  interfaces.** `value-host-tags` now reports a reify's declared interfaces
+  (with their modeled ancestry) and a bare deftype's declared interfaces from
+  the class graph, so an `extend-protocol` filed under an interface name —
+  `clojure.lang.IReduceInit`, `java.lang.Iterable`, an ancestor like
+  `Associative` for a type declaring `IPersistentVector` — dispatches on such
+  a value the way `instanceof` answers on the JVM. A defrecord's EXTRA declared
+  interfaces join its automatic map set the same way. `satisfies?` agrees: it
+  falls through to the same interface walk when the type's own registry has no
+  entry (it used to answer false while dispatch succeeded). An extension on
+  the type's own tag still wins, and `Object` extensions still catch types
+  declaring nothing.
+
 - **A deftype/reify can name a protocol by its dotted class spelling.**
   `(deftype T [] my.ns.PThing (m [_] …))` resolves `my.ns.PThing` to the
   protocol like the JVM does; the methods used to file as interface methods

host/chez/protocols.ss

@@ -263,6 +263,36 @@
          (find-method-any-protocol (jrec-tag v) "toString")
          (record-method-dispatch v "toString" jolt-nil))))
 
+;; the interfaces every defrecord carries, spelled both ways (the record arm of
+;; value-host-tags below).
+(define jrec-record-iface-tags
+  '("IRecord" "clojure.lang.IRecord" "IPersistentMap" "clojure.lang.IPersistentMap"
+    "APersistentMap" "Associative" "ILookup" "Seqable" "Counted"
+    "IPersistentCollection" "IObj" "IMeta" "Map" "java.util.Map"
+    "Iterable" "java.lang.Iterable" "Object"))
+
+;; a jch-tags list always ends with "Object"; the tail without it, for splicing
+;; ahead of another tag list.
+(define (jch-tags-sans-object ts)
+  (if (null? (cdr ts)) '() (cons (car ts) (jch-tags-sans-object (cdr ts)))))
+
+;; A reify's dispatch tags: each declared protocol/interface as its JVM interface
+;; name plus that interface's modeled ancestry, deduped, Object last — so an
+;; extend-protocol filed under an interface name (clojure.lang.IReduceInit,
+;; java.lang.Iterable, …) reaches a reify declaring it, exactly as instanceof
+;; answers on the JVM. The reify's own method table is consulted before these
+;; (protocol-resolve), so an inline impl still wins.
+(define (jreify-host-tags obj)
+  (let loop ((ps (jreify-protos obj)) (acc '()))
+    (if (null? ps)
+        (reverse (cons "Object" acc))
+        (let inner ((ts (jch-tags (proto-iface-name (car ps)))) (acc acc))
+          (if (null? ts)
+              (loop (cdr ps) acc)
+              (inner (cdr ts)
+                     (let ((t (car ts)))
+                       (if (or (string=? t "Object") (member t acc)) acc (cons t acc)))))))))
+
 ;; host type-tag candidates for a non-record value (extend-protocol on builtins).
 (define (value-host-tags obj)
   ;; numbers dispatch by actual type (a Double is NOT a Long): flonum -> Double,
@@ -364,15 +394,29 @@
         ;; IWalkTerm to clojure.lang.IRecord, and walking a record value must hit
         ;; that, not the Object default (which would recur forever). The record's
         ;; own type is tried first (dispatch checks jrec-tag before these tags).
+        ;; a reify reports its declared interfaces and their ancestry — see
+        ;; jreify-host-tags above.
+        ((jreify? obj) (jreify-host-tags obj))
+        ;; A record that declares FURTHER interfaces beyond the automatic map set
+        ;; reports those too (register-inline-protocol! files them as the tag's
+        ;; supers in the class graph, so cddr of the cached jch-tags list — own
+        ;; tag and simple segment dropped — is exactly the declared ancestry).
+        ;; The common record declares nothing extra and keeps the shared list,
+        ;; costing this hot fallback path one cons, as before.
         ((jrec-record? obj)
-         (cons (jrec-tag obj)
-               '("IRecord" "clojure.lang.IRecord" "IPersistentMap" "clojure.lang.IPersistentMap"
-                 "APersistentMap" "Associative" "ILookup" "Seqable" "Counted"
-                 "IPersistentCollection" "IObj" "IMeta" "Map" "java.util.Map"
-                 "Iterable" "java.lang.Iterable" "Object")))
-        ;; a bare deftype is opaque — its declared interfaces dispatch via the
-        ;; inline methods registered under its own tag (tried before these tags).
-        ((jrec? obj) (list (jrec-tag obj) "Object"))
+         (let* ((tag (jrec-tag obj))
+                (extra (cddr (jch-tags tag))))
+           (cons tag (if (null? (cdr extra))
+                         jrec-record-iface-tags
+                         (append (jch-tags-sans-object extra) jrec-record-iface-tags)))))
+        ;; a bare deftype dispatches through its own tag first, then its declared
+        ;; interfaces and their modeled ancestry — an extend-protocol filed under
+        ;; clojure.lang.IReduceInit reaches a deftype declaring it, as instanceof
+        ;; does. The tag's own SIMPLE segment is dropped (cddr): extensions on a
+        ;; deftype name file under its ns-qualified tag, and a bare segment could
+        ;; collide with a host class of the same name. A type declaring no
+        ;; interfaces keeps (tag "Object").
+        ((jrec? obj) (let ((tag (jrec-tag obj))) (cons tag (cddr (jch-tags tag)))))
         ;; a throwable reports its OWN class and that class's ancestry, so
         ;; (extend-protocol P Throwable …) reaches an ex-info or a host-constructed
         ;; RuntimeException. clojure.datafy extends Datafiable to Throwable exactly

host/chez/records-dispatch.ss

@@ -409,16 +409,23 @@
           (cond ((jclass? proto) (jclass-name proto))
                 ((jolt-nil? proto) "nil")
                 (else (jolt-final-str proto))))))
-    (cond
-      ((jrec? obj) (type-satisfies? (jrec-tag obj) pn-str))
-      ((jreify? obj)
-       (and (memp (lambda (p) (or (string=? p pn-str) (proto-class-match? p pn-str)))
-                  (jreify-protos obj))
-            #t))
-      (else (let loop ((tags (value-host-tags obj)))
-              (cond ((null? tags) #f)
-                    ((type-satisfies? (car tags) pn-str) #t)
-                    (else (loop (cdr tags)))))))))
+    (or
+      ;; direct: a record type's own registry, a reify's declared list.
+      (cond
+        ((jrec? obj) (and (type-satisfies? (jrec-tag obj) pn-str) #t))
+        ((jreify? obj)
+         (and (memp (lambda (p) (or (string=? p pn-str) (proto-class-match? p pn-str)))
+                    (jreify-protos obj))
+              #t))
+        (else #f))
+      ;; extended: the protocol may be extended to an interface or class the
+      ;; value reports — value-host-tags includes a deftype/reify's declared
+      ;; interfaces — the same walk dispatch takes. On the JVM one instanceof
+      ;; answers both the direct and the extended case.
+      (let loop ((tags (value-host-tags obj)))
+        (cond ((null? tags) #f)
+              ((type-satisfies? (car tags) pn-str) #t)
+              (else (loop (cdr tags))))))))
 (define (last-dot s)
   (let loop ((i (- (string-length s) 1)))
     (cond ((< i 0) s) ((char=? (string-ref s i) #\.) (substring s (+ i 1) (string-length s))) (else (loop (- i 1))))))

host/gambit/records-gambit.ss

@@ -1431,6 +1431,33 @@
          (find-method-any-protocol (jrec-tag v) "toString")
          (record-method-dispatch v "toString" jolt-nil))))
 
+(define jrec-record-iface-tags
+  '("IRecord" "clojure.lang.IRecord" "IPersistentMap"
+     "clojure.lang.IPersistentMap" "APersistentMap" "Associative"
+     "ILookup" "Seqable" "Counted" "IPersistentCollection" "IObj"
+     "IMeta" "Map" "java.util.Map" "Iterable"
+     "java.lang.Iterable" "Object"))
+
+(define (jch-tags-sans-object ts)
+  (if (null? (cdr ts))
+      '()
+      (cons (car ts) (jch-tags-sans-object (cdr ts)))))
+
+(define (jreify-host-tags obj)
+  (let loop ((ps (jreify-protos obj)) (acc '()))
+    (if (null? ps)
+        (reverse (cons "Object" acc))
+        (let inner ((ts (jch-tags (proto-iface-name (car ps))))
+                    (acc acc))
+          (if (null? ts)
+              (loop (cdr ps) acc)
+              (inner
+                (cdr ts)
+                (let ((t (car ts)))
+                  (if (or (string=? t "Object") (member t acc))
+                      acc
+                      (cons t acc)))))))))
+
 (define (value-host-tags obj)
   (cond
     ((flonum? obj) '("Double" "Float" "Number" "Object"))
@@ -1492,15 +1519,19 @@
     ((jbigdec? obj) (jch-tags "java.math.BigDecimal"))
     ((procedure? obj) (jch-tags "clojure.lang.AFunction"))
     ((jolt-nil? obj) '("nil"))
+    ((jreify? obj) (jreify-host-tags obj))
     ((jrec-record? obj)
-     (cons
-       (jrec-tag obj)
-       '("IRecord" "clojure.lang.IRecord" "IPersistentMap"
-          "clojure.lang.IPersistentMap" "APersistentMap" "Associative"
-          "ILookup" "Seqable" "Counted" "IPersistentCollection" "IObj"
-          "IMeta" "Map" "java.util.Map" "Iterable"
-          "java.lang.Iterable" "Object")))
-    ((jrec? obj) (list (jrec-tag obj) "Object"))
+     (let* ((tag (jrec-tag obj)) (extra (cddr (jch-tags tag))))
+       (cons
+         tag
+         (if (null? (cdr extra))
+             jrec-record-iface-tags
+             (append
+               (jch-tags-sans-object extra)
+               jrec-record-iface-tags)))))
+    ((jrec? obj)
+     (let ((tag (jrec-tag obj)))
+       (cons tag (cddr (jch-tags tag)))))
     ((jolt-ex-info-record? obj)
      (jch-tags (jolt-ex-info-record-class-name obj)))
     ((jolt-atom? obj) (jch-tags "clojure.lang.Atom"))
@@ -2332,20 +2363,21 @@
             ((jclass? proto) (jclass-name proto))
             ((jolt-nil? proto) "nil")
             (else (jolt-final-str proto))))))
-    (cond
-      ((jrec? obj) (type-satisfies? (jrec-tag obj) pn-str))
-      ((jreify? obj)
-       (and (memp
-              (lambda (p)
-                (or (string=? p pn-str) (proto-class-match? p pn-str)))
-              (jreify-protos obj))
-            #t))
-      (else
-       (let loop ((tags (value-host-tags obj)))
-         (cond
-           ((null? tags) #f)
-           ((type-satisfies? (car tags) pn-str) #t)
-           (else (loop (cdr tags)))))))))
+    (or (cond
+          ((jrec? obj)
+           (and (type-satisfies? (jrec-tag obj) pn-str) #t))
+          ((jreify? obj)
+           (and (memp
+                  (lambda (p)
+                    (or (string=? p pn-str) (proto-class-match? p pn-str)))
+                  (jreify-protos obj))
+                #t))
+          (else #f))
+        (let loop ((tags (value-host-tags obj)))
+          (cond
+            ((null? tags) #f)
+            ((type-satisfies? (car tags) pn-str) #t)
+            (else (loop (cdr tags))))))))
 
 (define (last-dot s)
   (let loop ((i (- (string-length s) 1)))

test/chez/corpus.edn

@@ -5239,4 +5239,12 @@
   {:suite "maps / array-map 1.13" :label "into {} of 9 keyword pairs is a PersistentHashMap" :expected "true" :actual "(instance? clojure.lang.PersistentHashMap (into {} (map (fn [i] [(keyword (str \"k\" i)) i]) (range 9))))" :portability :common}
   {:suite "maps / array-map 1.13" :label "transient assoc! promotes at capacity regardless of key type" :expected "[:k8 :k11 :k5 :k7 :k9 :k6 :k0 :k10 :k3 :k4 :k1 :k2]" :actual "(vec (keys (persistent! (reduce (fn [t i] (assoc! t (keyword (str \"k\" i)) i)) (transient {}) (range 12)))))" :portability :common}
   {:suite "maps / array-map 1.13" :label "transient dissoc! moves the last entry into the removed slot" :expected "[:a :d :c]" :actual "(vec (keys (persistent! (dissoc! (transient (array-map :a 1 :b 2 :c 3 :d 4)) :b))))" :portability :common}
+  {:suite "protocols / interface tags" :label "extend-protocol under an interface reaches a reify declaring it" :expected ":ireduce" :actual "(do (defprotocol IftP (iftp [x])) (extend-protocol IftP clojure.lang.IReduceInit (iftp [x] :ireduce)) (iftp (reify clojure.lang.IReduceInit (reduce [_ f init] init))))" :portability :common}
+  {:suite "protocols / interface tags" :label "extend-protocol under an interface reaches a deftype declaring it" :expected ":ireduce" :actual "(do (defprotocol IftQ (iftq [x])) (extend-protocol IftQ clojure.lang.IReduceInit (iftq [x] :ireduce)) (deftype IftT1 [] clojure.lang.IReduceInit (reduce [_ f init] init)) (iftq (->IftT1)))" :portability :common}
+  {:suite "protocols / interface tags" :label "a declared interface's ANCESTORS dispatch too (IPersistentVector is an Associative)" :expected ":assoc" :actual "(do (defprotocol IftR (iftr [x])) (extend-protocol IftR clojure.lang.Associative (iftr [x] :assoc)) (deftype IftT2 [] clojure.lang.IPersistentVector) (iftr (->IftT2)))" :portability :common}
+  {:suite "protocols / interface tags" :label "an extension on the type's own tag beats an interface extension" :expected ":own" :actual "(do (defprotocol IftS (ifts [x])) (extend-protocol IftS clojure.lang.IReduceInit (ifts [x] :iface)) (deftype IftT3 [] clojure.lang.IReduceInit (reduce [_ f init] init)) (extend-type IftT3 IftS (ifts [x] :own)) (ifts (->IftT3)))" :portability :common}
+  {:suite "protocols / interface tags" :label "satisfies? sees an interface extension for reify, deftype, and not others" :expected "[true true false]" :actual "(do (defprotocol IftU (iftu [x])) (extend-protocol IftU clojure.lang.IReduceInit (iftu [x] :i)) (deftype IftT4 [] clojure.lang.IReduceInit (reduce [_ f init] init)) [(satisfies? IftU (reify clojure.lang.IReduceInit (reduce [_ f init] init))) (satisfies? IftU (->IftT4)) (satisfies? IftU 42)])" :portability :common}
+  {:suite "protocols / interface tags" :label "an Object extension still catches a reify declaring interfaces" :expected ":obj" :actual "(do (defprotocol IftV (iftv [x])) (extend-protocol IftV Object (iftv [x] :obj)) (iftv (reify clojure.lang.IReduceInit (reduce [_ f init] init))))" :portability :common}
+  {:suite "protocols / interface tags" :label "a defrecord's EXTRA declared interface dispatches alongside the map set" :expected ":rec" :actual "(do (defprotocol IftW (iftw [x])) (extend-protocol IftW clojure.lang.IReduceInit (iftw [x] :rec)) (defrecord IftR1 [] clojure.lang.IReduceInit (reduce [_ f init] init)) (iftw (->IftR1)))" :portability :common}
+  {:suite "protocols / interface tags" :label "IRecord extension: dispatch and satisfies? agree on a record" :expected "[:irec true]" :actual "(do (defprotocol IftX (iftx [x])) (extend-protocol IftX clojure.lang.IRecord (iftx [x] :irec)) (defrecord IftR2 [a]) [(iftx (->IftR2 1)) (satisfies? IftX (->IftR2 1))])" :portability :common}
 ]