From d168d1195beed327bf4f6f0f3bf2f3d367618420 Mon Sep 17 00:00:00 2001 From: Yogthos Date: Tue, 23 Jun 2026 23:01:30 -0400 Subject: [PATCH] refactor: registry pattern for jolt-hash + jolt-class (jolt-lmot) MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Replace the set!-capture-and-rebind chains extending jolt-hash (3 sites: inst-time/ host-table/records) and jolt-class (3 sites: bigdec/natives-queue/host-table) with a register-hash-arm! / register-class-arm! registry (the pattern already used by register-str-render!). The base dispatcher walks its arms — disjoint types, so order is immaterial — then falls to the base cases. The entry is stable, so the per-site (def-var! "clojure.core" "class" …) re-points are gone. Behaviour-preserving (runtime .ss, no re-mint): jinst hash, bigdec/queue/record class, record hash, and a sorted-map hashing as its plain map all verified; make test green, 0 new corpus divergences. First two of six dispatchers; get/=/pr-str follow. --- host/chez/bigdec.ss | 4 +--- host/chez/host-class.ss | 13 ++++++++++++- host/chez/host-table.ss | 12 +++++------- host/chez/inst-time.ss | 3 +-- host/chez/natives-queue.ss | 4 +--- host/chez/records.ss | 3 +-- host/chez/values.ss | 14 +++++++++++++- 7 files changed, 34 insertions(+), 19 deletions(-) diff --git a/host/chez/bigdec.ss b/host/chez/bigdec.ss index 598acae..ddbd933 100644 --- a/host/chez/bigdec.ss +++ b/host/chez/bigdec.ss @@ -75,8 +75,6 @@ (set! jolt-pr-readable (lambda (x) (if (jbigdec? x) (string-append (jbigdec->string x) "M") (%bd-pr-readable x)))) ;; class / decimal? -(define %bd-class jolt-class) -(set! jolt-class (lambda (x) (if (jbigdec? x) "java.math.BigDecimal" (%bd-class x)))) -(def-var! "clojure.core" "class" jolt-class) +(register-class-arm! jbigdec? (lambda (x) "java.math.BigDecimal")) (set! jolt-decimal? (lambda (x) (jbigdec? x))) (def-var! "clojure.core" "decimal?" jolt-decimal?) diff --git a/host/chez/host-class.ss b/host/chez/host-class.ss index 79eb484..e9feafa 100644 --- a/host/chez/host-class.ss +++ b/host/chez/host-class.ss @@ -13,7 +13,13 @@ ;; (str (type x)) is the clean host taxonomy and ;; is never compared against a class token in the corpus. Records yield their ;; ns-qualified class name (= (str (type x))). Total — never crashes. -(define (jolt-class x) +;; A host shim (bigdec, queue, host-table) registers its type's class name via +;; register-class-arm! instead of set!-wrapping jolt-class (cf. register-hash-arm!). +;; The entry is stable, so the var cell bound below stays current as arms register. +(define jolt-class-arms '()) +(define (register-class-arm! pred handler) + (set! jolt-class-arms (cons (cons pred handler) jolt-class-arms))) +(define (jolt-class-base x) (cond ((jolt-nil? x) jolt-nil) ((boolean? x) "java.lang.Boolean") @@ -35,6 +41,11 @@ ;; (thrown? Class …) match (records.ss ex-info-map?/ex-info-class). ((ex-info-map? x) (ex-info-class x)) (else (jolt-str-render-one (jolt-type x))))) +(define (jolt-class x) + (let loop ((as jolt-class-arms)) + (cond ((null? as) (jolt-class-base x)) + (((caar as) x) ((cdar as) x)) + (else (loop (cdr as)))))) (def-var! "clojure.core" "class" jolt-class) diff --git a/host/chez/host-table.ss b/host/chez/host-table.ss index bd2ed29..4fa54f7 100644 --- a/host/chez/host-table.ss +++ b/host/chez/host-table.ss @@ -136,8 +136,8 @@ (cond ((htable-sorted? a) (%h-jolt=2 (sorted->plain a) (if (htable-sorted? b) (sorted->plain b) b))) ((htable-sorted? b) (%h-jolt=2 a (sorted->plain b))) (else (%h-jolt=2 a b))))) -(define %h-jolt-hash jolt-hash) -(set! jolt-hash (lambda (x) (if (htable-sorted? x) (%h-jolt-hash (sorted->plain x)) (%h-jolt-hash x)))) +;; a sorted coll hashes as its plain equivalent (jolt-hash recurses through the base). +(register-hash-arm! htable-sorted? (lambda (x) (jolt-hash (sorted->plain x)))) ;; --- printing ---------------------------------------------------------------- ;; sorted colls render in SORTED order (the value's :seq), not HAMT order — and @@ -177,8 +177,6 @@ ;; (class e) on a throwable tagged-table (a library's ex-info envelope carrying a ;; JVM :class, e.g. jolt-lang/http-client's UnknownHostException) reads that ;; class name, so clojure.test's (thrown? Class …) / (= Class (class e)) match. -(define %h-class jolt-class) -(set! jolt-class (lambda (x) - (let ((c (and (htable? x) (hashtable-ref (htable-h x) "class" #f)))) - (if (and c (string? c)) c (%h-class x))))) -(def-var! "clojure.core" "class" jolt-class) +;; an htable carrying a string "class" entry reports it (a host-object class mirror). +(register-class-arm! (lambda (x) (and (htable? x) (string? (hashtable-ref (htable-h x) "class" #f)))) + (lambda (x) (hashtable-ref (htable-h x) "class" #f))) diff --git a/host/chez/inst-time.ss b/host/chez/inst-time.ss index 55434bd..d1ac076 100644 --- a/host/chez/inst-time.ss +++ b/host/chez/inst-time.ss @@ -247,8 +247,7 @@ ((jinst? b) #f) (else (%it-=2 a b))))) -(define %it-hash jolt-hash) -(set! jolt-hash (lambda (x) (if (jinst? x) (jolt-hash (jinst-ms x)) (%it-hash x)))) +(register-hash-arm! jinst? (lambda (x) (jolt-hash (jinst-ms x)))) (define (inst-pr i) (string-append "#inst \"" (inst-rfc3339 i) "\"")) (define %it-pr-str jolt-pr-str) diff --git a/host/chez/natives-queue.ss b/host/chez/natives-queue.ss index a888017..c9170f8 100644 --- a/host/chez/natives-queue.ss +++ b/host/chez/natives-queue.ss @@ -49,9 +49,7 @@ (register-str-render! jolt-queue? (lambda (x) (jolt-str-render-one (jolt-seq-or-empty x)))) ;; class / type / instance? recognize a queue. -(define %q-class jolt-class) -(set! jolt-class (lambda (x) (if (jolt-queue? x) "clojure.lang.PersistentQueue" (%q-class x)))) -(def-var! "clojure.core" "class" jolt-class) +(register-class-arm! jolt-queue? (lambda (x) "clojure.lang.PersistentQueue")) (register-instance-check-arm! (lambda (type-sym val) (if (jolt-queue? val) diff --git a/host/chez/records.ss b/host/chez/records.ss index 1174c9e..6cf73b3 100644 --- a/host/chez/records.ss +++ b/host/chez/records.ss @@ -67,8 +67,7 @@ (cond ((jrec? a) (and (jrec? b) (jrec=? a b))) ((jrec? b) #f) (else (%r-jolt=2 a b))))) -(define %r-jolt-hash jolt-hash) -(set! jolt-hash (lambda (x) (if (jrec? x) (jrec-hash x) (%r-jolt-hash x)))) +(register-hash-arm! jrec? jrec-hash) (define %r-jolt-get jolt-get) (set! jolt-get (case-lambda ((coll k) (if (jrec? coll) (jrec-lookup coll k jolt-nil) (%r-jolt-get coll k))) diff --git a/host/chez/values.ss b/host/chez/values.ss index a8f5eda..32cf788 100644 --- a/host/chez/values.ss +++ b/host/chez/values.ss @@ -70,7 +70,14 @@ (else #f)))) ;; --- jolt hash — consistent with jolt= (for the HAMT) ----------------------- -(define (jolt-hash x) +;; A host shim (records, host-table, inst-time, …) registers its type's hash via +;; register-hash-arm! instead of set!-wrapping jolt-hash — the arms are disjoint +;; types, checked before the base cases, so the full behavior is gathered here plus +;; the registry rather than scattered across a set! chain (cf. register-str-render!). +(define jolt-hash-arms '()) +(define (register-hash-arm! pred handler) + (set! jolt-hash-arms (cons (cons pred handler) jolt-hash-arms))) +(define (jolt-hash-base x) (cond ((jolt-nil? x) 0) ((keyword-t? x) (keyword-t-khash x)) @@ -87,3 +94,8 @@ ((jolt-sequential? x) (seq-hash x)) ; vector/list/seq hash alike (forward to seq.ss) ((jolt-coll? x) (jolt-coll-hash x)) ; map/set; forward to collections.ss (else (equal-hash x)))) +(define (jolt-hash x) + (let loop ((as jolt-hash-arms)) + (cond ((null? as) (jolt-hash-base x)) + (((caar as) x) ((cdar as) x)) + (else (loop (cdr as))))))