From acf3e1ffd320f2bdc74bb431f083af69c790cf95 Mon Sep 17 00:00:00 2001 From: Yogthos Date: Tue, 23 Jun 2026 23:12:08 -0400 Subject: [PATCH] refactor: registry pattern for jolt-get + jolt=2 (jolt-lmot) jolt-get (4 sites: host-table/natives-misc/inst-time/records) and jolt=2 (6 sites: records/vars/inst-time/natives-misc/bigdec/host-table) move off the set!-rebind chains to register-get-arm! / register-eq-arm!. get's case-lambda becomes a stable 2/3-arg entry over a 3-arg dispatch; the equality arm pred is (a b) since either arg may carry the type, and the host-table sorted arm normalizes-then-re-dispatches. Behaviour-preserving (runtime .ss): var/inst/bigdec/record/uuid equality, record!=map, sorted-map=plain-map, and all the get cases verified; make test green, 0 new corpus divergences. Four of six dispatchers done; the printer (pr-str/pr-readable) remains. --- host/chez/bigdec.ss | 7 ++----- host/chez/collections.ss | 28 ++++++++++++++++++++-------- host/chez/host-table.ss | 15 ++++++--------- host/chez/inst-time.ss | 20 +++++++------------- host/chez/natives-misc.ss | 20 +++++++------------- host/chez/records.ss | 12 +++--------- host/chez/values.ss | 15 ++++++++++++++- host/chez/vars.ss | 11 ++++------- 8 files changed, 63 insertions(+), 65 deletions(-) diff --git a/host/chez/bigdec.ss b/host/chez/bigdec.ss index ddbd933..fcc260d 100644 --- a/host/chez/bigdec.ss +++ b/host/chez/bigdec.ss @@ -61,11 +61,8 @@ (def-var! "clojure.core" "bigdec" jolt-bigdec) ;; equality: a bigdec equals only another bigdec, by value (matching (= 3M 3) = false). -(define %bd-jolt=2 jolt=2) -(set! jolt=2 (lambda (a b) - (cond ((and (jbigdec? a) (jbigdec? b)) (jbigdec=? a b)) - ((or (jbigdec? a) (jbigdec? b)) #f) - (else (%bd-jolt=2 a b))))) +(register-eq-arm! (lambda (a b) (or (jbigdec? a) (jbigdec? b))) + (lambda (a b) (and (jbigdec? a) (jbigdec? b) (jbigdec=? a b)))) ;; str drops the M; pr/pr-str keep it. (register-str-render! jbigdec? jbigdec->string) diff --git a/host/chez/collections.ss b/host/chez/collections.ss index c538b73..fa51cd0 100644 --- a/host/chez/collections.ss +++ b/host/chez/collections.ss @@ -225,16 +225,28 @@ (fold-left jolt-conj1 jolt-empty-list xs) (fold-left jolt-conj1 coll xs))))) +;; A host shim registers a type's get via register-get-arm! (handler: (coll k d) -> +;; value) instead of set!-wrapping jolt-get — disjoint coll types, checked before the +;; base map/set/vec/string cases (cf. register-hash-arm!). +(define jolt-get-arms '()) +(define (register-get-arm! pred handler) + (set! jolt-get-arms (cons (cons pred handler) jolt-get-arms))) +(define (jolt-get-base coll k d) + (cond ((pmap? coll) (pmap-get coll k d)) + ((pset? coll) (if (pset-contains? coll k) k d)) + ((pvec? coll) (pvec-nth-d coll k d)) + ((string? coll) (let ((i (->idx k))) + (if (and (fixnum? i) (fx>=? i 0) (fxidx k))) - (if (and (fixnum? i) (fx>=? i 0) (fxpset sc) (fold-left (lambda (s x) (pset-conj s x)) empty-pset (seq->list (sc-call sc kw-op-seq)))) (define (sorted->plain x) (if (htable-sorted-map? x) (sorted-map->pmap x) (sorted-set->pset x))) -(define %h-jolt=2 jolt=2) -(set! jolt=2 (lambda (a b) - (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))))) +;; a sorted coll compares as its plain equivalent: normalize and re-dispatch (the +;; normalized values aren't sorted, so this arm won't re-match — the base compares). +(register-eq-arm! (lambda (a b) (or (htable-sorted? a) (htable-sorted? b))) + (lambda (a b) (jolt=2 (if (htable-sorted? a) (sorted->plain a) a) + (if (htable-sorted? b) (sorted->plain b) b)))) ;; 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)))) diff --git a/host/chez/inst-time.ss b/host/chez/inst-time.ss index d1ac076..104e286 100644 --- a/host/chez/inst-time.ss +++ b/host/chez/inst-time.ss @@ -232,20 +232,14 @@ (define kw-ms (keyword #f "ms")) (define inst-type-kw (keyword "jolt" "inst")) -(define %it-get jolt-get) -(set! jolt-get (case-lambda - ((coll k) (jolt-get coll k jolt-nil)) - ((coll k d) (if (jinst? coll) - (cond ((jolt=2 k kw-jolt-type) inst-type-kw) - ((jolt=2 k kw-ms) (jinst-ms coll)) - (else d)) - (%it-get coll k d))))) +(register-get-arm! jinst? + (lambda (coll k d) + (cond ((jolt=2 k kw-jolt-type) inst-type-kw) + ((jolt=2 k kw-ms) (jinst-ms coll)) + (else d)))) -(define %it-=2 jolt=2) -(set! jolt=2 (lambda (a b) - (cond ((jinst? a) (and (jinst? b) (= (jinst-ms a) (jinst-ms b)))) - ((jinst? b) #f) - (else (%it-=2 a b))))) +(register-eq-arm! (lambda (a b) (or (jinst? a) (jinst? b))) + (lambda (a b) (and (jinst? a) (jinst? b) (= (jinst-ms a) (jinst-ms b))))) (register-hash-arm! jinst? (lambda (x) (jolt-hash (jinst-ms x)))) diff --git a/host/chez/natives-misc.ss b/host/chez/natives-misc.ss index 1b9c84d..d610f72 100644 --- a/host/chez/natives-misc.ss +++ b/host/chez/natives-misc.ss @@ -58,11 +58,8 @@ (define %m-pr-readable jolt-pr-readable) (set! jolt-pr-readable (lambda (x) (if (juuid? x) (juuid-pr x) (%m-pr-readable x)))) ;; two uuids are = iff same string. -(define %m-=2 jolt=2) -(set! jolt=2 (lambda (a b) - (cond ((juuid? a) (and (juuid? b) (string=? (juuid-s a) (juuid-s b)))) - ((juuid? b) #f) - (else (%m-=2 a b))))) +(register-eq-arm! (lambda (a b) (or (juuid? a) (juuid? b))) + (lambda (a b) (and (juuid? a) (juuid? b) (string=? (juuid-s a) (juuid-s b))))) ;; --- bigint / biginteger ----------------------------------------------------- ;; jolt models every number as a double; an integer-valued double prints without @@ -80,14 +77,11 @@ (define (jolt-tagged-literal-pred? x) (jtagged? x)) (define kw-tl-tag (keyword #f "tag")) (define kw-tl-form (keyword #f "form")) -(define %m-get jolt-get) -(set! jolt-get (case-lambda - ((coll k) (if (jtagged? coll) (jolt-get coll k jolt-nil) (%m-get coll k))) - ((coll k d) (if (jtagged? coll) - (cond ((jolt=2 k kw-tl-tag) (jtagged-tag coll)) - ((jolt=2 k kw-tl-form) (jtagged-form coll)) - (else d)) - (%m-get coll k d))))) +(register-get-arm! jtagged? + (lambda (coll k d) + (cond ((jolt=2 k kw-tl-tag) (jtagged-tag coll)) + ((jolt=2 k kw-tl-form) (jtagged-form coll)) + (else d)))) (define (jtagged-pr t) (string-append "#" (jolt-pr-str (jtagged-tag t)) " " (jolt-pr-readable (jtagged-form t)))) (define %m2-pr-str jolt-pr-str) (set! jolt-pr-str (lambda (x) (if (jtagged? x) (jtagged-pr x) (%m2-pr-str x)))) diff --git a/host/chez/records.ss b/host/chez/records.ss index 6cf73b3..2f94604 100644 --- a/host/chez/records.ss +++ b/host/chez/records.ss @@ -62,16 +62,10 @@ "}")) ;; ---- extend the collection dispatchers with a jrec arm ---------------------- -(define %r-jolt=2 jolt=2) -(set! jolt=2 (lambda (a b) - (cond ((jrec? a) (and (jrec? b) (jrec=? a b))) - ((jrec? b) #f) - (else (%r-jolt=2 a b))))) +(register-eq-arm! (lambda (a b) (or (jrec? a) (jrec? b))) + (lambda (a b) (and (jrec? a) (jrec? b) (jrec=? a b)))) (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))) - ((coll k d) (if (jrec? coll) (jrec-lookup coll k d) (%r-jolt-get coll k d))))) +(register-get-arm! jrec? (lambda (coll k d) (jrec-lookup coll k d))) (define %r-jolt-count jolt-count) (set! jolt-count (lambda (coll) (if (jrec? coll) (length (jrec-pairs coll)) (%r-jolt-count coll)))) (define %r-jolt-contains? jolt-contains?) diff --git a/host/chez/values.ss b/host/chez/values.ss index 32cf788..b0ebed5 100644 --- a/host/chez/values.ss +++ b/host/chez/values.ss @@ -43,7 +43,15 @@ ;; chars/strings: Chez natives (strings treated immutable). ;; --- jolt equality (Clojure =) — scalars + collections ---------------------- -(define (jolt=2 a b) +;; A host shim registers a type's equality via register-eq-arm! instead of +;; set!-wrapping jolt=2 (cf. register-hash-arm!). An arm is (pred . handler), both +;; (a b): the arm applies when pred holds (typically either arg is the type), and +;; handler returns the #t/#f result. Arms are checked before the base scalar/coll +;; cases; the entry is stable. +(define jolt-eq-arms '()) +(define (register-eq-arm! pred handler) + (set! jolt-eq-arms (cons (cons pred handler) jolt-eq-arms))) +(define (jolt=2-base a b) (cond ((and (jolt-nil? a) (jolt-nil? b)) #t) ((or (jolt-nil? a) (jolt-nil? b)) #f) @@ -63,6 +71,11 @@ ;; other collections (map/set): forward to collections.ss. ((and (jolt-coll? a) (jolt-coll? b)) (jolt-coll=? a b)) (else (eq? a b)))) +(define (jolt=2 a b) + (let loop ((as jolt-eq-arms)) + (cond ((null? as) (jolt=2-base a b)) + (((caar as) a b) ((cdar as) a b)) + (else (loop (cdr as)))))) (define (jolt= a . rest) (let loop ((a a) (rest rest)) (cond ((null? rest) #t) diff --git a/host/chez/vars.ss b/host/chez/vars.ss index 123fb1a..1d53ed8 100644 --- a/host/chez/vars.ss +++ b/host/chez/vars.ss @@ -31,13 +31,10 @@ (if (var-cell? f) (apply jolt-invoke (var-cell-root f) args) (apply %v-invoke f args)))) ;; two var cells are = iff same ns/name (Clojure var identity). -(define %v-=2 jolt=2) -(set! jolt=2 (lambda (a b) - (cond ((var-cell? a) (and (var-cell? b) - (string=? (var-cell-ns a) (var-cell-ns b)) - (string=? (var-cell-name a) (var-cell-name b)))) - ((var-cell? b) #f) - (else (%v-=2 a b))))) +(register-eq-arm! (lambda (a b) (or (var-cell? a) (var-cell? b))) + (lambda (a b) (and (var-cell? a) (var-cell? b) + (string=? (var-cell-ns a) (var-cell-ns b)) + (string=? (var-cell-name a) (var-cell-name b))))) ;; pr-str / str of a var -> #'ns/name. (define (var->str v) (string-append "#'" (var-cell-ns v) "/" (var-cell-name v)))