Commit | Line | Data |
---|---|---|
3514320f MV |
1 | ;;;; srfi-39.test --- -*- scheme -*- |
2 | ;;;; | |
76350432 | 3 | ;;;; Copyright (C) 2004, 2005, 2006, 2008 Free Software Foundation, Inc. |
3514320f | 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. | |
3514320f | 9 | ;;;; |
53befeb7 | 10 | ;;;; This library is distributed in the hope that it will be useful, |
3514320f | 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. | |
3514320f | 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 | |
3514320f | 18 | |
1352a755 KR |
19 | (define-module (test-srfi-39) |
20 | #:use-module (test-suite lib) | |
76350432 LC |
21 | #:use-module (srfi srfi-34) |
22 | #:use-module (srfi srfi-39) | |
23 | #:duplicates (last) ;; avoid warning about srfi-34 replacing `raise' | |
24 | ) | |
3514320f MV |
25 | |
26 | (define a (make-parameter 3)) | |
27 | (define b (make-parameter 4)) | |
28 | ||
29 | (define (check a b a-val b-val) | |
30 | (and (eqv? (a) a-val)) (eqv? (b) b-val)) | |
31 | ||
32 | (define c (make-parameter 2 (lambda (x) (if (< x 10) x 10)))) | |
33 | (define d (make-parameter 15 (lambda (x) (if (< x 10) x 10)))) | |
34 | ||
35 | (with-test-prefix "SRFI-39" | |
36 | ||
37 | (pass-if "test 1" | |
38 | (check a b 3 4)) | |
39 | ||
40 | (pass-if "test 2" | |
41 | (parameterize ((a 2) (b 1)) | |
42 | (and (check a b 2 1) | |
43 | (parameterize ((b 8)) | |
44 | (check a b 2 8))))) | |
45 | ||
46 | (pass-if "test 3" | |
47 | (check a b 3 4)) | |
48 | ||
49 | (pass-if "test 4" | |
50 | (check c d 2 10)) | |
51 | ||
52 | (pass-if "test 5" | |
53 | (parameterize ((a 0) (b 1) (c 98) (d 9)) | |
54 | (and (check a b 0 1) | |
55 | (check c d 10 9) | |
56 | (parameterize ((c (a)) (d (b))) | |
57 | (and (check a b 0 1) | |
76350432 LC |
58 | (check c d 0 1)))))) |
59 | ||
60 | (pass-if "SRFI-34" | |
61 | (let ((inside? (make-parameter #f))) | |
62 | (call/cc (lambda (return) | |
63 | (with-exception-handler | |
64 | (lambda (c) | |
65 | ;; This handler should be called in the dynamic | |
66 | ;; environment installed by `parameterize'. | |
67 | (return (inside?))) | |
68 | (lambda () | |
69 | (parameterize ((inside? #t)) | |
70 | (raise 'some-exception))))))))) | |
b85bb56c KR |
71 | |
72 | (let () | |
73 | (define (test-ports param new-port new-port-2) | |
74 | (let ((old-port (param))) | |
75 | ||
76 | (pass-if "new value" | |
77 | (parameterize ((param new-port)) | |
78 | (eq? (param) new-port))) | |
79 | ||
80 | (pass-if "set value" | |
81 | (parameterize ((param old-port)) | |
82 | (param new-port) | |
83 | (eq? (param) new-port))) | |
84 | ||
85 | (pass-if "old restored" | |
86 | (parameterize ((param new-port)) | |
87 | #f) | |
88 | (eq? (param) old-port)) | |
89 | ||
90 | (pass-if "throw exit" | |
91 | (catch 'bail | |
92 | (lambda () | |
93 | (parameterize ((param new-port)) | |
94 | (throw 'bail))) | |
95 | (lambda args #f)) | |
96 | (eq? (param) old-port)) | |
97 | ||
98 | (pass-if "call/cc re-enter" | |
99 | (let ((cont #f) | |
100 | (count 0) | |
101 | (port #f) | |
102 | (good #t)) | |
103 | (parameterize ((param new-port)) | |
104 | (call/cc (lambda (k) (set! cont k))) | |
105 | (set! count (1+ count)) | |
106 | (set! port (param)) | |
107 | (if (= 1 count) (param new-port-2))) | |
108 | (set! good (and good (eq? (param) old-port))) | |
109 | (case count | |
110 | ((1) | |
111 | (set! good (and good (eq? port new-port))) | |
112 | ;; re-entering should give new-port-2 left there last time | |
113 | (cont)) | |
114 | ((2) | |
115 | (set! good (and good (eq? port new-port-2))))) | |
116 | good)) | |
117 | ||
118 | (pass-if "original unchanged" | |
119 | (eq? (param) old-port)))) | |
120 | ||
121 | (with-test-prefix "current-input-port" | |
122 | (test-ports current-input-port | |
123 | (open-input-string "xyz") (open-input-string "xyz"))) | |
124 | ||
125 | (with-test-prefix "current-output-port" | |
126 | (test-ports current-output-port | |
127 | (open-output-string) (open-output-string))) | |
128 | ||
129 | (with-test-prefix "current-error-port" | |
130 | (test-ports current-error-port | |
131 | (open-output-string) (open-output-string)))) |