guile/gc.scm

   1
   2 (define-module (guile gc))
   3
   4 (define (R) (reload-module (current-module)))
   5
   6 (define gc-size 10)
   7 (define the-cars (make-vector gc-size '(* . *)))
   8 (define the-cdrs (make-vector gc-size '(* . *)))
   9 (define gc-free 0)
  10 (define (show-gc)
  11   (display "\nfree:") (display gc-free) (newline)
  12   (display "cars:") (display the-cars) (newline)
  13   (display "cdrs:") (display the-cdrs) (newline))
  14 (show-gc)
  15
  16 (define (cell-type c) (car (gc-cell c)))
  17 (define cell-index cdr)
  18 (define (cell-value c) (cdr (gc-cell c)))
  19
  20 (define (make-cell type . x)
  21   (cons type (if (pair? x) (car x) '*)))
  22
  23 (define (gc-alloc)
  24   ((lambda (index)
  25      (set! gc-free (+ gc-free 1))
  26      (make-cell '* index))
  27    gc-free))
  28
  29 (define (make-number x)
  30   ((lambda (cell)
  31      (vector-set! the-cars (cell-index cell) (make-cell 'n x))
  32      cell)
  33    (gc-alloc)))
  34
  35 (define (make-symbol x)
  36   ((lambda (cell)
  37      (vector-set! the-cars (cell-index cell) (make-cell 's x))
  38      cell)
  39    (gc-alloc)))
  40
  41 (define (gc-cons x y)
  42   ((lambda (cell)
  43      (vector-set! the-cars (cell-index cell) (make-cell 'p (cell-index x)))
  44      (vector-set! the-cdrs (cell-index cell) y)
  45      cell)
  46    (gc-alloc)))
  47
  48 (define (gc-car c)
  49   (vector-ref the-cars (cell-index c)))
  50
  51 (define (gc-cdr c)
  52   (vector-ref the-cdrs (cell-index c)))
  53
  54 (define gc-cell gc-car)
  55 (define (gc-pair? c)
  56   (eq? (cell-type c) 'p))
  57
  58 (define (gc-set-car! c x)
  59   (if (gc-pair? c) (vector-set! the-cars (cell-index c) x)))
  60
  61 (define (gc-set-cdr! c x)
  62   (if (gc-pair? c) (vector-set! the-cdrs (cell-index c) x)))
  63
  64 (display "number 7=") (display (make-number 7)) (newline)
  65 (define first (make-number 8)) (newline)
  66 (show-gc)
  67 (define second (make-number 9)) (newline)
  68 (show-gc)
  69 (define pair (gc-cons first second))
  70 (show-gc)
  71 (display "pair:") (display pair) (newline)
  72
  73 (display "car:") (display (gc-car pair)) (newline)
  74 (display "cdr:") (display (gc-cdr pair)) (newline)
  75
  76 (define (gc-null? x) (eq? (car x) 'e))
  77
  78 (define gc-nil (make-cell 'e 0))
  79 (display "nil: ") (display gc-nil) (newline)
  80
  81 (define (gc-list . rest)
  82   (if (null? rest) gc-nil
  83       (gc-cons (car rest) (apply gc-list (cdr rest)))))
  84
  85 (define lst (gc-list (make-symbol 'a) (make-symbol 'b) (make-symbol 'c)))
  86 (display "lst:") (display lst) (newline)
  87 (show-gc)
  88
  89 (define (gc-display x . cont?)
  90   (if (gc-pair? x) (begin (if (null? cont?) (display "("))
  91                           (gc-display (gc-car x))
  92                           (if (gc-pair? (gc-cdr x)) (display " "))
  93                           (gc-display (gc-cdr x) #t)
  94                           (if (null? cont?) (display ")")))
  95       (if (gc-null? x) (if (not cont?) (display "()"))
  96           (display (cell-value x)))))
  97 (display "gc-display lst=") (gc-display lst) (newline)
  98 (show-gc)