From 2866c7590744961f1e92503d4ec5dbeebcba5284 Mon Sep 17 00:00:00 2001
From: Jan Nieuwenhuizen <janneke@gnu.org>
Date: Wed, 26 Oct 2016 19:54:03 +0200
Subject: [PATCH] Add mes gc test setup.

* tests/gc.test: New file.
---
 tests/gc.test | 169 ++++++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 169 insertions(+)
 create mode 100755 tests/gc.test

diff --git a/tests/gc.test b/tests/gc.test
new file mode 100755
index 00000000..4398933e
--- /dev/null
+++ b/tests/gc.test
@@ -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)