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

refactor: registry pattern for jolt-get + jolt=2 (jolt-lmot)

Browse source 
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.
This commit is contained in:
Yogthos 2026-06-23 23:12:08 -04:00
parent d168d1195b
commit acf3e1ffd3
8 changed files with 63 additions and 65 deletions
Download patch file Download diff file Expand all files Collapse all files

7
host/chez/bigdec.ss
View file

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

28
host/chez/collections.ss
View file

@ -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) (fx<? i (string-length coll))) (string-ref coll i) 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 coll k jolt-nil))
((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)))))
((coll k) (jolt-get-dispatch coll k jolt-nil))
((coll k d) (jolt-get-dispatch coll k d))))
(define jolt-nth
(case-lambda

15
host/chez/host-table.ss
View file

@ -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)
(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)))))
(register-get-arm! htable-sorted? (lambda (coll k d) (sc-call coll kw-op-get 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)
(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))))

20
host/chez/inst-time.ss
View file

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

20
host/chez/natives-misc.ss
View file

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

12
host/chez/records.ss
View file

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

15
host/chez/values.ss
View file

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

11
host/chez/vars.ss
View file

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