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

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