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

@@ -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)
+(register-eq-arm! (lambda (a b) (or (jbigdec? a) (jbigdec? b)))
-(set! jolt=2 (lambda (a b)
+                  (lambda (a b) (and (jbigdec? a) (jbigdec? b) (jbigdec=? a b))))
-  (cond ((and (jbigdec? a) (jbigdec? b)) (jbigdec=? a b))
-        ((or (jbigdec? a) (jbigdec? b)) #f)
-        (else (%bd-jolt=2 a b)))))
 
 ;; str drops the M; pr/pr-str keep it.
 (register-str-render! jbigdec? jbigdec->string)

host/chez/collections.ss

@@ -225,16 +225,28 @@
             (fold-left jolt-conj1 jolt-empty-list xs)
             (fold-left jolt-conj1 coll xs)))))
 
-(define jolt-get
+;; A host shim registers a type's get via register-get-arm! (handler: (coll k d) ->
-  (case-lambda
+;; value) instead of set!-wrapping jolt-get — disjoint coll types, checked before the
-    ((coll k) (jolt-get coll k jolt-nil))
+;; base map/set/vec/string cases (cf. register-hash-arm!).
-    ((coll k d)
+(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) (fx<? i (string-length coll))) (string-ref coll i) d)))
-           (else d)))))
+        (else d)))
+(define (jolt-get-dispatch coll k d)
+  (let loop ((as jolt-get-arms))
+    (cond ((null? as) (jolt-get-base coll k d))
+          (((caar as) coll) ((cdar as) coll k d))
+          (else (loop (cdr as))))))
+(define jolt-get
+  (case-lambda
+    ((coll k) (jolt-get-dispatch coll k jolt-nil))
+    ((coll k d) (jolt-get-dispatch coll k d))))
 
 (define jolt-nth
   (case-lambda

host/chez/host-table.ss

@@ -72,10 +72,7 @@
 (set! jolt-seq (lambda (x) (if (htable-sorted? x) (sc-call x kw-op-seq) (%h-seq x))))
 (define %h-count jolt-count)
 (set! jolt-count (lambda (coll) (if (htable-sorted? coll) (sc-call coll kw-op-count) (%h-count coll))))
-(define %h-get jolt-get)
+(register-get-arm! htable-sorted? (lambda (coll k d) (sc-call coll kw-op-get k d)))
-(set! jolt-get (case-lambda
-  ((coll k)   (if (htable-sorted? coll) (sc-call coll kw-op-get k jolt-nil) (%h-get coll k)))
-  ((coll k d) (if (htable-sorted? coll) (sc-call coll kw-op-get k d) (%h-get coll k d)))))
 (define %h-contains? jolt-contains?)
 (set! jolt-contains? (lambda (coll k)
   (if (htable-sorted? coll) (if (jolt-truthy? (sc-call coll kw-op-contains k)) #t #f) (%h-contains? coll k))))
@@ -131,11 +128,11 @@
 (define (sorted-set->pset 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)
+;; a sorted coll compares as its plain equivalent: normalize and re-dispatch (the
-(set! jolt=2 (lambda (a b)
+;; normalized values aren't sorted, so this arm won't re-match — the base compares).
-  (cond ((htable-sorted? a) (%h-jolt=2 (sorted->plain a) (if (htable-sorted? b) (sorted->plain b) b)))
+(register-eq-arm! (lambda (a b) (or (htable-sorted? a) (htable-sorted? b)))
-        ((htable-sorted? b) (%h-jolt=2 a (sorted->plain b)))
+                  (lambda (a b) (jolt=2 (if (htable-sorted? a) (sorted->plain a) a)
-        (else (%h-jolt=2 a b)))))
+                                        (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))))
 

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)
+(register-get-arm! jinst?
-(set! jolt-get (case-lambda
+  (lambda (coll k d)
-  ((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))
+          (else d))))
-                  (%it-get coll k d)))))
 
-(define %it-=2 jolt=2)
+(register-eq-arm! (lambda (a b) (or (jinst? a) (jinst? b)))
-(set! jolt=2 (lambda (a b)
+                  (lambda (a b) (and (jinst? a) (jinst? b) (= (jinst-ms a) (jinst-ms b)))))
-  (cond ((jinst? a) (and (jinst? b) (= (jinst-ms a) (jinst-ms b))))
-        ((jinst? b) #f)
-        (else (%it-=2 a b)))))
 
 (register-hash-arm! jinst? (lambda (x) (jolt-hash (jinst-ms x))))
 

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)
+(register-eq-arm! (lambda (a b) (or (juuid? a) (juuid? b)))
-(set! jolt=2 (lambda (a b)
+                  (lambda (a b) (and (juuid? a) (juuid? b) (string=? (juuid-s a) (juuid-s b)))))
-  (cond ((juuid? a) (and (juuid? b) (string=? (juuid-s a) (juuid-s b))))
-        ((juuid? b) #f)
-        (else (%m-=2 a 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)
+(register-get-arm! jtagged?
-(set! jolt-get (case-lambda
+  (lambda (coll k d)
-  ((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))
+          (else d))))
-                  (%m-get coll k 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))))

host/chez/records.ss

@@ -62,16 +62,10 @@
     "}"))
 
 ;; ---- extend the collection dispatchers with a jrec arm ----------------------
-(define %r-jolt=2 jolt=2)
+(register-eq-arm! (lambda (a b) (or (jrec? a) (jrec? b)))
-(set! jolt=2 (lambda (a b)
+                  (lambda (a b) (and (jrec? a) (jrec? b) (jrec=? a b))))
-  (cond ((jrec? a) (and (jrec? b) (jrec=? a b)))
-        ((jrec? b) #f)
-        (else (%r-jolt=2 a b)))))
 (register-hash-arm! jrec? jrec-hash)
-(define %r-jolt-get jolt-get)
+(register-get-arm! jrec? (lambda (coll k d) (jrec-lookup coll k d)))
-(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)))))
 (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?)

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)

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)
+(register-eq-arm! (lambda (a b) (or (var-cell? a) (var-cell? b)))
-(set! jolt=2 (lambda (a b)
+                  (lambda (a b) (and (var-cell? a) (var-cell? 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))))
+                                     (string=? (var-cell-name a) (var-cell-name b)))))
-        ((var-cell? b) #f)
-        (else (%v-=2 a b)))))
 
 ;; pr-str / str of a var -> #'ns/name.
 (define (var->str v) (string-append "#'" (var-cell-ns v) "/" (var-cell-name v)))