tests/gc.test

   1 #! /bin/sh
   2 # -*-scheme-*-
   3 echo ' ()' | cat $($(dirname $0)/../scripts/include.mes $0) $0 /dev/stdin | $(dirname $0)/../scripts/mes "$@"
   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-0))
  29 (mes-use-module (mes base))
  30 (mes-use-module (mes quasiquote))
  31 (mes-use-module (mes let))
  32 (mes-use-module (srfi srfi-0))
  33 (mes-use-module (mes scm))
  34 (mes-use-module (mes test))
  35
  36 (when guile?
  37   (use-modules (srfi srfi-1)))
  38
  39 (pass-if "first dummy" #t)
  40 (pass-if-not "second dummy" #f)
  41
  42 (define gc-size 10)
  43 (define the-cells (make-vector gc-size))
  44 (define gc-free 0)
  45
  46 (define cell-type-alist
  47   '((0 . c) (1 . m) (2 . n) (3 . p) (4 . i) (5 . $) (6 . s) (7 . r)))
  48
  49 (define (cell-index c)
  50   (if (eq? (car c) 'p)
  51       (cdr c)))
  52
  53 (define (describe-cell c)
  54   (cons (assoc-ref cell-type-alist (mes-type-of c)) c))
  55
  56 (define (iota n)
  57   (if (= 0 n) '(0)
  58       (append (iota (- n 1)) (list n))))
  59
  60 (define (gc-show)
  61   (display "\nfree:") (display gc-free) (newline)
  62   (map (lambda (i) (display i) (display ": ") (display (describe-cell (vector-ref the-cells i))) (newline)) (iota (- gc-size 1))))
  63
  64 (define (gc-show-new)
  65   (display "new:\n")
  66   (map (lambda (i) (display i) (display ": ") (display (describe-cell (vector-ref new-cells i))) (newline)) (iota (- gc-size 1)))
  67   )
  68 (gc-show)
  69
  70 (define (gc)
  71   (gc-show)
  72   barf-gc)
  73
  74 (define (alloc)
  75   (if (= gc-free gc-size) (gc))
  76   ((lambda (index)
  77      (set! gc-free (+ gc-free 1))
  78      (make-cell 'p index))
  79    gc-free))
  80
  81 (define (make-cell type . x)
  82   (cons type (if (pair? x) (car x) '*)))
  83
  84 (define (cell-index c)
  85   (if (eq? (car c) 'p)
  86       (cdr c)))
  87
  88 (define (make-number x)
  89   ((lambda (cell)
  90      (vector-set! the-cells (cell-index cell) x)
  91      cell)
  92    (alloc)))
  93
  94 (define (make-symbol x)
  95   ((lambda (cell)
  96      (vector-set! the-cells (cell-index cell) x)
  97      cell)
  98    (alloc)))
  99
 100 (define (gc-cons x y)
 101   ((lambda (cell)
 102      ((lambda (pair)
 103         (vector-set! the-cells (cell-index cell) pair)
 104         (set-car! pair x)
 105         (set-cdr! pair y))
 106       (cons *unspecified* *unspecified*))
 107      cell)
 108    (alloc)))
 109
 110 ;; (define (gc-reg c)
 111 ;;   (vector-ref the-cells (cell-index c)))
 112
 113 (define gc-display display)
 114 ;;(define (gc-display c) (display (gc-reg c)))
 115 ;; (define (gc-car c) (car (gc-reg c)))
 116 ;; (define (gc-cdr c) (cdr (gc-reg c)))
 117 ;; (define (gc-pair? c) (pair? (gc-reg c)))
 118 ;; (define (gc-null? c) (null? (gc-reg c)))
 119 ;; (define (gc-display x . cont?)
 120 ;;   (if (gc-pair? x) (begin (if (null? cont?) (display "("))
 121 ;;                           (gc-display (gc-reg x))
 122 ;;                           (if (gc-pair? (gc-cdr x)) (display " "))
 123 ;;                           (if (not (gc-null? (gc-cdr x)))
 124 ;;                               (gc-display (gc-cdr x) #t))
 125 ;;                           (if (null? cont?) (display ")")))
 126 ;;       (if (gc-null? x) (if (not cont?) (display "()"))
 127 ;;           (display (gc-reg x)))))
 128
 129 (define gc-nil '())
 130 (define first (make-symbol 'F)) (newline)
 131
 132 (define one (make-number 1))
 133 (display "one=") (display one) (newline)
 134 (define two (make-number 2))
 135 (define pair2-nil (gc-cons two gc-nil))
 136 (display "pair2-nil=") (display pair2-nil) (newline)
 137 (gc-show)
 138
 139 (define list1-2 (gc-cons one pair2-nil))
 140 (display "list1-2=") (display list1-2) (newline)
 141 (gc-show)
 142
 143 (define three (make-number 3))
 144 (define four (make-number 4))
 145 (define pair4-nil (gc-cons four gc-nil))
 146 (define list3-4 (gc-cons three pair4-nil))
 147 (define list1234 (gc-cons list1-2 list3-4))
 148 (gc-show)
 149
 150 (display "list1-2=") (display list1-2) (newline)
 151 (display "list3-4=") (display list3-4) (newline)
 152 (display "lst=") (display list1234) (newline)
 153 (gc-show)
 154
 155 (display "sicp-lst:") (gc-display list1234) (newline)
 156 (gc-show)
 157
 158 (display "\n**** trigger gc ****\n")
 159 (define next (gc-list (make-symbol 'N) (make-symbol 'X)))
 160 (set! list1234 '(p . 0))
 161 (display "sicp-lst:") (gc-display list1234) (newline)
 162 (gc-show)
 163 (display "next=") (display next) (newline)
 164 (display "gc-next=") (gc-display next) (newline)
 165 (gc-show)
 166
 167
 168
 169 (result 'report)