Guile gc experiment: add pairs.
[mes.git] / 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 car)
17 (define cell-index cdr)
18
19 (define (make-cell type . x)
20   (cons type (if (pair? x) (cell-type x) '*)))
21
22 (define (gc-alloc)
23   ((lambda (index)
24      (set! gc-free (+ gc-free 1))
25      (make-cell '* index))
26    gc-free))
27
28 (define (gc-make-number x)
29   ((lambda (cell)
30      (vector-set! the-cars (cell-index cell) (make-cell 'n x))
31      cell)
32    (gc-alloc)))
33
34 (define (gc-cons x y)
35   ((lambda (cell)
36      ((lambda (pair)
37       (vector-set! the-cars (cell-index cell) pair)
38       (vector-set! the-cars (cell-index cell) (make-cell 'p (cell-index x)))
39       (vector-set! the-cdrs (cell-index cell) (make-cell 'p (cell-index y)))
40       pair)
41       (make-cell 'p (cell-index cell))))
42    (gc-alloc)))
43
44 (define (gc-car c)
45   (if (eq? (cell-type c) 'p) (vector-ref the-cars
46                                          (cell-index
47                                           (vector-ref the-cars (cell-index c))))))
48
49 (define (gc-cdr c)
50   (if (eq? (cell-type c) 'p) (vector-ref the-cars
51                                          (cell-index
52                                           (vector-ref the-cdrs (cell-index c))))))
53
54 (display (gc-make-number 7)) (newline)
55 (define first (gc-make-number 8)) (newline)
56 (show-gc)
57 (define second (gc-make-number 9)) (newline)
58 (show-gc)
59 (define pair (gc-cons first second))
60 (show-gc)
61 (display "pair:") (display pair) (newline)
62
63 (display "car:") (display (gc-car pair)) (newline)
64 (display "cdr:") (display (gc-cdr pair)) (newline)