Merge pull request #294 from jolt-lang/hierarchy/reference-contracts

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

docs/host-interop.md

@@ -258,6 +258,14 @@ transitivity is computed):
 ;; (catch java.io.IOException e …) now matches it; (instance? java.lang.Exception e) is true
 ```
 
+deftype/defrecord classes join the same graph automatically at definition: a
+record's ancestry carries the record interfaces (`clojure.lang.IRecord`,
+`IPersistentMap`, `Associative`, …), a bare deftype carries
+`clojure.lang.IType`, and every protocol the type implements inline appears as
+an implemented interface — so `(ancestors MyRecord)`, `(isa? MyRecord
+clojure.lang.IPersistentMap)`, and hierarchy relationships `derive`d on a
+class's supers all answer like the JVM.
+
 Extending a *built-in* class instead (adding a method to core's `String` shim,
 say) means editing the relevant `host/chez/*.ss` file and running `make remint`
 — see [building-and-deps.md](building-and-deps.md).

docs/spec/09-core-library.md

@@ -232,6 +232,56 @@ clojure-test-suite `core_test/special_symbol_qmark.cljc` and every
 
 ---
 
+### make-hierarchy, derive, underive, isa?, parents, ancestors, descendants — since 1.0
+
+```
+(make-hierarchy)
+(derive tag parent)            (derive h tag parent)
+(underive tag parent)          (underive h tag parent)
+(isa? child parent)            (isa? h child parent)
+(parents tag)  (ancestors tag)  (descendants tag)   ; + (f h tag) forms
+```
+
+**Semantics**
+
+- S1. A hierarchy is a pure value `{:parents {tag #{...}} :ancestors {...}
+  :descendants {...}}`; the 3-arity forms are pure, the shorter arities read and
+  mutate the global hierarchy.
+- S2. `isa?` is true when `(= child parent)`, when the host type system says
+  parent is assignable from child (both classes), when the relationship was
+  `derive`d — including a relationship derived on one of a class child's
+  supers — or component-wise for equal-length vectors.
+- S3. Class tags answer through the host type hierarchy: `(parents c)` includes
+  the class's direct supers (`bases` — a concrete class's chain roots at
+  `java.lang.Object`, an interface's does not); `(ancestors c)` is the
+  transitive set plus anything `derive`d on the class or its supers. A
+  deftype/defrecord class's ancestry includes its implemented protocol
+  interfaces and, for records, the record interfaces
+  (`clojure.lang.IRecord`/`IPersistentMap`/`Associative`/…; `clojure.lang.IType`
+  for a bare deftype).
+- S4. `derive` returns the updated hierarchy (3-arity) or nil (2-arity);
+  deriving a relationship that already holds transitively, or one that would
+  create a cycle, throws.
+
+**Errors**
+
+- X1. `derive` asserts its argument shapes: parent must be a namespaced Named
+  value; tag must be a class or a Named value (namespaced in the 2-arity
+  global form); `(derive h tag tag)` fails the `not=` assert. AssertionError.
+- X2. `underive`/`derive` with a non-hierarchy `h` throw at the parents
+  lookup (the map is called as a function, like the reference).
+- X3. `(descendants h SomeClass)` throws UnsupportedOperationException
+  ("Can't get descendants of classes") — Java type inheritance is not
+  enumerable downward.
+
+**Conformance**
+
+S1–S4, X1–X3 → corpus `hierarchy / *` rows; clojure-test-suite
+`core_test/{derive,underive,isa_…,parents,ancestors,descendants}.cljc`
+(all fully passing).
+
+---
+
 ## Authoring notes
 
 - Source examples from the ClojureDocs export (`clojuredocs-export.edn`,

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
+  (let ((tag (string-append (chez-current-ns) "." (symbol-t-name name-sym))))
-                  (string-append (chez-current-ns) "." (symbol-t-name name-sym)) #t)
+    (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)

jolt-core/clojure/core/20-coll.clj

@@ -302,12 +302,24 @@
 ;; :descendants {tag #{all}}}. The 3-arity forms are PURE; the 1/2-arity forms
 ;; operate on the private global hierarchy atom. Multimethod dispatch
 ;; (evaluator defmulti-setup) calls isa? through the interned var.
+;;
+;; Ported from clojure.core with the reference's argument assertions and throw
+;; contracts intact — bad shapes throw exactly where they do there (a non-map h
+;; fails on the (parent-map tag) call, invalid tags fail the asserts). The class
+;; arms answer through the host class graph (jolt.host/class-* seams).
 
 (defn make-hierarchy []
   {:parents {} :descendants {} :ancestors {}})
 
 (def ^:private global-hierarchy (atom (make-hierarchy)))
 
+(defn- hier-assert [ok form]
+  (when-not ok (throw (new AssertionError (str "Assert failed: " form)))))
+
+;; a hierarchy tag naming a class — a class value, or the name string of a class
+;; the host graph models (jolt classes are their name strings).
+(defn- class-tag? [tag] (if (jolt.host/class-value? tag) true false))
+
 (defn isa?
   ([child parent] (isa? (deref global-hierarchy) child parent))
   ([h child parent]
@@ -316,6 +328,10 @@
        ;; so a class-keyed multimethod / (isa? (class x) C) dispatches like the JVM.
        (jolt.host/class-isa? child parent)
        (contains? (get (get h :ancestors) child #{}) parent)
+       ;; a hierarchy relationship established on one of a class's supers
+       (and (class-tag? child)
+            (some (fn [s] (contains? (get (get h :ancestors) s #{}) parent))
+                  (jolt.host/class-supers child)))
        (and (vector? parent) (vector? child)
             (= (count parent) (count child))
             (loop [ret true i 0]
@@ -325,24 +341,44 @@
 
 (defn parents
   ([tag] (parents (deref global-hierarchy) tag))
-  ([h tag] (not-empty (get (get h :parents) tag))))
+  ([h tag] (not-empty
+            (let [tp (get (get h :parents) tag)]
+              (if (class-tag? tag)
+                (into (set (jolt.host/class-bases tag)) tp)
+                tp)))))
 
 (defn ancestors
   ([tag] (ancestors (deref global-hierarchy) tag))
-  ([h tag]
+  ([h tag] (not-empty
-   ;; the user hierarchy plus any modeled JVM ancestry (jolt.host/class-ancestors)
+            (let [ta (get (get h :ancestors) tag)]
-   ;; so (ancestors (class x)) answers like the JVM for the common interfaces.
+              (if (class-tag? tag)
-   (let [hier (get (get h :ancestors) tag)
+                ;; the class's own ancestry plus hierarchy relationships derived
-         host (jolt.host/class-ancestors tag)]
+                ;; on the class or any of its supers
-     (not-empty (if host (into (or hier #{}) host) hier)))))
+                (let [superclasses (set (jolt.host/class-supers tag))]
+                  (reduce into superclasses
+                          (cons ta (map (fn [s] (get (get h :ancestors) s))
+                                        superclasses))))
+                ta)))))
 
 (defn descendants
   ([tag] (descendants (deref global-hierarchy) tag))
-  ([h tag] (not-empty (get (get h :descendants) tag))))
+  ([h tag] (if (class-tag? tag)
+             (throw (new UnsupportedOperationException "Can't get descendants of classes"))
+             (not-empty (get (get h :descendants) tag)))))
 
 (defn derive
-  ([tag parent] (swap! global-hierarchy derive tag parent) nil)
+  ([tag parent]
+   (hier-assert (namespace parent) "(namespace parent)")
+   (hier-assert (or (class-tag? tag)
+                    (and (or (keyword? tag) (symbol? tag)) (namespace tag)))
+                "(or (class? tag) (and (instance? clojure.lang.Named tag) (namespace tag)))")
+   (swap! global-hierarchy derive tag parent) nil)
   ([h tag parent]
+   (hier-assert (not= tag parent) "(not= tag parent)")
+   (hier-assert (or (class-tag? tag) (keyword? tag) (symbol? tag))
+                "(or (class? tag) (instance? clojure.lang.Named tag))")
+   (hier-assert (or (keyword? parent) (symbol? parent))
+                "(instance? clojure.lang.Named parent)")
    (let [tp (get h :parents)
          td (get h :descendants)
          ta (get h :ancestors)
@@ -350,14 +386,14 @@
               (reduce (fn [ret k]
                         (assoc ret k
                                (reduce conj (get targets k #{})
-                                       (cons target (get targets target)))))
+                                       (cons target (targets target)))))
-                      m (cons source (get sources source))))]
+                      m (cons source (sources source))))]
      (or
-      (when-not (contains? (get tp tag #{}) parent)
+      (when-not (contains? (tp tag) parent)
-        (when (contains? (get ta tag #{}) parent)
+        (when (contains? (ta tag) parent)
-          (throw (str tag " already has " parent " as ancestor")))
+          (throw (new Exception (str tag " already has " parent " as ancestor"))))
-        (when (contains? (get ta parent #{}) tag)
+        (when (contains? (ta parent) tag)
-          (throw (str "Cyclic derivation: " parent " has " tag " as ancestor")))
+          (throw (new Exception (str "Cyclic derivation: " parent " has " tag " as ancestor"))))
         {:parents (assoc tp tag (conj (get tp tag #{}) parent))
          :ancestors (tf ta tag td parent ta)
          :descendants (tf td parent ta tag td)})
@@ -367,15 +403,15 @@
   ([tag parent] (swap! global-hierarchy underive tag parent) nil)
   ([h tag parent]
    (let [parent-map (get h :parents)
-         childs-parents (if (get parent-map tag)
+         childs-parents (if (parent-map tag)
-                          (disj (get parent-map tag) parent)
+                          (disj (parent-map tag) parent)
                           #{})
          new-parents (if (not-empty childs-parents)
                        (assoc parent-map tag childs-parents)
                        (dissoc parent-map tag))
          deriv-seq (mapcat (fn [e] (cons (key e) (interpose (key e) (val e))))
                            (seq new-parents))]
-     (if (contains? (get parent-map tag #{}) parent)
+     (if (contains? (parent-map tag) parent)
        (reduce (fn [p [t pr]] (derive p t pr))
                (make-hierarchy) (partition 2 deriv-seq))
        h))))

test/chez/corpus.edn

@@ -501,12 +501,12 @@
   {:suite "hierarchy / pure 3-arity" :label "cyclic derive throws" :expected :throws :actual "(-> (make-hierarchy) (derive :a :b) (derive :b :a))"}
   {:suite "hierarchy / pure 3-arity" :label "duplicate derive ok" :expected "true" :actual "(let [h (-> (make-hierarchy) (derive :a :b) (derive :a :b))] (isa? h :a :b))"}
   {:suite "hierarchy / pure 3-arity" :label "parents nil when none" :expected "nil" :actual "(parents (make-hierarchy) :x)"}
-  {:suite "hierarchy / global + multimethod dispatch" :label "global derive + isa?" :expected "true" :actual "(do (derive :gsq :grect) (isa? :gsq :grect))"}
+  {:suite "hierarchy / global + multimethod dispatch" :label "global derive + isa?" :expected "true" :actual "(do (derive :g/sq :g/rect) (isa? :g/sq :g/rect))"}
-  {:suite "hierarchy / global + multimethod dispatch" :label "global ancestors" :expected "true" :actual "(do (derive :ga :gb) (derive :gb :gc) (contains? (ancestors :ga) :gc))"}
+  {:suite "hierarchy / global + multimethod dispatch" :label "global ancestors" :expected "true" :actual "(do (derive :g/a :g/b) (derive :g/b :g/c) (contains? (ancestors :g/a) :g/c))"}
-  {:suite "hierarchy / global + multimethod dispatch" :label "global underive" :expected "false" :actual "(do (derive :gu :gv) (underive :gu :gv) (isa? :gu :gv))"}
+  {:suite "hierarchy / global + multimethod dispatch" :label "global underive" :expected "false" :actual "(do (derive :g/u :g/v) (underive :g/u :g/v) (isa? :g/u :g/v))"}
-  {:suite "hierarchy / global + multimethod dispatch" :label "dispatch via hierarchy" :expected ":is-shape" :actual "(do (derive :hsq :hshape) (defmulti hmm identity) (defmethod hmm :hshape [_] :is-shape) (hmm :hsq))"}
+  {:suite "hierarchy / global + multimethod dispatch" :label "dispatch via hierarchy" :expected ":is-shape" :actual "(do (derive :h/sq :h/shape) (defmulti hmm identity) (defmethod hmm :h/shape [_] :is-shape) (hmm :h/sq))"}
   {:suite "hierarchy / global + multimethod dispatch" :label "dispatch custom hierarchy" :expected ":parent" :actual "(do (def hh (atom (derive (make-hierarchy) :c :p))) (defmulti cmm identity :hierarchy hh) (defmethod cmm :p [_] :parent) (cmm :c))"}
-  {:suite "hierarchy / global + multimethod dispatch" :label "dispatch exact beats isa" :expected ":exact" :actual "(do (derive :de1 :de2) (defmulti emm identity) (defmethod emm :de2 [_] :parent) (defmethod emm :de1 [_] :exact) (emm :de1))"}
+  {:suite "hierarchy / global + multimethod dispatch" :label "dispatch exact beats isa" :expected ":exact" :actual "(do (derive :de/e1 :de/e2) (defmulti emm identity) (defmethod emm :de/e2 [_] :parent) (defmethod emm :de/e1 [_] :exact) (emm :de/e1))"}
   {:suite "interop / dot forms" :label "method call" :expected "\"v=41\"" :actual "(. {:value 41 :describe (fn [self] (str \"v=\" (:value self)))} describe)"}
   {:suite "interop / dot forms" :label "method with args" :expected "\"Hello Alice\"" :actual "(. {:greet (fn [self n] (str \"Hello \" n))} greet \"Alice\")"}
   {:suite "interop / dot forms" :label "field access .-" :expected "41" :actual "(.-value {:value 41})"}
@@ -3534,4 +3534,12 @@
   {:suite "numbers / with-precision" :label "division rounds to precision (default HALF_UP)" :expected "\"0.3333\"" :actual "(str (with-precision 4 (/ 1M 3M)))"}
   {:suite "numbers / rationalize" :label "doubles go through shortest decimal print" :expected "[11/10 3/2 1 0 -1]" :actual "[(rationalize 1.1) (rationalize 1.5) (rationalize 1.0) (rationalize 0.0) (rationalize -1.0)]"}
   {:suite "numbers / rationalize" :label "bigdec and exacts pass through exactly" :expected "[3/2 1/3 7]" :actual "[(rationalize 1.5M) (rationalize 1/3) (rationalize 7)]"}
+  {:suite "hierarchy / derive asserts" :label "tag and parent must be namespaced Named (or a class)" :expected "[:ae :ae :ae :ae]" :actual "[(try (derive :a :user/p) (catch AssertionError _ :ae)) (try (derive :user/a :p) (catch AssertionError _ :ae)) (try (derive (make-hierarchy) :user/a :user/a) (catch AssertionError _ :ae)) (try (derive (make-hierarchy) :user/a \"p\") (catch AssertionError _ :ae))]"}
+  {:suite "hierarchy / derive throws" :label "redundant ancestor and cyclic derivation throw" :expected "[:anc :cyc]" :actual "(let [h (derive (derive (make-hierarchy) :user/b :user/a) :user/c :user/b)] [(try (derive h :user/c :user/a) (catch Exception _ :anc)) (try (derive h :user/a :user/c) (catch Exception _ :cyc))])"}
+  {:suite "hierarchy / underive" :label "a non-hierarchy first arg throws at the parents lookup" :expected "[:t :t :t]" :actual "[(try (underive {} :user/a :user/b) (catch Throwable _ :t)) (try (underive 42 :user/a :user/b) (catch Throwable _ :t)) (try (underive nil :user/a :user/b) (catch Throwable _ :t))]"}
+  {:suite "hierarchy / underive" :label "underive removes the relationship" :expected "[nil false]" :actual "(let [h (derive (make-hierarchy) :user/b :user/a) h2 (underive h :user/b :user/a)] [(parents h2 :user/b) (isa? h2 :user/b :user/a)])"}
+  {:suite "hierarchy / classes" :label "descendants of a class throws" :expected ":uoe" :actual "(try (descendants (make-hierarchy) java.lang.String) (catch UnsupportedOperationException _ :uoe))"}
+  {:suite "hierarchy / classes" :label "ancestors of a concrete class roots at Object" :expected "[true true]" :actual "[(contains? (ancestors (class #{})) java.lang.Object) (contains? (ancestors (class [])) java.lang.Object)]"}
+  {:suite "hierarchy / classes" :label "parents of a class are its direct supers" :expected "true" :actual "(contains? (parents (class [])) clojure.lang.APersistentVector)"}
+  {:suite "hierarchy / classes" :label "a relationship derived on a super applies to the class (isa? supers arm)" :expected "true" :actual "(let [h (derive (make-hierarchy) java.util.Collection :user/coll-like)] (isa? h (class []) :user/coll-like))"}
 ]

test/chez/cts-known-failures.txt

@@ -3,7 +3,6 @@
 # with: JOLT_CTS_WRITE_BASELINE=1 host/chez/cts.sh
 clojure.core-test.abs 1 0
 clojure.core-test.add-watch 0 3
-clojure.core-test.ancestors 9 0
 clojure.core-test.atom 14 0
 clojure.core-test.bigint 6 0
 clojure.core-test.bit-set 1 0
@@ -16,8 +15,6 @@ clojure.core-test.contains-qmark 3 0
 clojure.core-test.counted-qmark 1 0
 clojure.core-test.dec 1 0
 clojure.core-test.denominator 0 3
-clojure.core-test.derive 21 0
-clojure.core-test.descendants 4 0
 clojure.core-test.double 0 4
 clojure.core-test.double-qmark 3 0
 clojure.core-test.empty 1 0
@@ -43,7 +40,6 @@ clojure.core-test.num 2 1
 clojure.core-test.number-qmark 3 0
 clojure.core-test.numerator 0 3
 clojure.core-test.odd-qmark 1 0
-clojure.core-test.parents 10 0
 clojure.core-test.parse-uuid 3 0
 clojure.core-test.peek 2 0
 clojure.core-test.plus 11 0
@@ -68,7 +64,6 @@ clojure.core-test.special-symbol-qmark 4 0
 clojure.core-test.star 13 0
 clojure.core-test.star-squote 13 0
 clojure.core-test.transient 23 0
-clojure.core-test.underive 7 0
 clojure.core-test.update 1 0
 clojure.core-test.vals 0 3
 clojure.core-test.vec 1 0