8ca5bf0238d452417b2ca1f66569faf7c02cbb7a
[mes.git] / tests / gc.test
1 #! /bin/sh
2 # -*-scheme-*-
3 echo ' ()' | cat $(dirname $0)/../module/mes/base-0.mes $0 /dev/stdin | $(dirname $0)/../scripts/mes $MES_FLAGS "$@"
4 #paredit:||
5 exit $?
6 !#
7
8 ;;; -*-scheme-*-
9
10 ;;; Mes --- Maxwell Equations of Software
11 ;;; Copyright © 2016 Jan Nieuwenhuizen <janneke@gnu.org>
12 ;;;
13 ;;; This file is part of Mes.
14 ;;;
15 ;;; Mes is free software; you can redistribute it and/or modify it
16 ;;; under the terms of the GNU General Public License as published by
17 ;;; the Free Software Foundation; either version 3 of the License, or (at
18 ;;; your option) any later version.
19 ;;;
20 ;;; Mes is distributed in the hope that it will be useful, but
21 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
22 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
23 ;;; GNU General Public License for more details.
24 ;;;
25 ;;; You should have received a copy of the GNU General Public License
26 ;;; along with Mes.  If not, see <http://www.gnu.org/licenses/>.
27
28 (mes-use-module (mes base))
29 (mes-use-module (mes quasiquote))
30 (mes-use-module (mes let))
31 (mes-use-module (srfi srfi-0))
32 (mes-use-module (mes scm))
33 (mes-use-module (mes test))
34
35 (pass-if "first dummy" #t)
36 (pass-if-not "second dummy" #f)
37
38 (define gc-size 10)
39 (define the-cells (make-vector gc-size))
40 (define gc-free 0)
41
42 (define cell-type-alist
43   '((0 . c) (1 . m) (2 . n) (3 . p) (4 . i) (5 . $) (6 . s) (7 . r)))
44
45 (define (cell-index c)
46   (if (eq? (car c) 'p)
47       (cdr c)))
48
49 (define (describe-cell c)
50   (cons (assoc-ref cell-type-alist (mes-type-of c)) c))
51
52 (define (iota n)
53   (if (= 0 n) '(0)
54       (append (iota (- n 1)) (list n))))
55
56 (define (gc-show)
57   (display "\nfree:") (display gc-free) (newline)
58   (map (lambda (i) (display i) (display ": ") (display (describe-cell (vector-ref the-cells i))) (newline)) (iota (- gc-size 1))))
59
60 (define (gc-show-new)
61   (display "new:\n")
62   (map (lambda (i) (display i) (display ": ") (display (describe-cell (vector-ref new-cells i))) (newline)) (iota (- gc-size 1)))
63   )
64 (gc-show)
65
66 (define (gc)
67   (gc-show)
68   barf-gc)
69
70 (define (alloc)
71   (if (= gc-free gc-size) (gc))
72   ((lambda (index)
73      (set! gc-free (+ gc-free 1))
74      (make-cell 'p index))
75    gc-free))
76
77 (define (make-cell type . x)
78   (cons type (if (pair? x) (car x) '*)))
79
80 (define (cell-index c)
81   (if (eq? (car c) 'p)
82       (cdr c)))
83
84 (define (make-number x)
85   ((lambda (cell)
86      (vector-set! the-cells (cell-index cell) x)
87      cell)
88    (alloc)))
89
90 (define (make-symbol x)
91   ((lambda (cell)
92      (vector-set! the-cells (cell-index cell) x)
93      cell)
94    (alloc)))
95
96 (define (gc-cons x y)
97   ((lambda (cell)
98      ((lambda (pair)
99         (vector-set! the-cells (cell-index cell) pair)
100         (set-car! pair x)
101         (set-cdr! pair y))
102       (cons *unspecified* *unspecified*))
103      cell)
104    (alloc)))
105
106 ;; (define (gc-reg c)
107 ;;   (vector-ref the-cells (cell-index c)))
108
109 (define gc-display display)
110 ;;(define (gc-display c) (display (gc-reg c)))
111 ;; (define (gc-car c) (car (gc-reg c)))
112 ;; (define (gc-cdr c) (cdr (gc-reg c)))
113 ;; (define (gc-pair? c) (pair? (gc-reg c)))
114 ;; (define (gc-null? c) (null? (gc-reg c)))
115 ;; (define (gc-display x . cont?)
116 ;;   (if (gc-pair? x) (begin (if (null? cont?) (display "("))
117 ;;                           (gc-display (gc-reg x))
118 ;;                           (if (gc-pair? (gc-cdr x)) (display " "))
119 ;;                           (if (not (gc-null? (gc-cdr x)))
120 ;;                               (gc-display (gc-cdr x) #t))
121 ;;                           (if (null? cont?) (display ")")))
122 ;;       (if (gc-null? x) (if (not cont?) (display "()"))
123 ;;           (display (gc-reg x)))))
124
125 (define gc-nil '())
126 (define first (make-symbol 'F)) (newline)
127
128 (define one (make-number 1))
129 (display "one=") (display one) (newline)
130 (define two (make-number 2))
131 (define pair2-nil (gc-cons two gc-nil))
132 (display "pair2-nil=") (display pair2-nil) (newline)
133 (gc-show)
134
135 (define list1-2 (gc-cons one pair2-nil))
136 (display "list1-2=") (display list1-2) (newline)
137 (gc-show)
138
139 (define three (make-number 3))
140 (define four (make-number 4))
141 (define pair4-nil (gc-cons four gc-nil))
142 (define list3-4 (gc-cons three pair4-nil))
143 (define list1234 (gc-cons list1-2 list3-4))
144 (gc-show)
145
146 (display "list1-2=") (display list1-2) (newline)
147 (display "list3-4=") (display list3-4) (newline)
148 (display "lst=") (display list1234) (newline)
149 (gc-show)
150
151 (display "sicp-lst:") (gc-display list1234) (newline)
152 (gc-show)
153
154 (display "\n**** trigger gc ****\n")
155 (define next (gc-list (make-symbol 'N) (make-symbol 'X)))
156 (set! list1234 '(p . 0))
157 (display "sicp-lst:") (gc-display list1234) (newline)
158 (gc-show)
159 (display "next=") (display next) (newline)
160 (display "gc-next=") (gc-display next) (newline)
161 (gc-show)
162
163
164
165 (result 'report)