Commit | Line | Data |
---|---|---|
7171f1ab DH |
1 | ;;;; srfi-17.test --- test suite for Guile's SRFI-17 functions. -*- scheme -*- |
2 | ;;;; | |
6e7d5622 | 3 | ;;;; Copyright (C) 2001, 2003, 2005, 2006 Free Software Foundation, Inc. |
7171f1ab | 4 | ;;;; |
53befeb7 NJ |
5 | ;;;; This library is free software; you can redistribute it and/or |
6 | ;;;; modify it under the terms of the GNU Lesser General Public | |
7 | ;;;; License as published by the Free Software Foundation; either | |
8 | ;;;; version 3 of the License, or (at your option) any later version. | |
7171f1ab | 9 | ;;;; |
53befeb7 | 10 | ;;;; This library is distributed in the hope that it will be useful, |
7171f1ab | 11 | ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of |
53befeb7 NJ |
12 | ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU |
13 | ;;;; Lesser General Public License for more details. | |
7171f1ab | 14 | ;;;; |
53befeb7 NJ |
15 | ;;;; You should have received a copy of the GNU Lesser General Public |
16 | ;;;; License along with this library; if not, write to the Free Software | |
17 | ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA | |
7171f1ab | 18 | |
d6e04e7c DH |
19 | (define-module (test-suite test-srfi-17) |
20 | :use-module (test-suite lib) | |
21 | :use-module (srfi srfi-17)) | |
22 | ||
7171f1ab | 23 | |
3c1f825c KR |
24 | (pass-if "cond-expand srfi-17" |
25 | (cond-expand (srfi-17 #t) | |
26 | (else #f))) | |
27 | ||
28 | ;; | |
29 | ;; car | |
30 | ;; | |
31 | ||
32 | (with-test-prefix "car" | |
33 | ||
8e1973d9 KR |
34 | ;; this test failed in guile 1.8.1 and 1.6.8 and earlier, since `define' |
35 | ;; didn't set a name on a procedure-with-setter | |
36 | (pass-if "procedure-name" | |
37 | (if (memq 'procnames (debug-options)) ;; enabled by default | |
38 | (eq? 'car (procedure-name car)) | |
39 | (throw 'unsupported))) | |
40 | ||
3c1f825c KR |
41 | (pass-if "set! (car x)" |
42 | (let ((lst (list 1))) | |
43 | (set! (car lst) 2) | |
44 | (eqv? 2 (car lst))))) | |
45 | ||
46 | ;; | |
47 | ;; set! | |
48 | ;; | |
49 | ||
e08f3f7a LC |
50 | (define %some-variable #f) |
51 | ||
a48358b3 AW |
52 | (define exception:bad-quote |
53 | '(syntax-error . "quote: bad syntax")) | |
54 | ||
7171f1ab DH |
55 | (with-test-prefix "set!" |
56 | ||
57 | (with-test-prefix "target is not procedure with setter" | |
58 | ||
59 | (pass-if-exception "(set! (symbol->string 'x) 1)" | |
60 | exception:wrong-type-arg | |
61 | (set! (symbol->string 'x) 1)) | |
62 | ||
63 | (pass-if-exception "(set! '#f 1)" | |
a48358b3 | 64 | exception:bad-quote |
e08f3f7a LC |
65 | (eval '(set! '#f 1) (interaction-environment)))) |
66 | ||
67 | (with-test-prefix "target uses macro" | |
68 | ||
69 | (pass-if "(set! (@@ ...) 1)" | |
70 | (eval '(set! (@@ (test-suite test-srfi-17) %some-variable) 1) | |
71 | (interaction-environment)) | |
72 | (equal? %some-variable 1)) | |
73 | ||
74 | ;; The `(quote x)' below used to be memoized as an infinite list before | |
75 | ;; Guile 1.8.3. | |
76 | (pass-if-exception "(set! 'x 1)" | |
a48358b3 | 77 | exception:bad-quote |
e08f3f7a | 78 | (eval '(set! 'x 1) (interaction-environment))))) |
3c1f825c KR |
79 | |
80 | ;; | |
81 | ;; setter | |
82 | ;; | |
83 | ||
84 | (with-test-prefix "setter" | |
85 | ||
86 | (pass-if-exception "set! (setter x)" (cons 'misc-error ".*") | |
87 | (set! (setter car) noop)) | |
88 | ||
89 | (pass-if "car" | |
90 | (eq? set-car! (setter car)))) |