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

View file

@ -7,7 +7,10 @@
;; ;;
;; Loaded after records.ss (jrec) + collections/seq/values (the ctors it copies). ;; 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) (define (jolt-meta x)
(cond (cond
@ -31,7 +34,9 @@
((pmap? x) (make-pmap (pmap-root x) (pmap-cnt x))) ((pmap? x) (make-pmap (pmap-root x) (pmap-cnt x)))
((pset? x) (make-pset (pset-m x))) ((pset? x) (make-pset (pset-m x)))
((jrec? x) (make-jrec (jrec-tag x) (jrec-pairs 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) (define (jolt-with-meta x m)
(cond (cond
@ -45,6 +50,20 @@
(def-var! "clojure.core" "meta" jolt-meta) (def-var! "clojure.core" "meta" jolt-meta)
(def-var! "clojure.core" "with-meta" jolt-with-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 ;; (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 ;; "class" is a host taxonomy: a record yields its ns-qualified class-name SYMBOL
;; (user.TyR), everything else a keyword (:number/:vector/:seq/…). ;; (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) (if (cseq-forced? s) (cseq-tail s)
(let ((t ((cseq-tail s)))) (cseq-tail-set! s t) (cseq-forced?-set! s #t) t))) (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. ;; The empty seq (Clojure's empty list ()), distinct from nil. The (unused) field
(define-record-type empty-list-t (fields) (nongenerative empty-list-v1)) ;; defeats Chez's interning of fieldless records, so an empty list carrying
(define jolt-empty-list (make-empty-list-t)) ;; 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 ;; reduced: a box a reducing fn returns to stop reduce early. The
;; reduce machinery below unwraps it; (deref a-reduced) / unreduced also read it. ;; 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, ;; 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. ;; nil), so those keep the old per-step jolt-conj behaviour.
(define (jolt-into to from) (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-from n) (cseq-lazy n (lambda () (range-from (+ n 1)))))
(define (range-bounded n end step) (define (range-bounded n end step)

View file

@ -146,7 +146,8 @@
;; persistent disj over sets (pset-disj already exists in collections.ss). ;; persistent disj over sets (pset-disj already exists in collections.ss).
(define (jolt-disj s . xs) (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 --------------------------------------------------- ;; --- see-through accessors ---------------------------------------------------
(define (tvec-in-bounds? t i) (and (fixnum? i) (fx>=? i 0) (fx<? i (jolt-transient-n t)))) (define (tvec-in-bounds? t i) (and (fixnum? i) (fx>=? i 0) (fx<? i (jolt-transient-n t))))

View file

@ -103,17 +103,18 @@
(defn reverse [coll] (reduce conj (list) coll)) (defn reverse [coll] (reduce conj (list) coll))
;; An empty coll of the same category; sorted colls keep their comparator (the ;; An empty coll of the same category, carrying the receiver's metadata (Clojure's
;; .empty() does EMPTY.withMeta(meta())). Sorted colls keep their comparator (the
;; value's own :empty op). Strings and scalars are nil, as in Clojure; a lazy ;; value's own :empty op). Strings and scalars are nil, as in Clojure; a lazy
;; seq empties to (). ;; seq empties to ().
(defn empty [coll] (defn empty [coll]
(cond (cond
(nil? coll) nil (nil? coll) nil
(sorted? coll) ((get (jolt.host/ref-get coll :ops) :empty) coll) (sorted? coll) ((get (jolt.host/ref-get coll :ops) :empty) coll)
(map? coll) {} (map? coll) (with-meta {} (meta coll))
(set? coll) #{} (set? coll) (with-meta #{} (meta coll))
(vector? coll) [] (vector? coll) (with-meta [] (meta coll))
(coll? coll) () (coll? coll) (with-meta () (meta coll))
:else nil)) :else nil))
(defn assoc-in [m [k & ks] v] (defn assoc-in [m [k & ks] v]