guile18/test-suite/tests/structs.test

   1 ;;;; structs.test --- Test suite for Guile's structures.   -*- Scheme -*-
   2 ;;;; Ludovic Courtès <ludovic.courtes@laas.fr>, 2006-06-12.
   3 ;;;;
   4 ;;;; Copyright (C) 2006, 2007 Free Software Foundation, Inc.
   5 ;;;;
   6 ;;;; This program is free software; you can redistribute it and/or modify
   7 ;;;; it under the terms of the GNU General Public License as published by
   8 ;;;; the Free Software Foundation; either version 2, or (at your option)
   9 ;;;; any later version.
  10 ;;;;
  11 ;;;; This program is distributed in the hope that it will be useful,
  12 ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  13 ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14 ;;;; GNU General Public License for more details.
  15 ;;;;
  16 ;;;; You should have received a copy of the GNU General Public License
  17 ;;;; along with this software; see the file COPYING.  If not, write to
  18 ;;;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
  19 ;;;; Boston, MA 02110-1301 USA
  20
  21 (define-module (test-suite test-structs)
  22   :use-module (test-suite lib))
  23
  24
  25 \f
  26 ;;;
  27 ;;; Struct example taken from the reference manual (by Tom Lord).
  28 ;;;
  29
  30 (define ball-root (make-vtable-vtable "pr" 0))
  31
  32 (define (make-ball-type ball-color)
  33   (make-struct ball-root 0
  34                (make-struct-layout "pw")
  35                (lambda (ball port)
  36                  (format port "#<a ~A ball owned by ~A>"
  37                          (color ball)
  38                          (owner ball)))
  39                ball-color))
  40
  41 (define (color ball) (struct-ref (struct-vtable ball) vtable-offset-user))
  42 (define (owner ball) (struct-ref ball 0))
  43 (define (set-owner! ball owner) (struct-set! ball 0 owner))
  44
  45 (define red (make-ball-type 'red))
  46 (define green (make-ball-type 'green))
  47
  48 (define (make-ball type owner) (make-struct type 0 owner))
  49
  50
  51 \f
  52 ;;;
  53 ;;; Test suite.
  54 ;;;
  55
  56 (with-test-prefix "low-level struct procedures"
  57
  58   (pass-if "constructors"
  59      (and (struct-vtable? ball-root)
  60           (struct-vtable? red)
  61           (struct-vtable? green)))
  62
  63   (pass-if "vtables"
  64      (and (eq? (struct-vtable red) ball-root)
  65           (eq? (struct-vtable green) ball-root)
  66           (eq? (struct-vtable (make-ball red "Bob")) red)
  67
  68           ;; end of the vtable tower
  69           (eq? (struct-vtable ball-root) ball-root)))
  70
  71   (pass-if-exception "write-access denied"
  72      exception:struct-set!-denied
  73
  74      ;; The first field of instances of BALL-ROOT is read-only.
  75      (struct-set! red vtable-offset-user "blue"))
  76
  77   (pass-if "write-access granted"
  78      (set-owner! (make-ball red "Bob") "Fred")
  79      #t)
  80
  81   (pass-if "struct-set!"
  82      (let ((ball (make-ball green "Bob")))
  83        (set-owner! ball "Bill")
  84        (string=? (owner ball) "Bill"))))
  85
  86
  87 (with-test-prefix "equal?"
  88
  89   (pass-if "simple structs"
  90      (let* ((vtable (make-vtable-vtable "pr" 0))
  91             (s1     (make-struct vtable 0 "hello"))
  92             (s2     (make-struct vtable 0 "hello")))
  93        (equal? s1 s2)))
  94
  95   (pass-if "more complex structs"
  96      (let ((first (make-ball red (string-copy "Bob")))
  97            (second (make-ball red (string-copy "Bob"))))
  98        (equal? first second)))
  99
 100   (pass-if "not-equal?"
 101      (not (or (equal? (make-ball red "Bob") (make-ball green "Bob"))
 102               (equal? (make-ball red "Bob") (make-ball red "Bill"))))))
 103
 104
 105 ;;
 106 ;; make-struct
 107 ;;
 108
 109 (define exception:bad-tail
 110   (cons 'misc-error "tail array not allowed unless"))
 111
 112 (with-test-prefix "make-struct"
 113
 114   ;; in guile 1.8.1 and earlier, this caused an error throw out of an
 115   ;; SCM_CRITICAL_SECTION_START / SCM_CRITICAL_SECTION_END, which abort()ed
 116   ;; the program
 117   ;;
 118   (pass-if-exception "wrong type for `u' field" exception:wrong-type-arg
 119     (let* ((vv (make-vtable-vtable "" 0))
 120            (v  (make-struct vv 0 (make-struct-layout "uw"))))
 121       (make-struct v 0 'x)))
 122
 123   ;; In guile 1.8.1 and earlier, and 1.6.8 and earlier, there was no check
 124   ;; on a tail array being created without an R/W/O type for it.  This left
 125   ;; it uninitialized by scm_struct_init(), resulting in garbage getting
 126   ;; into an SCM when struct-ref read it (and attempting to print a garbage
 127   ;; SCM can cause a segv).
 128   ;;
 129   (pass-if-exception "no R/W/O for tail array" exception:bad-tail
 130     (let* ((vv (make-vtable-vtable "" 0))
 131            (v  (make-struct vv 0 (make-struct-layout "pw"))))
 132       (make-struct v 123 'x))))
 133
 134 ;;
 135 ;; make-vtable
 136 ;;
 137
 138 (with-test-prefix "make-vtable"
 139
 140   (pass-if "without printer"
 141     (let* ((vtable (make-vtable "pwpr"))
 142            (struct (make-struct vtable 0 'x 'y)))
 143       (and (eq? 'x (struct-ref struct 0))
 144            (eq? 'y (struct-ref struct 1)))))
 145
 146   (pass-if "with printer"
 147     (let ()
 148       (define (print struct port)
 149         (display "hello" port))
 150
 151       (let* ((vtable (make-vtable "pwpr" print))
 152              (struct (make-struct vtable 0 'x 'y))
 153              (str    (call-with-output-string
 154                       (lambda (port)
 155                         (display struct port)))))
 156          (equal? str "hello")))))
 157
 158
 159 ;;; Local Variables:
 160 ;;; coding: latin-1
 161 ;;; End: