1 ;;;; structs.test --- Structures. -*- mode: scheme; coding: utf-8; -*-
2 ;;;; Ludovic Courtès <ludo@gnu.org>, 2006-06-12.
4 ;;;; Copyright (C) 2006, 2007, 2009, 2010, 2012 Free Software Foundation, Inc.
6 ;;;; This library is free software; you can redistribute it and/or
7 ;;;; modify it under the terms of the GNU Lesser General Public
8 ;;;; License as published by the Free Software Foundation; either
9 ;;;; version 3 of the License, or (at your option) any later version.
11 ;;;; This library 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 GNU
14 ;;;; Lesser General Public License for more details.
16 ;;;; You should have received a copy of the GNU Lesser General Public
17 ;;;; License along with this library; if not, write to the Free Software
18 ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
20 (define-module (test-suite test-structs)
21 :use-module (test-suite lib))
26 ;;; Struct example taken from the reference manual (by Tom Lord).
30 (make-vtable (string-append standard-vtable-fields "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)
67 (eq? (struct-vtable ball-root) <standard-vtable>)
69 ;; end of the vtable tower
70 (eq? (struct-vtable <standard-vtable>) <standard-vtable>)))
72 (pass-if-exception "write-access denied"
73 exception:struct-set!-denied
75 ;; The first field of instances of BALL-ROOT is read-only.
76 (struct-set! red vtable-offset-user "blue"))
78 (pass-if "write-access granted"
79 (set-owner! (make-ball red "Bob") "Fred")
82 (pass-if "struct-set!"
83 (let ((ball (make-ball green "Bob")))
84 (set-owner! ball "Bill")
85 (string=? (owner ball) "Bill")))
88 (let ((ball (make-ball red "Alice")))
89 (equal? (struct-ref ball 0) "Alice")))
91 (pass-if "struct-set!"
92 (let* ((v (make-vtable "pw"))
94 (r (struct-set! s 0 'a)))
99 (pass-if-exception "struct-ref out-of-range"
100 exception:out-of-range
101 (let* ((v (make-vtable "prpr"))
102 (s (make-struct v 0 'a 'b)))
105 (pass-if-exception "struct-set! out-of-range"
106 exception:out-of-range
107 (let* ((v (make-vtable "pwpw"))
108 (s (make-struct v 0 'a 'b)))
109 (struct-set! s 2 'c))))
112 (with-test-prefix "equal?"
114 (pass-if "simple structs"
115 (let* ((vtable (make-vtable "pr"))
116 (s1 (make-struct vtable 0 "hello"))
117 (s2 (make-struct vtable 0 "hello")))
120 (pass-if "more complex structs"
121 (let ((first (make-ball red (string-copy "Bob")))
122 (second (make-ball red (string-copy "Bob"))))
123 (equal? first second)))
125 (pass-if "not-equal?"
126 (not (or (equal? (make-ball red "Bob") (make-ball green "Bob"))
127 (equal? (make-ball red "Bob") (make-ball red "Bill"))))))
130 (with-test-prefix "hash"
132 (pass-if "simple structs"
133 (let* ((v (make-vtable "pr"))
134 (s1 (make-struct v 0 "hello"))
135 (s2 (make-struct v 0 "hello")))
136 (= (hash s1 7777) (hash s2 7777))))
138 (pass-if "different structs"
139 (let* ((v (make-vtable "pr"))
140 (s1 (make-struct v 0 "hello"))
141 (s2 (make-struct v 0 "world")))
142 (or (not (= (hash s1 7777) (hash s2 7777)))
143 (throw 'unresolved))))
145 (pass-if "different struct types"
146 (let* ((v1 (make-vtable "pr"))
147 (v2 (make-vtable "pr"))
148 (s1 (make-struct v1 0 "hello"))
149 (s2 (make-struct v2 0 "hello")))
150 (or (not (= (hash s1 7777) (hash s2 7777)))
151 (throw 'unresolved))))
153 (pass-if "more complex structs"
154 (let ((s1 (make-ball red (string-copy "Bob")))
155 (s2 (make-ball red (string-copy "Bob"))))
156 (= (hash s1 7777) (hash s2 7777))))
158 (pass-if "struct with weird fields"
159 (let* ((v (make-vtable "prurph"))
160 (s1 (make-struct v 0 "hello" 123 "invisible-secret1"))
161 (s2 (make-struct v 0 "hello" 123 "invisible-secret2")))
162 (= (hash s1 7777) (hash s2 7777))))
164 (pass-if "cyclic structs"
165 (let* ((v (make-vtable "pw"))
166 (a (make-struct v 0 #f))
167 (b (make-struct v 0 a)))
169 (and (hash a 7777) (hash b 7777) #t))))
176 (define exception:bad-tail
177 (cons 'misc-error "tail array not allowed unless"))
179 (with-test-prefix "make-struct"
181 ;; in guile 1.8.1 and earlier, this caused an error throw out of an
182 ;; SCM_CRITICAL_SECTION_START / SCM_CRITICAL_SECTION_END, which abort()ed
185 (pass-if-exception "wrong type for `u' field" exception:wrong-type-arg
186 (let* ((vv (make-vtable standard-vtable-fields))
187 (v (make-struct vv 0 (make-struct-layout "uw"))))
188 (make-struct v 0 'x)))
190 ;; In guile 1.8.1 and earlier, and 1.6.8 and earlier, there was no check
191 ;; on a tail array being created without an R/W/O type for it. This left
192 ;; it uninitialized by scm_struct_init(), resulting in garbage getting
193 ;; into an SCM when struct-ref read it (and attempting to print a garbage
194 ;; SCM can cause a segv).
196 (pass-if-exception "no R/W/O for tail array" exception:bad-tail
197 (let* ((vv (make-vtable standard-vtable-fields))
198 (v (make-struct vv 0 (make-struct-layout "pw"))))
199 (make-struct v 123 'x))))
205 (with-test-prefix "make-vtable"
207 (pass-if "without printer"
208 (let* ((vtable (make-vtable "pwpr"))
209 (struct (make-struct vtable 0 'x 'y)))
210 (and (eq? 'x (struct-ref struct 0))
211 (eq? 'y (struct-ref struct 1)))))
213 (pass-if "with printer"
215 (define (print struct port)
216 (display "hello" port))
218 (let* ((vtable (make-vtable "pwpr" print))
219 (struct (make-struct vtable 0 'x 'y))
220 (str (call-with-output-string
222 (display struct port)))))
223 (equal? str "hello")))))