Collection ops carry the receiver's metadata

conj/assoc/dissoc/disj/pop/into and empty now thread the receiver's
metadata onto the result, matching Clojure (each op constructs a new
collection with meta() carried forward; coll.empty() is
EMPTY.withMeta(meta())). The metadata side-table is now weak so meta on
intermediate collections is reclaimed with them, and empty-list-t carries
an (unused) field so a metadata-bearing () is a distinct identity from the
shared singleton instead of leaking meta onto every ().

Unblocks metadata-driven walks (aero/integrant): (into (empty form) ...)
now preserves a vector/map/set's metadata, so a postwalk whose outer fn
reads (meta x) sees it.
This commit is contained in:
Yogthos 2026-06-24 13:46:58 -04:00
parent 5b55c7f7b0
commit 4ae3d3116e
7 changed files with 484 additions and 457 deletions

View file

@ -223,7 +223,7 @@
(let ((coll (car args)) (xs (cdr args)))
(if (jolt-nil? coll)
(fold-left jolt-conj1 jolt-empty-list xs)
(fold-left jolt-conj1 coll xs)))))
(meta-carry coll (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
@ -287,14 +287,15 @@
((jolt-nil? coll) (pmap-assoc empty-pmap k v))
(else (error 'assoc "unsupported collection"))))
(define (jolt-assoc coll . kvs)
(let loop ((coll coll) (kvs kvs))
(cond ((null? kvs) coll)
((null? (cdr kvs)) (error 'assoc "assoc expects an even number of key/vals"))
(else (loop (jolt-assoc1 coll (car kvs) (cadr kvs)) (cddr kvs))))))
(meta-carry coll
(let loop ((coll coll) (kvs kvs))
(cond ((null? kvs) coll)
((null? (cdr kvs)) (error 'assoc "assoc expects an even number of key/vals"))
(else (loop (jolt-assoc1 coll (car kvs) (cadr kvs)) (cddr kvs)))))))
(define (jolt-dissoc coll . ks)
(cond ((jolt-nil? coll) jolt-nil)
((pmap? coll) (fold-left pmap-dissoc coll ks))
((pmap? coll) (meta-carry coll (fold-left pmap-dissoc coll ks)))
(else (error 'dissoc "unsupported collection"))))
(define (jolt-contains? coll k)
@ -319,8 +320,8 @@
((or (cseq? coll) (empty-list-t? coll)) (jolt-first coll)) ; list peek = first
((jolt-nil? coll) jolt-nil) (else (error 'peek "unsupported collection"))))
(define (jolt-pop coll)
(cond ((pvec? coll) (pvec-pop coll))
((cseq? coll) (jolt-rest coll)) ; list pop = rest
(cond ((pvec? coll) (meta-carry coll (pvec-pop coll)))
((cseq? coll) (meta-carry coll (jolt-rest coll))) ; list pop = rest
((empty-list-t? coll) (error 'pop "can't pop empty list"))
(else (error 'pop "unsupported collection"))))

View file

@ -7,7 +7,10 @@
;;
;; Loaded after records.ss (jrec) + collections/seq/values (the ctors it copies).
(define meta-table (make-eq-hashtable))
;; Weak so a collection's metadata is reclaimed with the collection — collection
;; ops (conj/assoc/into) carry meta forward onto fresh values, so a strong table
;; would retain every meta-bearing intermediate.
(define meta-table (make-weak-eq-hashtable))
(define (jolt-meta x)
(cond
@ -31,7 +34,9 @@
((pmap? x) (make-pmap (pmap-root x) (pmap-cnt x)))
((pset? x) (make-pset (pset-m x)))
((jrec? x) (make-jrec (jrec-tag x) (jrec-pairs x)))
(else x))) ; cseq / empty-list / procedure
;; () is a shared singleton — a fresh instance keeps meta off every other ().
((empty-list-t? x) (fresh-empty-list))
(else x))) ; cseq / procedure
(define (jolt-with-meta x m)
(cond
@ -45,6 +50,20 @@
(def-var! "clojure.core" "meta" jolt-meta)
(def-var! "clojure.core" "with-meta" jolt-with-meta)
;; Carry SRC's collection metadata onto DST (a freshly-built collection of the
;; same kind), as Clojure's ops do — each new collection threads its receiver's
;; meta() forward. Returns DST. The size check is the fast path: programs that
;; never attach collection metadata pay one O(1) check per op, no lookup.
(define (meta-carry src dst)
(if (fx=? 0 (hashtable-size meta-table))
dst
(let ((m (hashtable-ref meta-table src #f)))
(if m
;; never attach to the shared () singleton — use a fresh instance
(let ((d (if (empty-list-t? dst) (fresh-empty-list) dst)))
(hashtable-set! meta-table d m) d)
dst))))
;; (type x) — Clojure's (or (:type (meta x)) (class x)). With no JVM classes the
;; "class" is a host taxonomy: a record yields its ns-qualified class-name SYMBOL
;; (user.TyR), everything else a keyword (:number/:vector/:seq/…).

File diff suppressed because one or more lines are too long

File diff suppressed because one or more lines are too long

View file

@ -41,9 +41,13 @@
(if (cseq-forced? s) (cseq-tail s)
(let ((t ((cseq-tail s)))) (cseq-tail-set! s t) (cseq-forced?-set! s #t) t)))
;; The empty seq (Clojure's empty list ()), distinct from nil.
(define-record-type empty-list-t (fields) (nongenerative empty-list-v1))
(define jolt-empty-list (make-empty-list-t))
;; The empty seq (Clojure's empty list ()), distinct from nil. The (unused) field
;; defeats Chez's interning of fieldless records, so an empty list carrying
;; metadata (an `empty`/`pop`/`with-meta` result) is a distinct identity from the
;; shared jolt-empty-list — otherwise its meta would leak onto every ().
(define-record-type empty-list-t (fields _) (nongenerative empty-list-v2))
(define (fresh-empty-list) (make-empty-list-t #f))
(define jolt-empty-list (fresh-empty-list))
;; reduced: a box a reducing fn returns to stop reduce early. The
;; reduce machinery below unwraps it; (deref a-reduced) / unreduced also read it.
@ -212,7 +216,8 @@
;; falls back to a copy-on-write wrapper for other targets (lists, sorted colls,
;; nil), so those keep the old per-step jolt-conj behaviour.
(define (jolt-into to from)
(jolt-persistent! (reduce-seq (lambda (t x) (jolt-conj! t x)) (jolt-transient-new to) (jolt-seq from))))
(meta-carry to
(jolt-persistent! (reduce-seq (lambda (t x) (jolt-conj! t x)) (jolt-transient-new to) (jolt-seq from)))))
(define (range-from n) (cseq-lazy n (lambda () (range-from (+ n 1)))))
(define (range-bounded n end step)

View file

@ -146,7 +146,8 @@
;; persistent disj over sets (pset-disj already exists in collections.ss).
(define (jolt-disj s . xs)
(let loop ((s s) (xs xs)) (if (null? xs) s (loop (pset-disj s (car xs)) (cdr xs)))))
(meta-carry s
(let loop ((s s) (xs xs)) (if (null? xs) s (loop (pset-disj s (car xs)) (cdr xs))))))
;; --- see-through accessors ---------------------------------------------------
(define (tvec-in-bounds? t i) (and (fixnum? i) (fx>=? i 0) (fx<? i (jolt-transient-n t))))