;; Garbage-Collection für Paare und Zahlen

;; Speicherverwaltung

(define *n-pairs* 100)
(define *free-pair* 0)

(define *the-cars* (make-vector *n-pairs* 0))
(define *the-cdrs* (make-vector *n-pairs* 0))

(define *from-cars* (make-vector *n-pairs* 0))
(define *from-cdrs* (make-vector *n-pairs* 0))

(define (new-number? n)
  (even? n))

(define (number-value n)
  (quotient n 2))

(define (make-number n)
  (* 2 n))

(define (new-pair? n)
  (odd? n))

(define (make-new-pair index)
  (+ 1 (* 2 index)))

(define (pair-index p)
  (quotient (- p 1) 2))

(define (new-cons a b)
  (if (>= *free-pair* *n-pairs*)
      #f
      (let ((index *free-pair*))
	(vector-set! *the-cars* index a)
	(vector-set! *the-cdrs* index b)
	(set! *free-pair* (+ 1 *free-pair*))
	(make-new-pair index))))

(define (new-car p)
  (vector-ref *the-cars* (pair-index p)))

(define (new-cdr p)
  (vector-ref *the-cdrs* (pair-index p)))

;; GC

(define (collect-garbage roots)
  (swap-spaces!)
  (set! *free-pair* 0)
  (let ((new-roots (map trace-value roots)))
    (letrec ((loop 
	      (lambda (scan)
		(if (> *free-pair* scan)
		    (begin
		      (vector-set! *the-cars* scan
				   (trace-value (vector-ref *the-cars* scan)))
		      (vector-set! *the-cdrs* scan
				   (trace-value (vector-ref *the-cdrs* scan)))
		      (loop (+ 1 scan)))))))
      (loop 0))
    new-roots))

(define (swap-spaces!)
  (let ((from-cars *from-cars*)
	(from-cdrs *from-cdrs*))
    (set! *from-cars* *the-cars*)
    (set! *from-cdrs* *the-cdrs*)

    (set! *the-cars* from-cars)
    (set! *the-cdrs* from-cdrs)))

(define (trace-value value)
  (if (new-pair? value)
      (copy-pair value)
      value))

(define (copy-pair pair)
  (let* ((index (pair-index pair))
	 (car-val (vector-ref *from-cars* index)))
    (if (eq? car-val 'broken-heart)
	(vector-ref *from-cdrs* index)
	(let ((new-index *free-pair*))
	  (vector-set! *the-cars* new-index car-val)
	  (vector-set! *the-cdrs* new-index
		       (vector-ref *from-cdrs* index))
	  ;; Herz brechen
	  (vector-set! *from-cars* index 'broken-heart)
	  (vector-set! *from-cdrs* index (make-new-pair new-index))
	  (set! *free-pair* (+ 1 *free-pair*))
	  (make-new-pair new-index)))))