살아 있는 셀을 복사하고 되풀이된 참조는 전달하며 쓰레기는 남겨 둔다.

(begin
  (define (tagged-list? value tag)
    (and (pair? value) (eq? (car value) tag)))
  (define (make-vector-memory capacity)
    (list '*vector-memory*
          (make-vector capacity '*unused*)
          (make-vector capacity '*unused*)
          (cons 'free 0)))
  (define (memory-cars memory) (list-ref memory 1))
  (define (memory-cdrs memory) (list-ref memory 2))
  (define (memory-free-cell memory) (list-ref memory 3))
  (define (memory-free memory) (cdr (memory-free-cell memory)))
  (define (set-memory-free! memory value)
    (set-cdr! (memory-free-cell memory) value))

  (define (pair-pointer? value) (tagged-list? value 'ptr))
  (define (make-pointer index) (list 'ptr index))
  (define (pointer-index pointer) (cadr pointer))

  (define (allocate-pair! memory car-value cdr-value)
    (let ((index (memory-free memory)))
      (if (>= index (vector-length (memory-cars memory)))
          (error "vector memory exhausted" index)
          (begin
            (vector-set! (memory-cars memory) index car-value)
            (vector-set! (memory-cdrs memory) index cdr-value)
            (set-memory-free! memory (+ index 1))
            (make-pointer index)))))
  (define (memory-car memory pointer)
    (vector-ref (memory-cars memory) (pointer-index pointer)))
  (define (memory-cdr memory pointer)
    (vector-ref (memory-cdrs memory) (pointer-index pointer)))
  (define (set-memory-car! memory pointer value)
    (vector-set! (memory-cars memory)
                 (pointer-index pointer)
                 value))
  (define (set-memory-cdr! memory pointer value)
    (vector-set! (memory-cdrs memory)
                 (pointer-index pointer)
                 value))

  (define (list->memory values memory)
    (if (null? values)
        '()
        (let ((tail (list->memory (cdr values) memory)))
          (allocate-pair! memory (car values) tail))))
  (define (memory->list pointer memory)
    (if (null? pointer)
        '()
        (cons (memory-car memory pointer)
              (memory->list (memory-cdr memory pointer)
                            memory))))
  (define (used-vector-prefix values count)
    (define (loop index result)
      (if (= index count)
          (reverse result)
          (loop (+ index 1)
                (cons (vector-ref values index) result))))
    (loop 0 '()))
  (define (collect from-memory roots)
    (let ((to-memory
           (make-vector-memory
             (vector-length (memory-cars from-memory))))
          (forwarding
           (make-vector
             (vector-length (memory-cars from-memory))
             #f)))
      (define (copy-value value)
        (if (not (pair-pointer? value))
            value
            (let* ((old-index (pointer-index value))
                   (known (vector-ref forwarding old-index)))
              (if known
                  known
                  (let ((new-pointer
                         (allocate-pair!
                           to-memory
                           '*pending-car*
                           '*pending-cdr*)))
                    (vector-set! forwarding
                                 old-index
                                 new-pointer)
                    (set-memory-car!
                      to-memory
                      new-pointer
                      (copy-value
                        (memory-car from-memory value)))
                    (set-memory-cdr!
                      to-memory
                      new-pointer
                      (copy-value
                        (memory-cdr from-memory value)))
                    new-pointer)))))
      (define new-roots (map copy-value roots))
      (list new-roots to-memory forwarding)))
  (define from-memory (make-vector-memory 10))
  (define shared
    (allocate-pair! from-memory 'shared '()))
  (define left
    (allocate-pair! from-memory 'a shared))
  (define right
    (allocate-pair! from-memory 'b shared))
  (define dead-tail
    (allocate-pair! from-memory 'dead '()))
  (define garbage
    (allocate-pair! from-memory 'garbage dead-tail))
  (define collection
    (collect from-memory (list left right)))
  (define roots (car collection))
  (define to-memory (cadr collection))
  (define forwarding (caddr collection))
  (define new-left (car roots))
  (define new-right (cadr roots))
  (list (memory-free from-memory)
        (memory-free to-memory)
        (- (memory-free from-memory)
           (memory-free to-memory))
        (memory->list new-left to-memory)
        (memory->list new-right to-memory)
        (equal? (memory-cdr to-memory new-left)
                (memory-cdr to-memory new-right))
        (vector-ref forwarding (pointer-index dead-tail))
        (vector-ref forwarding (pointer-index garbage)))
)