+(define* (transient-intset #:optional (source empty-intset))
+ (match source
+ (($ <transient-intset> min shift root edit)
+ (assert-readable! edit)
+ source)
+ (($ <intset> min shift root)
+ (let ((edit (make-atomic-reference (current-thread))))
+ (make-transient-intset min shift root edit)))))
+
+(define* (persistent-intset #:optional (source empty-intset))
+ (match source
+ (($ <transient-intset> min shift root edit)
+ (assert-readable! edit)
+ ;; Make a fresh reference, causing any further operations on this
+ ;; transient to clone its root afresh.
+ (set-transient-intset-edit! source
+ (make-atomic-reference (current-thread)))
+ ;; Clear the reference to the current thread, causing our edited
+ ;; data structures to be persistent again.
+ (set-atomic-reference! edit #f)
+ (if min
+ (make-intset min shift root)
+ empty-intset))
+ (($ <intset>)
+ source)))
+
+(define (intset-add! bs i)
+ (define (adjoin-leaf i root)
+ (clone-leaf-and-set root (logand i *leaf-mask*) #t))
+ (define (ensure-branch! root idx)
+ (let ((edit (vector-ref root *edit-index*)))
+ (match (vector-ref root idx)
+ (#f (let ((v (new-branch edit)))
+ (vector-set! root idx v)
+ v))
+ (v (writable-branch v edit)))))
+ (define (adjoin-branch! i shift root)
+ (let* ((shift (- shift *branch-bits*))
+ (idx (logand (ash i (- shift)) *branch-mask*)))
+ (cond
+ ((= shift *leaf-bits*)
+ (vector-set! root idx (adjoin-leaf i (vector-ref root idx))))
+ (else
+ (adjoin-branch! i shift (ensure-branch! root idx))))))
+ (match bs
+ (($ <transient-intset> min shift root edit)
+ (assert-readable! edit)
+ (cond
+ ((< i 0)
+ ;; The power-of-two spanning trick doesn't work across 0.
+ (error "Intsets can only hold non-negative integers." i))
+ ((not root)
+ ;; Add first element.
+ (let ((min (round-down i shift)))
+ (set-transient-intset-min! bs min)
+ (set-transient-intset-shift! bs *leaf-bits*)
+ (set-transient-intset-root! bs (adjoin-leaf (- i min) root))))
+ ((and (<= min i) (< i (+ min (ash 1 shift))))
+ ;; Add element to set; level will not change.
+ (if (= shift *leaf-bits*)
+ (set-transient-intset-root! bs (adjoin-leaf (- i min) root))
+ (adjoin-branch! (- i min) shift root)))
+ (else
+ (let lp ((min min)
+ (shift shift)
+ (root (if (eqv? shift *leaf-bits*)
+ root
+ (writable-branch root edit))))
+ (let* ((shift* (+ shift *branch-bits*))
+ (min* (round-down min shift*))
+ (idx (logand (ash (- min min*) (- shift)) *branch-mask*))
+ (root* (new-branch edit)))
+ (vector-set! root* idx root)
+ (cond
+ ((and (<= min* i) (< i (+ min* (ash 1 shift*))))
+ (set-transient-intset-min! bs min*)
+ (set-transient-intset-shift! bs shift*)
+ (set-transient-intset-root! bs root*)
+ (adjoin-branch! (- i min*) shift* root*))
+ (else
+ (lp min* shift* root*)))))))
+ bs)
+ (($ <intset>)
+ (intset-add! (transient-intset bs) i))))
+