Commit | Line | Data |
---|---|---|
04bb321a | 1 | ;;;; elisp.test --- tests guile's elisp support -*- scheme -*- |
6e7d5622 | 2 | ;;;; Copyright (C) 2002, 2003, 2006 Free Software Foundation, Inc. |
04bb321a | 3 | ;;;; |
73be1d9e MV |
4 | ;;;; This library is free software; you can redistribute it and/or |
5 | ;;;; modify it under the terms of the GNU Lesser General Public | |
6 | ;;;; License as published by the Free Software Foundation; either | |
7 | ;;;; version 2.1 of the License, or (at your option) any later version. | |
8 | ;;;; | |
9 | ;;;; This library is distributed in the hope that it will be useful, | |
04bb321a | 10 | ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of |
73be1d9e MV |
11 | ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU |
12 | ;;;; Lesser General Public License for more details. | |
13 | ;;;; | |
14 | ;;;; You should have received a copy of the GNU Lesser General Public | |
15 | ;;;; License along with this library; if not, write to the Free Software | |
92205699 | 16 | ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA |
04bb321a | 17 | |
e68ef9c8 DH |
18 | (define-module (test-suite test-elisp) |
19 | :use-module (test-suite lib) | |
20 | :use-module (ice-9 weak-vector)) | |
21 | ||
62f80361 AW |
22 | (define *old-stack-level* (and=> (memq 'stack (debug-options)) cadr)) |
23 | (if *old-stack-level* | |
24 | (debug-set! stack (* 2 *old-stack-level*))) | |
25 | ||
04bb321a NJ |
26 | ;;; |
27 | ;;; elisp | |
28 | ;;; | |
29 | ||
30 | (if (defined? '%nil) | |
31 | ||
32 | (with-test-prefix "scheme" | |
33 | ||
34 | (with-test-prefix "nil value is a boolean" | |
35 | ||
36 | (pass-if "boolean?" | |
37 | (boolean? %nil)) | |
38 | ||
39 | ) | |
40 | ||
41 | (with-test-prefix "nil value is false" | |
42 | ||
43 | (pass-if "not" | |
44 | (eq? (not %nil) #t)) | |
45 | ||
46 | (pass-if "if" | |
47 | (if %nil #f #t)) | |
48 | ||
49 | (pass-if "and" | |
50 | (eq? (and %nil #t) #f)) | |
51 | ||
52 | (pass-if "or" | |
53 | (eq? (or %nil #f) #f)) | |
54 | ||
55 | (pass-if "cond" | |
56 | (cond (%nil #f) (else #t))) | |
57 | ||
58 | (pass-if "do" | |
59 | (call-with-current-continuation | |
60 | (lambda (exit) | |
61 | (do ((i 0 (+ i 1))) | |
62 | (%nil (exit #f)) | |
63 | (if (> i 10) | |
64 | (exit #t)))))) | |
65 | ||
66 | ) | |
67 | ||
68 | (with-test-prefix "nil value as an empty list" | |
69 | ||
70 | (pass-if "list?" | |
71 | (list? %nil)) | |
72 | ||
73 | (pass-if "null?" | |
74 | (null? %nil)) | |
75 | ||
76 | (pass-if "sort" | |
77 | (eq? (sort %nil <) %nil)) | |
78 | ||
79 | ) | |
80 | ||
81 | (with-test-prefix "lists formed using nil value" | |
82 | ||
83 | (pass-if "list?" | |
84 | (list? (cons 'a %nil))) | |
85 | ||
962b1f0b NJ |
86 | (pass-if "length of %nil" |
87 | (= (length %nil) 0)) | |
88 | ||
04bb321a NJ |
89 | (pass-if "length" |
90 | (= (length (cons 'a (cons 'b (cons 'c %nil)))) 3)) | |
91 | ||
92 | (pass-if "length (with backquoted list)" | |
93 | (= (length `(a b c . ,%nil)) 3)) | |
94 | ||
bbd26b5a NJ |
95 | (pass-if "write (%nil)" |
96 | (string=? (with-output-to-string | |
97 | (lambda () (write %nil))) | |
98 | "#nil")) ; Hmmm... should be "()" ? | |
99 | ||
100 | (pass-if "display (%nil)" | |
101 | (string=? (with-output-to-string | |
102 | (lambda () (display %nil))) | |
103 | "#nil")) ; Ditto. | |
104 | ||
105 | (pass-if "write (list)" | |
04bb321a NJ |
106 | (string=? (with-output-to-string |
107 | (lambda () (write (cons 'a %nil)))) | |
108 | "(a)")) | |
109 | ||
bbd26b5a | 110 | (pass-if "display (list)" |
04bb321a NJ |
111 | (string=? (with-output-to-string |
112 | (lambda () (display (cons 'a %nil)))) | |
113 | "(a)")) | |
114 | ||
962b1f0b NJ |
115 | (pass-if "assq" |
116 | (and (equal? (assq 1 `((1 one) (2 two) . ,%nil)) | |
117 | '(1 one)) | |
118 | (equal? (assq 3 `((1 one) (2 two) . ,%nil)) | |
119 | #f))) | |
120 | ||
121 | (pass-if "assv" | |
122 | (and (equal? (assv 1 `((1 one) (2 two) . ,%nil)) | |
123 | '(1 one)) | |
124 | (equal? (assv 3 `((1 one) (2 two) . ,%nil)) | |
125 | #f))) | |
126 | ||
127 | (pass-if "assoc" | |
128 | (and (equal? (assoc 1 `((1 one) (2 two) . ,%nil)) | |
129 | '(1 one)) | |
130 | (equal? (assoc 3 `((1 one) (2 two) . ,%nil)) | |
131 | #f))) | |
132 | ||
133 | (pass-if "with-fluids*" | |
134 | (let ((f (make-fluid)) | |
135 | (g (make-fluid))) | |
136 | (with-fluids* (cons f (cons g %nil)) | |
137 | '(3 4) | |
138 | (lambda () | |
139 | (and (eq? (fluid-ref f) 3) | |
140 | (eq? (fluid-ref g) 4)))))) | |
141 | ||
142 | (pass-if "append!" | |
143 | (let ((a (copy-tree '(1 2 3))) | |
144 | (b (copy-tree `(4 5 6 . ,%nil))) | |
145 | (c (copy-tree '(7 8 9))) | |
146 | (d (copy-tree `(a b c . ,%nil)))) | |
147 | (equal? (append! a b c d) | |
148 | `(1 2 3 4 5 6 7 8 9 a b c . ,%nil)))) | |
149 | ||
150 | (pass-if "last-pair" | |
151 | (equal? (last-pair `(1 2 3 4 5 . ,%nil)) | |
152 | (cons 5 %nil))) | |
153 | ||
154 | (pass-if "reverse" | |
155 | (equal? (reverse `(1 2 3 4 5 . ,%nil)) | |
156 | '(5 4 3 2 1))) ; Hmmm... is this OK, or | |
157 | ; should it be | |
158 | ; `(5 4 3 2 1 . ,%nil) ? | |
159 | ||
160 | (pass-if "reverse!" | |
161 | (equal? (reverse! (copy-tree `(1 2 3 4 5 . ,%nil))) | |
162 | '(5 4 3 2 1))) ; Ditto. | |
163 | ||
164 | (pass-if "list-ref" | |
165 | (eq? (list-ref `(0 1 2 3 4 . ,%nil) 4) 4)) | |
166 | ||
167 | (pass-if-exception "list-ref" | |
168 | exception:out-of-range | |
169 | (eq? (list-ref `(0 1 2 3 4 . ,%nil) 6) 6)) | |
170 | ||
171 | (pass-if "list-set!" | |
172 | (let ((l (copy-tree `(0 1 2 3 4 . ,%nil)))) | |
173 | (list-set! l 4 44) | |
174 | (= (list-ref l 4) 44))) | |
175 | ||
176 | (pass-if-exception "list-set!" | |
177 | exception:out-of-range | |
178 | (let ((l (copy-tree `(0 1 2 3 4 . ,%nil)))) | |
179 | (list-set! l 6 44) | |
180 | (= (list-ref l 6) 44))) | |
181 | ||
bbd26b5a NJ |
182 | (pass-if "list-cdr-set!" |
183 | (let ((l (copy-tree `(0 1 2 3 4 . ,%nil)))) | |
184 | (and (begin | |
185 | (list-cdr-set! l 4 44) | |
186 | (equal? l '(0 1 2 3 4 . 44))) | |
187 | (begin | |
188 | (list-cdr-set! l 3 `(new . ,%nil)) | |
189 | (equal? l `(0 1 2 3 new . ,%nil)))))) | |
190 | ||
191 | (pass-if-exception "list-cdr-set!" | |
192 | exception:out-of-range | |
193 | (let ((l (copy-tree `(0 1 2 3 4 . ,%nil)))) | |
194 | (list-cdr-set! l 6 44))) | |
195 | ||
196 | (pass-if "memq" | |
197 | (equal? (memq 'c `(a b c d . ,%nil)) `(c d . ,%nil))) | |
198 | ||
199 | (pass-if "memv" | |
200 | (equal? (memv 'c `(a b c d . ,%nil)) `(c d . ,%nil))) | |
201 | ||
202 | (pass-if "member" | |
203 | (equal? (member "c" `("a" "b" "c" "d" . ,%nil)) `("c" "d" . ,%nil))) | |
204 | ||
205 | (pass-if "list->vector" | |
42ad901d | 206 | (equal? '#(1 2 3) (list->vector `(1 2 3 . ,%nil)))) |
bbd26b5a NJ |
207 | |
208 | (pass-if "list->vector" | |
42ad901d | 209 | (equal? '#(1 2 3) (list->vector `(1 2 3 . ,%nil)))) |
bbd26b5a NJ |
210 | |
211 | (pass-if "list->weak-vector" | |
212 | (equal? (weak-vector 1 2 3) (list->weak-vector `(1 2 3 . ,%nil)))) | |
213 | ||
214 | (pass-if "sorted?" | |
215 | (and (sorted? `(1 2 3 . ,%nil) <) | |
216 | (not (sorted? `(1 6 3 . ,%nil) <)))) | |
217 | ||
218 | (pass-if "merge" | |
219 | (equal? (merge '(1 4 7 10) | |
220 | (merge `(2 5 8 11 . ,%nil) | |
221 | `(3 6 9 12 . ,%nil) | |
222 | <) | |
223 | <) | |
224 | `(1 2 3 4 5 6 7 8 9 10 11 12 . ,%nil))) | |
225 | ||
226 | (pass-if "merge!" | |
227 | (equal? (merge! (copy-tree '(1 4 7 10)) | |
228 | (merge! (copy-tree `(2 5 8 11 . ,%nil)) | |
229 | (copy-tree `(3 6 9 12 . ,%nil)) | |
230 | <) | |
231 | <) | |
232 | `(1 2 3 4 5 6 7 8 9 10 11 12 . ,%nil))) | |
233 | ||
234 | (pass-if "sort" | |
235 | (equal? (sort `(1 5 3 8 4 . ,%nil) <) '(1 3 4 5 8))) | |
236 | ||
237 | (pass-if "stable-sort" | |
238 | (equal? (stable-sort `(1 5 3 8 4 . ,%nil) <) '(1 3 4 5 8))) | |
239 | ||
240 | (pass-if "sort!" | |
241 | (equal? (sort! (copy-tree `(1 5 3 8 4 . ,%nil)) <) | |
242 | '(1 3 4 5 8))) | |
243 | ||
244 | (pass-if "stable-sort!" | |
245 | (equal? (stable-sort! (copy-tree `(1 5 3 8 4 . ,%nil)) <) | |
246 | '(1 3 4 5 8))) | |
247 | ||
04bb321a NJ |
248 | ) |
249 | ||
250 | (with-test-prefix "value preservation" | |
251 | ||
252 | (pass-if "car" | |
253 | (eq? (car (cons %nil 'a)) %nil)) | |
254 | ||
255 | (pass-if "cdr" | |
256 | (eq? (cdr (cons 'a %nil)) %nil)) | |
257 | ||
258 | (pass-if "vector-ref" | |
259 | (eq? (vector-ref (vector %nil) 0) %nil)) | |
260 | ||
261 | ) | |
262 | ||
263 | )) | |
264 | ||
a64e6669 NJ |
265 | (if (defined? '%nil) |
266 | (use-modules (lang elisp interface))) | |
267 | ||
268 | (if (defined? '%nil) | |
269 | ||
270 | (with-test-prefix "elisp" | |
271 | ||
272 | (define (elisp-pass-if expr expected) | |
273 | (pass-if (with-output-to-string | |
274 | (lambda () | |
275 | (write expr))) | |
276 | (let ((calc (with-output-to-string | |
277 | (lambda () | |
278 | (write (eval-elisp expr)))))) | |
279 | (string=? calc expected)))) | |
280 | ||
281 | (elisp-pass-if '(and #f) "#f") | |
282 | (elisp-pass-if '(and #t) "#t") | |
283 | (elisp-pass-if '(and nil) "#nil") | |
284 | (elisp-pass-if '(and t) "#t") | |
285 | (elisp-pass-if '(and) "#t") | |
286 | (elisp-pass-if '(cond (nil t) (t 3)) "3") | |
287 | (elisp-pass-if '(cond (nil t) (t)) "#t") | |
288 | (elisp-pass-if '(cond (nil)) "#nil") | |
289 | (elisp-pass-if '(cond) "#nil") | |
290 | (elisp-pass-if '(if #f 'a 'b) "b") | |
291 | (elisp-pass-if '(if #t 'a 'b) "a") | |
292 | (elisp-pass-if '(if '() 'a 'b) "b") | |
293 | (elisp-pass-if '(if nil 'a 'b) "b") | |
294 | (elisp-pass-if '(if nil 1 2 3 4) "4") | |
295 | (elisp-pass-if '(if nil 1 2) "2") | |
296 | (elisp-pass-if '(if nil 1) "#nil") | |
297 | (elisp-pass-if '(if t 1 2) "1") | |
298 | (elisp-pass-if '(if t 1) "1") | |
299 | (elisp-pass-if '(let (a) a) "#nil") | |
300 | (elisp-pass-if '(let* (a) a) "#nil") | |
301 | (elisp-pass-if '(let* ((a 1) (b (* a 2))) b) "2") | |
302 | (elisp-pass-if '(memq '() '(())) "(())") | |
303 | (elisp-pass-if '(memq '() '(nil)) "(#nil)") | |
304 | (elisp-pass-if '(memq '() '(t)) "#nil") | |
305 | (elisp-pass-if '(memq nil '(())) "(())") | |
306 | (elisp-pass-if '(memq nil '(nil)) "(#nil)") | |
307 | (elisp-pass-if '(memq nil (list nil)) "(#nil)") | |
308 | (elisp-pass-if '(null '#f) "#t") | |
309 | (elisp-pass-if '(null '()) "#t") | |
310 | (elisp-pass-if '(null 'nil) "#t") | |
311 | (elisp-pass-if '(null nil) "#t") | |
312 | (elisp-pass-if '(or 1 2 3) "1") | |
313 | (elisp-pass-if '(or nil t nil) "#t") | |
314 | (elisp-pass-if '(or nil) "#nil") | |
315 | (elisp-pass-if '(or t nil t) "#t") | |
316 | (elisp-pass-if '(or t) "#t") | |
317 | (elisp-pass-if '(or) "#nil") | |
318 | (elisp-pass-if '(prog1 1 2 3) "1") | |
319 | (elisp-pass-if '(prog2 1 2 3) "2") | |
320 | (elisp-pass-if '(progn 1 2 3) "3") | |
321 | (elisp-pass-if '(while nil 1) "#nil") | |
322 | ||
323 | (elisp-pass-if '(defun testf (x y &optional o &rest r) (list x y o r)) "testf") | |
324 | (elisp-pass-if '(testf 1 2) "(1 2 #nil #nil)") | |
325 | (elisp-pass-if '(testf 1 2 3 4 5 56) "(1 2 3 (4 5 56))") | |
326 | ;; NB `lambda' in Emacs is self-quoting, but that's only after | |
327 | ;; loading the macro definition of lambda in subr.el. | |
328 | (elisp-pass-if '(function (lambda (x y &optional o &rest r) (list x y o r))) "(lambda (x y &optional o &rest r) (list x y o r))") | |
329 | (elisp-pass-if '(funcall (lambda (x y &optional o &rest r) (list x y o r)) 1 2 3 4) "(1 2 3 (4))") | |
330 | (elisp-pass-if '(apply (lambda (x y &optional o &rest r) (list x y o r)) 1 2 3 nil) "(1 2 3 #nil)") | |
331 | ||
332 | (elisp-pass-if '(setq x 3) "3") | |
333 | (elisp-pass-if '(defvar x 4) "x") | |
334 | (elisp-pass-if 'x "3") | |
335 | ||
336 | )) | |
337 | ||
62f80361 AW |
338 | (debug-set! stack *old-stack-level*) |
339 | ||
04bb321a | 340 | ;;; elisp.test ends here |