Commit | Line | Data |
---|---|---|
7171f1ab DH |
1 | ;;;; srfi-17.test --- test suite for Guile's SRFI-17 functions. -*- scheme -*- |
2 | ;;;; | |
e75184d5 | 3 | ;;;; Copyright (C) 2001, 2003, 2005, 2006, 2010 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 | 19 | (define-module (test-suite test-srfi-17) |
e75184d5 AW |
20 | #:use-module (ice-9 regex) |
21 | #:use-module (test-suite lib) | |
22 | #:use-module (srfi srfi-17)) | |
d6e04e7c | 23 | |
7171f1ab | 24 | |
3c1f825c KR |
25 | (pass-if "cond-expand srfi-17" |
26 | (cond-expand (srfi-17 #t) | |
27 | (else #f))) | |
28 | ||
29 | ;; | |
30 | ;; car | |
31 | ;; | |
32 | ||
33 | (with-test-prefix "car" | |
34 | ||
8e1973d9 KR |
35 | ;; this test failed in guile 1.8.1 and 1.6.8 and earlier, since `define' |
36 | ;; didn't set a name on a procedure-with-setter | |
37 | (pass-if "procedure-name" | |
38 | (if (memq 'procnames (debug-options)) ;; enabled by default | |
39 | (eq? 'car (procedure-name car)) | |
40 | (throw 'unsupported))) | |
41 | ||
3c1f825c KR |
42 | (pass-if "set! (car x)" |
43 | (let ((lst (list 1))) | |
44 | (set! (car lst) 2) | |
45 | (eqv? 2 (car lst))))) | |
46 | ||
47 | ;; | |
48 | ;; set! | |
49 | ;; | |
50 | ||
e08f3f7a LC |
51 | (define %some-variable #f) |
52 | ||
a48358b3 | 53 | (define exception:bad-quote |
e75184d5 AW |
54 | '(quote . "bad syntax")) |
55 | ||
56 | ;; (put 'pass-if-syntax-error 'scheme-indent-function 1) | |
57 | (define-syntax pass-if-syntax-error | |
58 | (syntax-rules () | |
59 | ((_ name pat exp) | |
60 | (pass-if name | |
61 | (catch 'syntax-error | |
62 | (lambda () exp (error "expected uri-error exception")) | |
63 | (lambda (k who what where form . maybe-subform) | |
64 | (if (if (pair? pat) | |
65 | (and (eq? who (car pat)) | |
66 | (string-match (cdr pat) what)) | |
67 | (string-match pat what)) | |
68 | #t | |
69 | (error "unexpected syntax-error exception" what pat)))))))) | |
a48358b3 | 70 | |
7171f1ab DH |
71 | (with-test-prefix "set!" |
72 | ||
73 | (with-test-prefix "target is not procedure with setter" | |
74 | ||
75 | (pass-if-exception "(set! (symbol->string 'x) 1)" | |
76 | exception:wrong-type-arg | |
77 | (set! (symbol->string 'x) 1)) | |
78 | ||
e75184d5 | 79 | (pass-if-syntax-error "(set! '#f 1)" |
a48358b3 | 80 | exception:bad-quote |
e08f3f7a LC |
81 | (eval '(set! '#f 1) (interaction-environment)))) |
82 | ||
83 | (with-test-prefix "target uses macro" | |
84 | ||
85 | (pass-if "(set! (@@ ...) 1)" | |
86 | (eval '(set! (@@ (test-suite test-srfi-17) %some-variable) 1) | |
87 | (interaction-environment)) | |
88 | (equal? %some-variable 1)) | |
89 | ||
90 | ;; The `(quote x)' below used to be memoized as an infinite list before | |
91 | ;; Guile 1.8.3. | |
e75184d5 | 92 | (pass-if-syntax-error "(set! 'x 1)" |
a48358b3 | 93 | exception:bad-quote |
e08f3f7a | 94 | (eval '(set! 'x 1) (interaction-environment))))) |
3c1f825c KR |
95 | |
96 | ;; | |
97 | ;; setter | |
98 | ;; | |
99 | ||
100 | (with-test-prefix "setter" | |
101 | ||
102 | (pass-if-exception "set! (setter x)" (cons 'misc-error ".*") | |
103 | (set! (setter car) noop)) | |
104 | ||
105 | (pass-if "car" | |
106 | (eq? set-car! (setter car)))) |