simon/jolt
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

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

Browse source 
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.
This commit is contained in:
Yogthos 2026-07-02 08:48:30 -04:00
parent 7e1df2c600
commit 6e333b3020
10 changed files with 618 additions and 401 deletions
Download patch file Download diff file Expand all files Collapse all files

38
host/chez/java/class-hierarchy.ss
View file

@ -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"))

56
host/chez/java/host-static-classes.ss
View file

@ -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)))))