Merge pull request #190 from jolt-lang/spike/coll-ops-metadata

Collection ops carry the receiver's metadata

host/chez/collections.ss

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

host/chez/natives-meta.ss

@@ -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/…).

host/chez/seq.ss

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

host/chez/transients.ss

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

jolt-core/clojure/core/22-coll.clj

@@ -103,17 +103,18 @@
 
 (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
 ;; seq empties to ().
 (defn empty [coll]
   (cond
     (nil? coll) nil
     (sorted? coll) ((get (jolt.host/ref-get coll :ops) :empty) coll)
-    (map? coll) {}
-    (set? coll) #{}
-    (vector? coll) []
-    (coll? coll) ()
+    (map? coll) (with-meta {} (meta coll))
+    (set? coll) (with-meta #{} (meta coll))
+    (vector? coll) (with-meta [] (meta coll))
+    (coll? coll) (with-meta () (meta coll))
     :else nil))
 
 (defn assoc-in [m [k & ks] v]

test/chez/corpus.edn

@@ -1063,6 +1063,22 @@
   {:suite "metadata / clojure.edn preserves meta" :label "edn vector meta" :expected "{:ref true}" :actual "(do (require (quote [clojure.edn :as e1])) (meta (e1/read-string \"^:ref [:greeting]\")))"}
   {:suite "metadata / clojure.edn preserves meta" :label "edn map meta" :expected "{:m true}" :actual "(do (require (quote [clojure.edn :as e1])) (meta (e1/read-string \"^:m {:a 1}\")))"}
   {:suite "metadata / clojure.edn preserves meta" :label "edn set meta" :expected "{:s true}" :actual "(do (require (quote [clojure.edn :as e1])) (meta (e1/read-string \"^:s #{1}\")))"}
+  {:suite "metadata / collection ops preserve meta" :label "empty keeps vector meta" :expected "{:k 9}" :actual "(meta (empty (with-meta [1] {:k 9})))"}
+  {:suite "metadata / collection ops preserve meta" :label "empty keeps map meta" :expected "{:k 9}" :actual "(meta (empty (with-meta {:a 1} {:k 9})))"}
+  {:suite "metadata / collection ops preserve meta" :label "empty keeps set meta" :expected "{:k 9}" :actual "(meta (empty (with-meta #{1} {:k 9})))"}
+  {:suite "metadata / collection ops preserve meta" :label "empty keeps list meta" :expected "{:k 9}" :actual "(meta (empty (with-meta (list 1) {:k 9})))"}
+  {:suite "metadata / collection ops preserve meta" :label "into empty keeps meta" :expected "{:k 9}" :actual "(meta (into (empty (with-meta {:a 1} {:k 9})) {:b 2}))"}
+  {:suite "metadata / collection ops preserve meta" :label "into target meta" :expected "{:k 9}" :actual "(meta (into (with-meta [] {:k 9}) [1 2]))"}
+  {:suite "metadata / collection ops preserve meta" :label "conj on vector" :expected "{:k 9}" :actual "(meta (conj (with-meta [1] {:k 9}) 2))"}
+  {:suite "metadata / collection ops preserve meta" :label "conj on list" :expected "{:k 9}" :actual "(meta (conj (with-meta (list 1) {:k 9}) 2))"}
+  {:suite "metadata / collection ops preserve meta" :label "assoc on map" :expected "{:k 9}" :actual "(meta (assoc (with-meta {:a 1} {:k 9}) :b 2))"}
+  {:suite "metadata / collection ops preserve meta" :label "dissoc on map" :expected "{:k 9}" :actual "(meta (dissoc (with-meta {:a 1 :c 3} {:k 9}) :c))"}
+  {:suite "metadata / collection ops preserve meta" :label "disj on set" :expected "{:k 9}" :actual "(meta (disj (with-meta #{1 2} {:k 9}) 2))"}
+  {:suite "metadata / collection ops preserve meta" :label "pop on vector" :expected "{:k 9}" :actual "(meta (pop (with-meta [1 2] {:k 9})))"}
+  {:suite "metadata / collection ops preserve meta" :label "op without meta is nil" :expected "nil" :actual "(meta (conj [1] 2))"}
+  {:suite "metadata / collection ops preserve meta" :label "value preserved through conj" :expected "[1 2]" :actual "(conj (with-meta [1] {:k 9}) 2)"}
+  {:suite "metadata / collection ops preserve meta" :label "empty list singleton unaffected" :expected "nil" :actual "(do (with-meta () {:leak 1}) (meta ()))"}
+  {:suite "metadata / collection ops preserve meta" :label "empty vector literal unaffected" :expected "nil" :actual "(do (with-meta [] {:leak 1}) (meta []))"}
   {:suite "metadata / def metadata" :label "^:dynamic var binds" :expected "9" :actual "(do (def ^:dynamic *d* 1) (binding [*d* 9] *d*))"}
   {:suite "metadata / def metadata" :label "^:private on var" :expected "true" :actual "(do (def ^:private pv 1) (:private (meta (var pv))))"}
   {:suite "metadata / def metadata" :label "^Type tag on var" :expected "java.lang.String" :actual "(do (def ^String tv \"a\") (:tag (meta (var tv))))"}