1 ;;;; structs.test --- Test suite for Guile's structures. -*- Scheme -*-
2 ;;;; Ludovic Courtès <ludovic.courtes@laas.fr>, 2006-06-12.
4 ;;;; Copyright (C) 2006, 2007 Free Software Foundation, Inc.
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.
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.
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
21 (define-module (test-suite test-structs)
22 :use-module (test-suite lib))
27 ;;; Struct example taken from the reference manual (by Tom Lord).
30 (define ball-root (make-vtable-vtable "pr" 0))
32 (define (make-ball-type ball-color)
33 (make-struct ball-root 0
34 (make-struct-layout "pw")
36 (format port "#<a ~A ball owned by ~A>"
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))
45 (define red (make-ball-type 'red))
46 (define green (make-ball-type 'green))
48 (define (make-ball type owner) (make-struct type 0 owner))
56 (with-test-prefix "low-level struct procedures"
58 (pass-if "constructors"
59 (and (struct-vtable? ball-root)
61 (struct-vtable? green)))
64 (and (eq? (struct-vtable red) ball-root)
65 (eq? (struct-vtable green) ball-root)
66 (eq? (struct-vtable (make-ball red "Bob")) red)
68 ;; end of the vtable tower
69 (eq? (struct-vtable ball-root) ball-root)))
71 (pass-if-exception "write-access denied"
72 exception:struct-set!-denied
74 ;; The first field of instances of BALL-ROOT is read-only.
75 (struct-set! red vtable-offset-user "blue"))
77 (pass-if "write-access granted"
78 (set-owner! (make-ball red "Bob") "Fred")
81 (pass-if "struct-set!"
82 (let ((ball (make-ball green "Bob")))
83 (set-owner! ball "Bill")
84 (string=? (owner ball) "Bill"))))
87 (with-test-prefix "equal?"
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")))
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)))
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"))))))
109 (define exception:bad-tail
110 (cons 'misc-error "tail array not allowed unless"))
112 (with-test-prefix "make-struct"
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
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)))
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).
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))))
138 (with-test-prefix "make-vtable"
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)))))
146 (pass-if "with printer"
148 (define (print struct port)
149 (display "hello" port))
151 (let* ((vtable (make-vtable "pwpr" print))
152 (struct (make-struct vtable 0 'x 'y))
153 (str (call-with-output-string
155 (display struct port)))))
156 (equal? str "hello")))))