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 | |
53befeb7 | 7 | ;;;; version 3 of the License, or (at your option) any later version. |
73be1d9e MV |
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 | ||
c2521a21 AW |
26 | (define *old-%load-should-autocompile* %load-should-autocompile) |
27 | (set! %load-should-autocompile #f) | |
28 | ||
04bb321a NJ |
29 | ;;; |
30 | ;;; elisp | |
31 | ;;; | |
32 | ||
33 | (if (defined? '%nil) | |
34 | ||
35 | (with-test-prefix "scheme" | |
36 | ||
37 | (with-test-prefix "nil value is a boolean" | |
38 | ||
39 | (pass-if "boolean?" | |
40 | (boolean? %nil)) | |
41 | ||
42 | ) | |
43 | ||
44 | (with-test-prefix "nil value is false" | |
45 | ||
46 | (pass-if "not" | |
47 | (eq? (not %nil) #t)) | |
48 | ||
49 | (pass-if "if" | |
50 | (if %nil #f #t)) | |
51 | ||
52 | (pass-if "and" | |
53 | (eq? (and %nil #t) #f)) | |
54 | ||
55 | (pass-if "or" | |
56 | (eq? (or %nil #f) #f)) | |
57 | ||
58 | (pass-if "cond" | |
59 | (cond (%nil #f) (else #t))) | |
60 | ||
61 | (pass-if "do" | |
62 | (call-with-current-continuation | |
63 | (lambda (exit) | |
64 | (do ((i 0 (+ i 1))) | |
65 | (%nil (exit #f)) | |
66 | (if (> i 10) | |
67 | (exit #t)))))) | |
68 | ||
69 | ) | |
70 | ||
71 | (with-test-prefix "nil value as an empty list" | |
72 | ||
73 | (pass-if "list?" | |
74 | (list? %nil)) | |
75 | ||
76 | (pass-if "null?" | |
77 | (null? %nil)) | |
78 | ||
79 | (pass-if "sort" | |
80 | (eq? (sort %nil <) %nil)) | |
81 | ||
82 | ) | |
83 | ||
84 | (with-test-prefix "lists formed using nil value" | |
85 | ||
86 | (pass-if "list?" | |
87 | (list? (cons 'a %nil))) | |
88 | ||
962b1f0b NJ |
89 | (pass-if "length of %nil" |
90 | (= (length %nil) 0)) | |
91 | ||
04bb321a NJ |
92 | (pass-if "length" |
93 | (= (length (cons 'a (cons 'b (cons 'c %nil)))) 3)) | |
94 | ||
95 | (pass-if "length (with backquoted list)" | |
96 | (= (length `(a b c . ,%nil)) 3)) | |
97 | ||
bbd26b5a NJ |
98 | (pass-if "write (%nil)" |
99 | (string=? (with-output-to-string | |
100 | (lambda () (write %nil))) | |
101 | "#nil")) ; Hmmm... should be "()" ? | |
102 | ||
103 | (pass-if "display (%nil)" | |
104 | (string=? (with-output-to-string | |
105 | (lambda () (display %nil))) | |
106 | "#nil")) ; Ditto. | |
107 | ||
108 | (pass-if "write (list)" | |
04bb321a NJ |
109 | (string=? (with-output-to-string |
110 | (lambda () (write (cons 'a %nil)))) | |
111 | "(a)")) | |
112 | ||
bbd26b5a | 113 | (pass-if "display (list)" |
04bb321a NJ |
114 | (string=? (with-output-to-string |
115 | (lambda () (display (cons 'a %nil)))) | |
116 | "(a)")) | |
117 | ||
962b1f0b NJ |
118 | (pass-if "assq" |
119 | (and (equal? (assq 1 `((1 one) (2 two) . ,%nil)) | |
120 | '(1 one)) | |
121 | (equal? (assq 3 `((1 one) (2 two) . ,%nil)) | |
122 | #f))) | |
123 | ||
124 | (pass-if "assv" | |
125 | (and (equal? (assv 1 `((1 one) (2 two) . ,%nil)) | |
126 | '(1 one)) | |
127 | (equal? (assv 3 `((1 one) (2 two) . ,%nil)) | |
128 | #f))) | |
129 | ||
130 | (pass-if "assoc" | |
131 | (and (equal? (assoc 1 `((1 one) (2 two) . ,%nil)) | |
132 | '(1 one)) | |
133 | (equal? (assoc 3 `((1 one) (2 two) . ,%nil)) | |
134 | #f))) | |
135 | ||
136 | (pass-if "with-fluids*" | |
137 | (let ((f (make-fluid)) | |
138 | (g (make-fluid))) | |
139 | (with-fluids* (cons f (cons g %nil)) | |
140 | '(3 4) | |
141 | (lambda () | |
142 | (and (eq? (fluid-ref f) 3) | |
143 | (eq? (fluid-ref g) 4)))))) | |
144 | ||
145 | (pass-if "append!" | |
146 | (let ((a (copy-tree '(1 2 3))) | |
147 | (b (copy-tree `(4 5 6 . ,%nil))) | |
148 | (c (copy-tree '(7 8 9))) | |
149 | (d (copy-tree `(a b c . ,%nil)))) | |
150 | (equal? (append! a b c d) | |
151 | `(1 2 3 4 5 6 7 8 9 a b c . ,%nil)))) | |
152 | ||
153 | (pass-if "last-pair" | |
154 | (equal? (last-pair `(1 2 3 4 5 . ,%nil)) | |
155 | (cons 5 %nil))) | |
156 | ||
157 | (pass-if "reverse" | |
158 | (equal? (reverse `(1 2 3 4 5 . ,%nil)) | |
159 | '(5 4 3 2 1))) ; Hmmm... is this OK, or | |
160 | ; should it be | |
161 | ; `(5 4 3 2 1 . ,%nil) ? | |
162 | ||
163 | (pass-if "reverse!" | |
164 | (equal? (reverse! (copy-tree `(1 2 3 4 5 . ,%nil))) | |
165 | '(5 4 3 2 1))) ; Ditto. | |
166 | ||
167 | (pass-if "list-ref" | |
168 | (eq? (list-ref `(0 1 2 3 4 . ,%nil) 4) 4)) | |
169 | ||
170 | (pass-if-exception "list-ref" | |
171 | exception:out-of-range | |
172 | (eq? (list-ref `(0 1 2 3 4 . ,%nil) 6) 6)) | |
173 | ||
174 | (pass-if "list-set!" | |
175 | (let ((l (copy-tree `(0 1 2 3 4 . ,%nil)))) | |
176 | (list-set! l 4 44) | |
177 | (= (list-ref l 4) 44))) | |
178 | ||
179 | (pass-if-exception "list-set!" | |
180 | exception:out-of-range | |
181 | (let ((l (copy-tree `(0 1 2 3 4 . ,%nil)))) | |
182 | (list-set! l 6 44) | |
183 | (= (list-ref l 6) 44))) | |
184 | ||
bbd26b5a NJ |
185 | (pass-if "list-cdr-set!" |
186 | (let ((l (copy-tree `(0 1 2 3 4 . ,%nil)))) | |
187 | (and (begin | |
188 | (list-cdr-set! l 4 44) | |
189 | (equal? l '(0 1 2 3 4 . 44))) | |
190 | (begin | |
191 | (list-cdr-set! l 3 `(new . ,%nil)) | |
192 | (equal? l `(0 1 2 3 new . ,%nil)))))) | |
193 | ||
194 | (pass-if-exception "list-cdr-set!" | |
195 | exception:out-of-range | |
196 | (let ((l (copy-tree `(0 1 2 3 4 . ,%nil)))) | |
197 | (list-cdr-set! l 6 44))) | |
198 | ||
199 | (pass-if "memq" | |
200 | (equal? (memq 'c `(a b c d . ,%nil)) `(c d . ,%nil))) | |
201 | ||
202 | (pass-if "memv" | |
203 | (equal? (memv 'c `(a b c d . ,%nil)) `(c d . ,%nil))) | |
204 | ||
205 | (pass-if "member" | |
206 | (equal? (member "c" `("a" "b" "c" "d" . ,%nil)) `("c" "d" . ,%nil))) | |
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->vector" | |
42ad901d | 212 | (equal? '#(1 2 3) (list->vector `(1 2 3 . ,%nil)))) |
bbd26b5a NJ |
213 | |
214 | (pass-if "list->weak-vector" | |
215 | (equal? (weak-vector 1 2 3) (list->weak-vector `(1 2 3 . ,%nil)))) | |
216 | ||
217 | (pass-if "sorted?" | |
218 | (and (sorted? `(1 2 3 . ,%nil) <) | |
219 | (not (sorted? `(1 6 3 . ,%nil) <)))) | |
220 | ||
221 | (pass-if "merge" | |
222 | (equal? (merge '(1 4 7 10) | |
223 | (merge `(2 5 8 11 . ,%nil) | |
224 | `(3 6 9 12 . ,%nil) | |
225 | <) | |
226 | <) | |
227 | `(1 2 3 4 5 6 7 8 9 10 11 12 . ,%nil))) | |
228 | ||
229 | (pass-if "merge!" | |
230 | (equal? (merge! (copy-tree '(1 4 7 10)) | |
231 | (merge! (copy-tree `(2 5 8 11 . ,%nil)) | |
232 | (copy-tree `(3 6 9 12 . ,%nil)) | |
233 | <) | |
234 | <) | |
235 | `(1 2 3 4 5 6 7 8 9 10 11 12 . ,%nil))) | |
236 | ||
237 | (pass-if "sort" | |
238 | (equal? (sort `(1 5 3 8 4 . ,%nil) <) '(1 3 4 5 8))) | |
239 | ||
240 | (pass-if "stable-sort" | |
241 | (equal? (stable-sort `(1 5 3 8 4 . ,%nil) <) '(1 3 4 5 8))) | |
242 | ||
243 | (pass-if "sort!" | |
244 | (equal? (sort! (copy-tree `(1 5 3 8 4 . ,%nil)) <) | |
245 | '(1 3 4 5 8))) | |
246 | ||
247 | (pass-if "stable-sort!" | |
248 | (equal? (stable-sort! (copy-tree `(1 5 3 8 4 . ,%nil)) <) | |
249 | '(1 3 4 5 8))) | |
250 | ||
04bb321a NJ |
251 | ) |
252 | ||
253 | (with-test-prefix "value preservation" | |
254 | ||
255 | (pass-if "car" | |
256 | (eq? (car (cons %nil 'a)) %nil)) | |
257 | ||
258 | (pass-if "cdr" | |
259 | (eq? (cdr (cons 'a %nil)) %nil)) | |
260 | ||
261 | (pass-if "vector-ref" | |
262 | (eq? (vector-ref (vector %nil) 0) %nil)) | |
263 | ||
264 | ) | |
265 | ||
266 | )) | |
267 | ||
a64e6669 NJ |
268 | (if (defined? '%nil) |
269 | (use-modules (lang elisp interface))) | |
270 | ||
271 | (if (defined? '%nil) | |
272 | ||
273 | (with-test-prefix "elisp" | |
274 | ||
275 | (define (elisp-pass-if expr expected) | |
276 | (pass-if (with-output-to-string | |
277 | (lambda () | |
278 | (write expr))) | |
279 | (let ((calc (with-output-to-string | |
280 | (lambda () | |
281 | (write (eval-elisp expr)))))) | |
282 | (string=? calc expected)))) | |
283 | ||
ec5cb825 AW |
284 | (define (elisp-pass-if/maybe-error key expr expected) |
285 | (pass-if (with-output-to-string (lambda () (write expr))) | |
286 | (string=? | |
287 | (catch key | |
288 | (lambda () | |
289 | (with-output-to-string | |
290 | (lambda () (write (eval-elisp expr))))) | |
291 | (lambda (k . args) | |
292 | (format (current-error-port) | |
293 | "warning: caught ~a: ~a\n" k args) | |
294 | (throw 'unresolved))) | |
295 | expected))) | |
296 | ||
a64e6669 NJ |
297 | (elisp-pass-if '(and #f) "#f") |
298 | (elisp-pass-if '(and #t) "#t") | |
299 | (elisp-pass-if '(and nil) "#nil") | |
300 | (elisp-pass-if '(and t) "#t") | |
301 | (elisp-pass-if '(and) "#t") | |
302 | (elisp-pass-if '(cond (nil t) (t 3)) "3") | |
303 | (elisp-pass-if '(cond (nil t) (t)) "#t") | |
304 | (elisp-pass-if '(cond (nil)) "#nil") | |
305 | (elisp-pass-if '(cond) "#nil") | |
306 | (elisp-pass-if '(if #f 'a 'b) "b") | |
307 | (elisp-pass-if '(if #t 'a 'b) "a") | |
308 | (elisp-pass-if '(if '() 'a 'b) "b") | |
309 | (elisp-pass-if '(if nil 'a 'b) "b") | |
310 | (elisp-pass-if '(if nil 1 2 3 4) "4") | |
311 | (elisp-pass-if '(if nil 1 2) "2") | |
312 | (elisp-pass-if '(if nil 1) "#nil") | |
313 | (elisp-pass-if '(if t 1 2) "1") | |
314 | (elisp-pass-if '(if t 1) "1") | |
315 | (elisp-pass-if '(let (a) a) "#nil") | |
316 | (elisp-pass-if '(let* (a) a) "#nil") | |
317 | (elisp-pass-if '(let* ((a 1) (b (* a 2))) b) "2") | |
318 | (elisp-pass-if '(memq '() '(())) "(())") | |
319 | (elisp-pass-if '(memq '() '(nil)) "(#nil)") | |
320 | (elisp-pass-if '(memq '() '(t)) "#nil") | |
321 | (elisp-pass-if '(memq nil '(())) "(())") | |
322 | (elisp-pass-if '(memq nil '(nil)) "(#nil)") | |
323 | (elisp-pass-if '(memq nil (list nil)) "(#nil)") | |
324 | (elisp-pass-if '(null '#f) "#t") | |
325 | (elisp-pass-if '(null '()) "#t") | |
326 | (elisp-pass-if '(null 'nil) "#t") | |
327 | (elisp-pass-if '(null nil) "#t") | |
328 | (elisp-pass-if '(or 1 2 3) "1") | |
329 | (elisp-pass-if '(or nil t nil) "#t") | |
330 | (elisp-pass-if '(or nil) "#nil") | |
331 | (elisp-pass-if '(or t nil t) "#t") | |
332 | (elisp-pass-if '(or t) "#t") | |
333 | (elisp-pass-if '(or) "#nil") | |
334 | (elisp-pass-if '(prog1 1 2 3) "1") | |
335 | (elisp-pass-if '(prog2 1 2 3) "2") | |
336 | (elisp-pass-if '(progn 1 2 3) "3") | |
337 | (elisp-pass-if '(while nil 1) "#nil") | |
338 | ||
339 | (elisp-pass-if '(defun testf (x y &optional o &rest r) (list x y o r)) "testf") | |
340 | (elisp-pass-if '(testf 1 2) "(1 2 #nil #nil)") | |
341 | (elisp-pass-if '(testf 1 2 3 4 5 56) "(1 2 3 (4 5 56))") | |
342 | ;; NB `lambda' in Emacs is self-quoting, but that's only after | |
343 | ;; loading the macro definition of lambda in subr.el. | |
344 | (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))") | |
345 | (elisp-pass-if '(funcall (lambda (x y &optional o &rest r) (list x y o r)) 1 2 3 4) "(1 2 3 (4))") | |
a64e6669 | 346 | |
fb10a008 AW |
347 | (elisp-pass-if '(apply (lambda (x y &optional o &rest r) (list x y o r)) 1 2 3 nil) |
348 | "(1 2 3 #nil)") | |
ec5cb825 | 349 | |
a64e6669 NJ |
350 | (elisp-pass-if '(setq x 3) "3") |
351 | (elisp-pass-if '(defvar x 4) "x") | |
352 | (elisp-pass-if 'x "3") | |
353 | ||
354 | )) | |
355 | ||
c2521a21 | 356 | (set! %load-should-autocompile *old-%load-should-autocompile*) |
62f80361 AW |
357 | (debug-set! stack *old-stack-level*) |
358 | ||
04bb321a | 359 | ;;; elisp.test ends here |