Hierarchy fns follow the reference contracts; deftype classes join the class graph

derive/underive/ancestors/descendants/parents/isa? re-ported from
clojure.core with the argument assertions and throw contracts intact:
derive asserts tag/parent shapes (AssertionError) and throws on redundant
or cyclic derivation; underive/derive on a non-hierarchy value throw at the
parents lookup (the map is called as a function, like the reference);
(descendants h SomeClass) throws UnsupportedOperationException. isa? gains
the reference's supers arm (a relationship derived on a class's super
applies to the class).

The class arms now answer fully through the one class graph: parents of a
class are its direct supers (bases), ancestors are the transitive set
rooted at java.lang.Object for concrete classes (interfaces are marked and
don't root at Object, matching getSuperclass semantics). deftype/defrecord
classes register into the graph at definition — protocol interfaces they
implement appear as supers (JVM-munged ns spelling), records carry the
record interfaces (IRecord/IPersistentMap/... whose closure supplies
Associative/Seqable), bare deftypes carry IType. The type NAME var still
holds the ctor (a jolt-ism); class-key maps it back to the class so
(ancestors TypeName)/(isa? x TypeName) work. canonical-host-tag learned to
NOT canonicalize deftype names through the graph arm (extend-type on a
deftype was registering under the bare segment its values never report).

Five old corpus rows used non-namespaced derive tags that throw on the JVM
too; now namespaced. 8 new JVM-certified corpus rows; spec entries for the
hierarchy family; cts baseline 5730 -> 5781 pass (ancestors/derive/
descendants/parents/underive namespaces fully clean), 74 baselined
namespaces.

host/chez/java/class-hierarchy.ss

@@ -33,6 +33,15 @@
 
 (define (jch-direct-supers name) (hashtable-ref jvm-class-parents name '()))
 
+;; Replace a class's direct supers outright (defrecord re-declares the row its
+;; deftype half registered). Same cache invalidation as a register.
+(define (jch-set-supers! name supers)
+  (hashtable-set! jvm-class-parents name supers)
+  (hashtable-clear! jch-closure-cache)
+  (hashtable-clear! jch-tags-cache)
+  (set! jch-known-cache #f)
+  (set! jch-simple->fqn-cache #f))
+
 ;; transitive supers of NAME (canonical), excluding NAME and Object; Object is the
 ;; universal root supplied by callers. Breadth-first, deduped, stable order.
 (define (jch-closure name)
@@ -46,6 +55,11 @@
         (hashtable-set! jch-closure-cache name result)
         result)))
 
+;; ns segment munging for a JVM-spelled class name: dashes become underscores
+;; (clojure.core-test.x -> clojure.core_test.x).
+(define (jch-munge-segments s)
+  (list->string (map (lambda (c) (if (char=? c #\-) #\_ c)) (string->list s))))
+
 (define (jch-last-segment s)
   (let loop ((i (- (string-length s) 1)))
     (cond ((< i 0) s)
@@ -130,6 +144,30 @@
     (set! jch-simple->fqn-cache #f)
     (jch-register-supers!-inner name supers)))
 
+;; ---- interface marking ---------------------------------------------------------
+;; The JVM distinguishes a concrete class (whose bases/supers chain roots at
+;; Object) from an interface (whose don't). The graph marks the modeled
+;; interfaces; anything unmarked is treated as a concrete class.
+(define jch-interface-set (make-hashtable string-hash string=?))
+(define (jch-mark-interface! name) (hashtable-set! jch-interface-set name #t))
+(define (jch-interface? name) (hashtable-ref jch-interface-set name #f))
+(for-each jch-mark-interface!
+          '("clojure.lang.Seqable" "clojure.lang.Sequential" "clojure.lang.Sorted"
+            "clojure.lang.Reversible" "clojure.lang.Indexed" "clojure.lang.Counted"
+            "clojure.lang.Named" "clojure.lang.Fn" "clojure.lang.IFn"
+            "clojure.lang.IPersistentCollection" "clojure.lang.ISeq"
+            "clojure.lang.Associative" "clojure.lang.ILookup"
+            "clojure.lang.IPersistentStack" "clojure.lang.IPersistentVector"
+            "clojure.lang.IPersistentMap" "clojure.lang.IPersistentSet"
+            "clojure.lang.IPersistentList" "clojure.lang.IObj" "clojure.lang.IMeta"
+            "clojure.lang.IDeref" "clojure.lang.IRecord" "clojure.lang.IType"
+            "clojure.lang.IHashEq" "clojure.lang.IEditableCollection"
+            "clojure.lang.IExceptionInfo" "clojure.lang.IReduceInit"
+            "java.util.List" "java.util.Set" "java.util.Collection" "java.util.Map"
+            "java.util.Iterator" "java.lang.Iterable" "java.lang.CharSequence"
+            "java.lang.Comparable" "java.lang.Runnable"
+            "java.util.concurrent.Callable" "java.io.Serializable"))
+
 ;; ---- seed the built-in graph: direct supers only, faithful to the JVM ---------
 ;; core clojure.lang interfaces
 (jch-register-supers! "clojure.lang.IPersistentCollection" '("clojure.lang.Seqable"))

host/chez/java/host-static-classes.ss

@@ -841,7 +841,12 @@
 (define (make-class-obj name) (make-jhost "class" (vector name)))
 (define (jclass? x) (and (jhost? x) (string=? (jhost-tag x) "class")))
 (define (jclass-name x) (vector-ref (jhost-state x) 0))
-(define (class-key x) (cond ((jclass? x) (jclass-name x)) ((string? x) x) (else #f)))
+(define (class-key x)
+  (cond ((jclass? x) (jclass-name x))
+        ((string? x) x)
+        ;; a deftype/defrecord NAME var holds its ctor; treat it as the class
+        ((procedure? x) (hashtable-ref chez-deftype-ctor-tag x #f))
+        (else #f)))
 (register-eq-arm! (lambda (a b) (or (jclass? a) (jclass? b)))
                   (lambda (a b) (let ((ka (class-key a)) (kb (class-key b)))
                                   (and ka kb (string=? ka kb) #t))))
@@ -1047,19 +1052,62 @@
                 #t jolt-nil))
           jolt-nil))))
 
+;; is NAME a class the host models (registered in the class graph, a legacy
+;; supers-table entry, or a fn class)? Object itself is modeled.
+(define (hsc-class-known? name)
+  (or (string=? name "java.lang.Object")
+      (jch-known? name)
+      (and (hashtable-ref class-supers-tbl name #f) #t)
+      (str-has-dollar? name)))
+
+;; transitive ancestry, rooted at Object for a concrete class like (supers c);
+;; an interface's chain has no Object (its getSuperclass is null). '() for
+;; Object itself and for a name the host doesn't model.
+(define (class-ancestors-rooted name)
+  (if (or (string=? name "java.lang.Object") (jch-interface? name))
+      (class-ancestors-list name)
+      (let ((as (class-ancestors-list name)))
+        (cond ((member "java.lang.Object" as) as)
+              ((null? as) (if (hsc-class-known? name) '("java.lang.Object") '()))
+              (else (append as '("java.lang.Object")))))))
+
 ;; (jolt.host/class-supers name) / (jolt.host/class-ancestors name) — a jolt seq of
-;; super / ancestor class-name strings, or nil when jolt models no hierarchy for it.
+;; super / ancestor class-name strings (transitive, Object-rooted), or nil when
+;; jolt models no hierarchy for it. class-bases is the DIRECT supers (clojure.core
+;; `bases` / the class arm of `parents`).
 (def-var! "jolt.host" "class-supers"
   (lambda (x)
     (let ((name (class-key x)))
       (if name
-          (let ((as (class-ancestors-list name)))   ; transitive, like the JVM
+          (let ((as (class-ancestors-rooted name)))
             (if (null? as) jolt-nil (list->cseq as)))
           jolt-nil))))
 (def-var! "jolt.host" "class-ancestors"
   (lambda (x)
     (let ((name (class-key x)))
       (if name
-          (let ((as (class-ancestors-list name)))
+          (let ((as (class-ancestors-rooted name)))
             (if (null? as) jolt-nil (list->cseq as)))
           jolt-nil))))
+(def-var! "jolt.host" "class-bases"
+  (lambda (x)
+    (let ((name (class-key x)))
+      (if name
+          (let* ((ds (class-direct-supers name))
+                 ;; a concrete class's bases include its superclass — Object when
+                 ;; nothing more specific is modeled (interfaces have none).
+                 (ds (if (or (string=? name "java.lang.Object")
+                             (jch-interface? name)
+                             (member "java.lang.Object" ds))
+                         ds
+                         (append ds '("java.lang.Object")))))
+            (if (null? ds) jolt-nil (list->cseq ds)))
+          jolt-nil))))
+;; is X a class value — a jclass, a deftype ctor, or a name string the host
+;; graph models?
+(def-var! "jolt.host" "class-value?"
+  (lambda (x)
+    (if (jclass? x)
+        #t
+        (let ((n (class-key x)))
+          (if (and n (hsc-class-known? n)) #t jolt-nil)))))

host/chez/records.ss

@@ -44,6 +44,10 @@
 ;; resolves "Raw" to its real tag "a.util.Raw" here instead of prepending the
 ;; calling ns. The local ns is preferred, so a same-named local type still wins.
 (define chez-deftype-tag-set (make-hashtable string-hash string=?))
+;; ctor procedure -> its class tag: the type NAME var holds the ctor (a jolt-ism;
+;; the JVM resolves it to the class), so class-key maps the ctor back to the
+;; class for (ancestors TypeName) / (isa? x TypeName) / derive on the type.
+(define chez-deftype-ctor-tag (make-weak-eq-hashtable))
 (define chez-simple-name-tag (make-hashtable string-hash string=?))
 ;; a jrec that is coll? — a record, or a deftype implementing a collection
 ;; interface (its seq/count/nth/valAt/cons method is registered). find-method-any-
@@ -618,6 +622,11 @@
     ;; index the tag so a cross-ns extend-protocol resolves the bare type name.
     (hashtable-set! chez-deftype-tag-set tag #t)
     (hashtable-set! chez-simple-name-tag (symbol-t-name name-sym) tag)
+    ;; graft the type onto the class graph so isa?/supers/ancestors see it. A
+    ;; bare deftype is an IType; defrecord (which runs register-record-type!
+    ;; right after) replaces the row with the record interface set.
+    (jch-set-supers! tag '("clojure.lang.IType"))
+    (hashtable-set! chez-deftype-ctor-tag ctor tag)
     ;; record the shape for whole-program inference, keyed by the positional
     ;; ctor var "ns/->Name" the analyzer resolves a (->Name …) call to.
     (register-record-shape! (string-append (chez-current-ns) "/->" (symbol-t-name name-sym))
@@ -689,9 +698,14 @@
                   type-name)))
     ;; a host class if the literal set lists it OR the class graph models it — both
     ;; feed value-host-tags (which emits the same bare segment), so a protocol
-    ;; extended to any modeled class keys under a tag the value reports.
+    ;; extended to any modeled class keys under a tag the value reports. A
+    ;; deftype/defrecord is in the graph too (its ancestry), but its VALUES report
+    ;; the ns-qualified tag, not the bare segment — so a name that resolves to a
+    ;; deftype never canonicalizes through the graph arm.
     (and (or (hashtable-ref host-type-set base #f)
-             (jch-known? base) (jch-known? type-name))
+             (and (not (hashtable-ref chez-simple-name-tag type-name #f))
+                  (not (hashtable-ref chez-deftype-tag-set type-name #f))
+                  (or (jch-known? base) (jch-known? type-name))))
          base)))
 ;; An extend/extend-type/extend-protocol registration marks the tag as an
 ;; extender of the protocol (recorded inside type-registry so the per-case prune
@@ -731,6 +745,12 @@
                  (let ((h (make-hashtable string-hash string=?))) (hashtable-set! type-registry tag h) h))))
     (unless (hashtable-ref ti proto-name #f)
       (hashtable-set! ti proto-name (make-hashtable string-hash string=?))))
+  ;; the protocol's interface joins the type's class ancestry, spelled like the
+  ;; JVM interface (munged ns; the defining ns is assumed to be the current one —
+  ;; the macro passes only the simple protocol name).
+  (let ((iface (string-append (jch-munge-segments (chez-current-ns)) "." proto-name)))
+    (jch-mark-interface! iface)
+    (jch-register-supers! (string-append (chez-current-ns) "." type-name) (list iface)))
   jolt-nil)
 
 ;; protocol-resolve: the impl procedure for obj — by record type tag, a reify's
@@ -1050,8 +1070,18 @@
 ;; defrecord marks its type a record (deftype does not), keyed by the same
 ;; "ns.Name" tag make-deftype-ctor bakes — so jrec-record? distinguishes the two.
 (define (register-record-type! name-sym)
-  (hashtable-set! chez-record-type-tbl
-                  (string-append (chez-current-ns) "." (symbol-t-name name-sym)) #t)
+  (let ((tag (string-append (chez-current-ns) "." (symbol-t-name name-sym))))
+    (hashtable-set! chez-record-type-tbl tag #t)
+    ;; a defrecord's class ancestry: replace the deftype IType row with the
+    ;; record interfaces (their closure supplies Associative/Seqable/ILookup/…),
+    ;; keeping any protocol interfaces already grafted by the inline
+    ;; registrations that ran between the deftype ctor and this call.
+    (let ((protos (filter (lambda (s) (not (string=? s "clojure.lang.IType")))
+                          (jch-direct-supers tag))))
+      (jch-set-supers! tag (append protos
+                                   '("clojure.lang.IRecord" "clojure.lang.IObj"
+                                     "clojure.lang.IPersistentMap" "java.util.Map"
+                                     "clojure.lang.IHashEq" "java.io.Serializable")))))
   jolt-nil)
 (def-var! "clojure.core" "register-record-type!" register-record-type!)
 (def-var! "clojure.core" "make-protocol" make-protocol)