Add mes gc test setup.
* tests/gc.test: New file.
This commit is contained in:
Jan Nieuwenhuizen
parent
84787f9f23
commit
2866c75907
169
tests/gc.test
Executable file
169
tests/gc.test
Executable file
|
|
@ -0,0 +1,169 @@
|
|||
#! /bin/sh
|
||||
# -*-scheme-*-
|
||||
echo ' ()' | cat $($(dirname $0)/../scripts/include.mes $0) $0 /dev/stdin | $(dirname $0)/../scripts/mes "$@"
|
||||
#paredit:||
|
||||
exit $?
|
||||
!#
|
||||
|
||||
;;; -*-scheme-*-
|
||||
|
||||
;;; Mes --- Maxwell Equations of Software
|
||||
;;; Copyright © 2016 Jan Nieuwenhuizen <janneke@gnu.org>
|
||||
;;;
|
||||
;;; This file is part of Mes.
|
||||
;;;
|
||||
;;; Mes is free software; you can redistribute it and/or modify it
|
||||
;;; under the terms of the GNU General Public License as published by
|
||||
;;; the Free Software Foundation; either version 3 of the License, or (at
|
||||
;;; your option) any later version.
|
||||
;;;
|
||||
;;; Mes is distributed in the hope that it will be useful, but
|
||||
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
;;; GNU General Public License for more details.
|
||||
;;;
|
||||
;;; You should have received a copy of the GNU General Public License
|
||||
;;; along with Mes. If not, see <http://www.gnu.org/licenses/>.
|
||||
|
||||
(mes-use-module (mes base-0))
|
||||
(mes-use-module (mes base))
|
||||
(mes-use-module (mes quasiquote))
|
||||
(mes-use-module (mes let))
|
||||
(mes-use-module (srfi srfi-0))
|
||||
(mes-use-module (mes scm))
|
||||
(mes-use-module (mes test))
|
||||
|
||||
(when guile?
|
||||
(use-modules (srfi srfi-1)))
|
||||
|
||||
(pass-if "first dummy" #t)
|
||||
(pass-if-not "second dummy" #f)
|
||||
|
||||
(define gc-size 10)
|
||||
(define the-cells (make-vector gc-size))
|
||||
(define gc-free 0)
|
||||
|
||||
(define cell-type-alist
|
||||
'((0 . c) (1 . m) (2 . n) (3 . p) (4 . i) (5 . $) (6 . s) (7 . r)))
|
||||
|
||||
(define (cell-index c)
|
||||
(if (eq? (car c) 'p)
|
||||
(cdr c)))
|
||||
|
||||
(define (describe-cell c)
|
||||
(cons (assoc-ref cell-type-alist (mes-type-of c)) c))
|
||||
|
||||
(define (iota n)
|
||||
(if (= 0 n) '(0)
|
||||
(append (iota (- n 1)) (list n))))
|
||||
|
||||
(define (gc-show)
|
||||
(display "\nfree:") (display gc-free) (newline)
|
||||
(map (lambda (i) (display i) (display ": ") (display (describe-cell (vector-ref the-cells i))) (newline)) (iota (- gc-size 1))))
|
||||
|
||||
(define (gc-show-new)
|
||||
(display "new:\n")
|
||||
(map (lambda (i) (display i) (display ": ") (display (describe-cell (vector-ref new-cells i))) (newline)) (iota (- gc-size 1)))
|
||||
)
|
||||
(gc-show)
|
||||
|
||||
(define (gc)
|
||||
(gc-show)
|
||||
barf-gc)
|
||||
|
||||
(define (alloc)
|
||||
(if (= gc-free gc-size) (gc))
|
||||
((lambda (index)
|
||||
(set! gc-free (+ gc-free 1))
|
||||
(make-cell 'p index))
|
||||
gc-free))
|
||||
|
||||
(define (make-cell type . x)
|
||||
(cons type (if (pair? x) (car x) '*)))
|
||||
|
||||
(define (cell-index c)
|
||||
(if (eq? (car c) 'p)
|
||||
(cdr c)))
|
||||
|
||||
(define (make-number x)
|
||||
((lambda (cell)
|
||||
(vector-set! the-cells (cell-index cell) x)
|
||||
cell)
|
||||
(alloc)))
|
||||
|
||||
(define (make-symbol x)
|
||||
((lambda (cell)
|
||||
(vector-set! the-cells (cell-index cell) x)
|
||||
cell)
|
||||
(alloc)))
|
||||
|
||||
(define (gc-cons x y)
|
||||
((lambda (cell)
|
||||
((lambda (pair)
|
||||
(vector-set! the-cells (cell-index cell) pair)
|
||||
(set-car! pair x)
|
||||
(set-cdr! pair y))
|
||||
(cons *unspecified* *unspecified*))
|
||||
cell)
|
||||
(alloc)))
|
||||
|
||||
;; (define (gc-reg c)
|
||||
;; (vector-ref the-cells (cell-index c)))
|
||||
|
||||
(define gc-display display)
|
||||
;;(define (gc-display c) (display (gc-reg c)))
|
||||
;; (define (gc-car c) (car (gc-reg c)))
|
||||
;; (define (gc-cdr c) (cdr (gc-reg c)))
|
||||
;; (define (gc-pair? c) (pair? (gc-reg c)))
|
||||
;; (define (gc-null? c) (null? (gc-reg c)))
|
||||
;; (define (gc-display x . cont?)
|
||||
;; (if (gc-pair? x) (begin (if (null? cont?) (display "("))
|
||||
;; (gc-display (gc-reg x))
|
||||
;; (if (gc-pair? (gc-cdr x)) (display " "))
|
||||
;; (if (not (gc-null? (gc-cdr x)))
|
||||
;; (gc-display (gc-cdr x) #t))
|
||||
;; (if (null? cont?) (display ")")))
|
||||
;; (if (gc-null? x) (if (not cont?) (display "()"))
|
||||
;; (display (gc-reg x)))))
|
||||
|
||||
(define gc-nil '())
|
||||
(define first (make-symbol 'F)) (newline)
|
||||
|
||||
(define one (make-number 1))
|
||||
(display "one=") (display one) (newline)
|
||||
(define two (make-number 2))
|
||||
(define pair2-nil (gc-cons two gc-nil))
|
||||
(display "pair2-nil=") (display pair2-nil) (newline)
|
||||
(gc-show)
|
||||
|
||||
(define list1-2 (gc-cons one pair2-nil))
|
||||
(display "list1-2=") (display list1-2) (newline)
|
||||
(gc-show)
|
||||
|
||||
(define three (make-number 3))
|
||||
(define four (make-number 4))
|
||||
(define pair4-nil (gc-cons four gc-nil))
|
||||
(define list3-4 (gc-cons three pair4-nil))
|
||||
(define list1234 (gc-cons list1-2 list3-4))
|
||||
(gc-show)
|
||||
|
||||
(display "list1-2=") (display list1-2) (newline)
|
||||
(display "list3-4=") (display list3-4) (newline)
|
||||
(display "lst=") (display list1234) (newline)
|
||||
(gc-show)
|
||||
|
||||
(display "sicp-lst:") (gc-display list1234) (newline)
|
||||
(gc-show)
|
||||
|
||||
(display "\n**** trigger gc ****\n")
|
||||
(define next (gc-list (make-symbol 'N) (make-symbol 'X)))
|
||||
(set! list1234 '(p . 0))
|
||||
(display "sicp-lst:") (gc-display list1234) (newline)
|
||||
(gc-show)
|
||||
(display "next=") (display next) (newline)
|
||||
(display "gc-next=") (gc-display next) (newline)
|
||||
(gc-show)
|
||||
|
||||
|
||||
|
||||
(result 'report)
|
||||
Loading…
Reference in a new issue