Commit | Line | Data |
---|---|---|
aa42c036 LC |
1 | ;;;; structs.test --- Structures. -*- mode: scheme; coding: utf-8; -*- |
2 | ;;;; Ludovic Courtès <ludo@gnu.org>, 2006-06-12. | |
487f6be1 | 3 | ;;;; |
07e6d2d4 | 4 | ;;;; Copyright (C) 2006, 2007, 2009, 2010, 2012 Free Software Foundation, Inc. |
487f6be1 | 5 | ;;;; |
53befeb7 NJ |
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. | |
10 | ;;;; | |
11 | ;;;; This library is distributed in the hope that it will be useful, | |
487f6be1 | 12 | ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of |
53befeb7 NJ |
13 | ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU |
14 | ;;;; Lesser General Public License for more details. | |
15 | ;;;; | |
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 | |
487f6be1 | 19 | |
42ddb3cb LC |
20 | (define-module (test-suite test-structs) |
21 | :use-module (test-suite lib)) | |
487f6be1 LC |
22 | |
23 | ||
24 | \f | |
25 | ;;; | |
26 | ;;; Struct example taken from the reference manual (by Tom Lord). | |
27 | ;;; | |
28 | ||
07e6d2d4 AW |
29 | (define ball-root |
30 | (make-vtable (string-append standard-vtable-fields "pr") 0)) | |
487f6be1 LC |
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) | |
07e6d2d4 | 67 | (eq? (struct-vtable ball-root) <standard-vtable>) |
487f6be1 LC |
68 | |
69 | ;; end of the vtable tower | |
07e6d2d4 | 70 | (eq? (struct-vtable <standard-vtable>) <standard-vtable>))) |
487f6be1 LC |
71 | |
72 | (pass-if-exception "write-access denied" | |
73 | exception:struct-set!-denied | |
74 | ||
75 | ;; The first field of instances of BALL-ROOT is read-only. | |
76 | (struct-set! red vtable-offset-user "blue")) | |
77 | ||
78 | (pass-if "write-access granted" | |
79 | (set-owner! (make-ball red "Bob") "Fred") | |
80 | #t) | |
81 | ||
82 | (pass-if "struct-set!" | |
83 | (let ((ball (make-ball green "Bob"))) | |
84 | (set-owner! ball "Bill") | |
aa42c036 | 85 | (string=? (owner ball) "Bill"))) |
487f6be1 | 86 | |
aa42c036 LC |
87 | (pass-if "struct-ref" |
88 | (let ((ball (make-ball red "Alice"))) | |
89 | (equal? (struct-ref ball 0) "Alice"))) | |
42ddb3cb | 90 | |
aa42c036 LC |
91 | (pass-if "struct-set!" |
92 | (let* ((v (make-vtable "pw")) | |
93 | (s (make-struct v 0)) | |
94 | (r (struct-set! s 0 'a))) | |
95 | (eq? r | |
96 | (struct-ref s 0) | |
97 | 'a))) | |
98 | ||
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))) | |
103 | (struct-ref s 2))) | |
104 | ||
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)))) | |
110 | ||
111 | \f | |
42ddb3cb LC |
112 | (with-test-prefix "equal?" |
113 | ||
114 | (pass-if "simple structs" | |
fb0f1a40 | 115 | (let* ((vtable (make-vtable "pr")) |
42ddb3cb LC |
116 | (s1 (make-struct vtable 0 "hello")) |
117 | (s2 (make-struct vtable 0 "hello"))) | |
118 | (equal? s1 s2))) | |
119 | ||
120 | (pass-if "more complex structs" | |
487f6be1 | 121 | (let ((first (make-ball red (string-copy "Bob"))) |
42ddb3cb | 122 | (second (make-ball red (string-copy "Bob")))) |
487f6be1 LC |
123 | (equal? first second))) |
124 | ||
125 | (pass-if "not-equal?" | |
42ddb3cb | 126 | (not (or (equal? (make-ball red "Bob") (make-ball green "Bob")) |
487f6be1 LC |
127 | (equal? (make-ball red "Bob") (make-ball red "Bill")))))) |
128 | ||
8ac870de LC |
129 | \f |
130 | (with-test-prefix "hash" | |
131 | ||
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)))) | |
137 | ||
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)))) | |
144 | ||
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)))) | |
487f6be1 | 152 | |
8ac870de LC |
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)))) | |
157 | ||
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)))) | |
163 | ||
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))) | |
168 | (struct-set! a 0 b) | |
169 | (and (hash a 7777) (hash b 7777) #t)))) | |
170 | ||
171 | \f | |
004be623 KR |
172 | ;; |
173 | ;; make-struct | |
174 | ;; | |
175 | ||
176 | (define exception:bad-tail | |
177 | (cons 'misc-error "tail array not allowed unless")) | |
178 | ||
179 | (with-test-prefix "make-struct" | |
180 | ||
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 | |
183 | ;; the program | |
184 | ;; | |
185 | (pass-if-exception "wrong type for `u' field" exception:wrong-type-arg | |
07e6d2d4 | 186 | (let* ((vv (make-vtable standard-vtable-fields)) |
004be623 KR |
187 | (v (make-struct vv 0 (make-struct-layout "uw")))) |
188 | (make-struct v 0 'x))) | |
189 | ||
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). | |
195 | ;; | |
196 | (pass-if-exception "no R/W/O for tail array" exception:bad-tail | |
07e6d2d4 | 197 | (let* ((vv (make-vtable standard-vtable-fields)) |
004be623 KR |
198 | (v (make-struct vv 0 (make-struct-layout "pw")))) |
199 | (make-struct v 123 'x)))) | |
200 | ||
201 | ;; | |
202 | ;; make-vtable | |
203 | ;; | |
204 | ||
205 | (with-test-prefix "make-vtable" | |
206 | ||
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))))) | |
212 | ||
213 | (pass-if "with printer" | |
214 | (let () | |
215 | (define (print struct port) | |
216 | (display "hello" port)) | |
217 | ||
218 | (let* ((vtable (make-vtable "pwpr" print)) | |
219 | (struct (make-struct vtable 0 'x 'y)) | |
220 | (str (call-with-output-string | |
221 | (lambda (port) | |
222 | (display struct port))))) | |
223 | (equal? str "hello"))))) |