2 ;; Copyright (c) 2002 by The XFree86 Project, Inc.
4 ;; Permission is hereby granted, free of charge, to any person obtaining a
5 ;; copy of this software and associated documentation files (the "Software"),
6 ;; to deal in the Software without restriction, including without limitation
7 ;; the rights to use, copy, modify, merge, publish, distribute, sublicense,
8 ;; and/or sell copies of the Software, and to permit persons to whom the
9 ;; Software is furnished to do so, subject to the following conditions:
11 ;; The above copyright notice and this permission notice shall be included in
12 ;; all copies or substantial portions of the Software.
14 ;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
15 ;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
16 ;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL
17 ;; THE XFREE86 PROJECT BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
18 ;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF
19 ;; OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
22 ;; Except as contained in this notice, the name of the XFree86 Project shall
23 ;; not be used in advertising or otherwise to promote the sale, use or other
24 ;; dealings in this Software without prior written authorization from the
27 ;; Author: Paulo César Pereira de Andrade
30 ;; $XFree86: xc/programs/xedit/lisp/test/list.lsp,v 1.5 2002/11/26 04:06:30 paulo Exp $
33 ;; basic lisp function tests
35 ;; Most of the tests are just the examples from the
37 ;; Common Lisp HyperSpec (TM)
38 ;; Copyright 1996-2001, Xanalys Inc. All rights reserved.
40 ;; Some tests are hand crafted, to test how the interpreter treats
41 ;; uncommon arguments or special conditions
47 o NIL and T should be always treated as symbols, actually it is
48 legal to say (defun nil (...) ...)
49 o There aren't true uninterned symbols, there are only symbols that
50 did not yet establish the home package, but once one is created, an
51 interned symbol is always returned.
54 (defun compare-test (test expect function arguments
55 &aux result (error t) unused error-value)
59 (setq result (apply function arguments))
64 (format t "ERROR: (~S~{ ~S~}) => ~S~%" function arguments error-value)
65 (or (funcall test result expect)
66 (format t "(~S~{ ~S~}) => should be ~S not ~S~%"
67 function arguments expect result
73 (defun compare-eval (test expect form
74 &aux result (error t) unused error-value)
78 (setq result (eval form))
83 (format t "ERROR: ~S => ~S~%" form error-value)
84 (or (funcall test result expect)
85 (format t "~S => should be ~S not ~S~%"
92 (defun error-test (function &rest arguments &aux result (error t))
94 (setq result (apply function arguments))
98 (format t "ERROR: no error for (~S~{ ~S~}), result was ~S~%"
99 function arguments result)
103 (defun error-eval (form &aux result (error t))
105 (setq result (eval form))
109 (format t "ERROR: no error for ~S, result was ~S~%" form result)
113 (defun eq-test (expect function &rest arguments)
114 (compare-test #'eq expect function arguments))
116 (defun eql-test (expect function &rest arguments)
117 (compare-test #'eql expect function arguments))
119 (defun equal-test (expect function &rest arguments)
120 (compare-test #'equal expect function arguments))
122 (defun equalp-test (expect function &rest arguments)
123 (compare-test #'equalp expect function arguments))
126 (defun eq-eval (expect form)
127 (compare-eval #'eq expect form))
129 (defun eql-eval (expect form)
130 (compare-eval #'eql expect form))
132 (defun equal-eval (expect form)
133 (compare-eval #'equal expect form))
135 (defun equalp-eval (expect form)
136 (compare-eval #'equalp expect form))
138 ;; clisp treats strings loaded from a file as constants
139 (defun xseq (sequence)
140 #+clisp (if *load-pathname* (copy-seq sequence) sequence)
145 (equal-test '((+ 2 3) . 4) #'apply 'cons '((+ 2 3) 4))
146 (eql-test -1 #'apply #'- '(1 2))
147 (eql-test 7 #'apply #'max 3 5 '(2 7 3))
148 (error-test #'apply #'+ 1)
149 (error-test #'apply #'+ 1 2)
150 (error-test #'apply #'+ 1 . 2)
151 (error-test #'apply #'+ 1 2 3)
152 (error-test #'apply #'+ 1 2 . 3)
153 (eql-test 6 #'apply #'+ 1 2 3 ())
156 (eq-eval t '(let* ((a #\a) (b a)) (eq a b)))
157 (eq-test t #'eq 'a 'a)
158 (eq-test nil #'eq 'a 'b)
159 (eq-eval t '(eq #1=1 #1#))
160 (eq-test nil #'eq "abc" "abc")
161 (setq a '('x #c(1 2) #\z))
162 (eq-test nil #'eq a (copy-seq a))
165 (eq-test t #'eql 1 1)
166 (eq-test t #'eql 1.3d0 1.3d0)
167 (eq-test nil #'eql 1 1d0)
168 (eq-test t #'eql #c(1 -5) #c(1 -5))
169 (eq-test t #'eql 'a 'a)
170 (eq-test nil #'eql :a 'a)
171 (eq-test t #'eql #c(5d0 0) 5d0)
172 (eq-test nil #'eql #c(5d0 0d0) 5d0)
173 (eq-test nil #'eql "abc" "abc")
174 (equal-eval '(1 5/6 #p"test" #\#) '(setq a '(1 5/6 #p"test" #\#)))
175 (eq-test nil #'eql a (copy-seq a))
178 hash0 (make-hash-table)
179 hash1 (make-hash-table)
182 (gethash :foo hash0) :bar
183 (gethash :foo hash1) :bar
185 (defstruct test a b c)
187 struc0 (make-test :a 1 :b 2 :c #\c)
188 struc1 (make-test :a 1 :b 2 :c #\c)
192 (eq-test t #'equal "abc" "abc")
193 (eq-test t #'equal 1 1)
194 (eq-test t #'equal #c(1 2) #c(1 2))
195 (eq-test nil #'equal #c(1 2) #c(1 2d0))
196 (eq-test t #'equal #\A #\A)
197 (eq-test nil #'equal #\A #\a)
198 (eq-test nil #'equal "abc" "Abc")
199 (equal-eval '(1 2 3/5 #\a) '(setq a '(1 2 3/5 #\a)))
200 (eq-test t #'equal a (copy-seq a))
201 (eq-test nil #'equal hash0 hash1)
202 (eq-test nil #'equal struc0 struc1)
203 (eq-test nil #'equal #(1 2 3 4) #(1 2 3 4))
206 (eq-test t #'equalp hash0 hash1)
208 (gethash 2 hash0) "FoObAr"
209 (gethash 2 hash1) "fOoBaR"
211 (eq-test t #'equalp hash0 hash1)
214 (gethash 3d0 hash1) 3
216 (eq-test nil #'equalp hash0 hash1)
217 (eq-test t #'equalp struc0 struc1)
222 (eq-test t #'equalp struc0 struc1)
224 (test-b struc0) 'test
225 (test-b struc1) :test
227 (eq-test nil #'equalp struc0 struc1)
228 (eq-test t #'equalp #c(1/2 1d0) #c(0.5d0 1))
229 (eq-test t #'equalp 1 1d0)
230 (eq-test t #'equalp #(1 2 3 4) #(1 2 3 4))
231 (eq-test t #'equalp #(1 #\a 3 4d0) #(1 #\A 3 4))
234 (equal-test '((1 . "one")) #'acons 1 "one" nil)
235 (equal-test '((2 . "two") (1 . "one")) #'acons 2 "two" '((1 . "one")))
238 (equal-test '(nil) #'adjoin nil nil)
239 (equal-test '(a) #'adjoin 'a nil)
240 (equal-test '(1 2 3) #'adjoin 1 '(1 2 3))
241 (equal-test '(1 2 3) #'adjoin 2 '(1 2 3))
242 (equal-test '((1) (1) (2) (3)) #'adjoin '(1) '((1) (2) (3)))
243 (equal-test '((1) (2) (3)) #'adjoin '(1) '((1) (2) (3)) :key #'car)
244 (error-test #'adjoin nil 1)
246 ;; alpha-char-p - function
247 (eq-test t #'alpha-char-p #\a)
248 (eq-test nil #'alpha-char-p #\5)
249 (error-test #'alpha-char-p 'a)
251 ;; alphanumericp - function
252 (eq-test t #'alphanumericp #\Z)
253 (eq-test t #'alphanumericp #\8)
254 (eq-test nil #'alphanumericp #\#)
257 (eql-eval 1 '(setq temp1 1 temp2 1 temp3 1))
258 (eql-eval 2 '(and (incf temp1) (incf temp2) (incf temp3)))
259 (eq-eval t '(and (eql 2 temp1) (eql 2 temp2) (eql 2 temp3)))
260 (eql-eval 1 '(decf temp3))
261 (eq-eval nil '(and (decf temp1) (decf temp2) (eq temp3 'nil) (decf temp3)))
262 (eq-eval t '(and (eql temp1 temp2) (eql temp2 temp3)))
264 (equal-eval '(1 2 3) '(multiple-value-list (and (values 'a) (values 1 2 3))))
265 (equal-eval nil '(and (values) t))
268 (equal-test '(a b c d e f g) #'append '(a b c) '(d e f) '() '(g))
269 (equal-test '(a b c . d) #'append '(a b c) 'd)
270 (eq-test nil #'append)
271 (eql-test 'a #'append nil 'a)
272 (error-test #'append 1 2)
275 (equal-test '(1 . "one") #'assoc 1 '((2 . "two") (1 . "one")))
276 (equal-test '(2 . "two") #'assoc 2 '((1 . "one") (2 . "two")))
277 (eq-test nil #'assoc 1 nil)
278 (equal-test '(2 . "two") #'assoc-if #'evenp '((1 . "one") (2 . "two")))
279 (equal-test '(3 . "three") #'assoc-if-not #'(lambda(x) (< x 3))
280 '((1 . "one") (2 . "two") (3 . "three")))
281 (equal-test '("two" . 2) #'assoc #\o '(("one" . 1) ("two" . 2) ("three" . 3))
282 :key #'(lambda (x) (char x 2)))
283 (equal-test '(a . b) #'assoc 'a '((x . a) (y . b) (a . b) (a . c)))
287 (eq-test t #'atom '())
288 (eq-test nil #'atom '(1))
289 (eq-test t #'atom 'a)
291 ;; block - special operator
292 (eq-eval nil '(block empty))
293 (eql-eval 2 '(let ((x 1))
294 (block stop (setq x 2) (return-from stop) (setq x 3)) x))
295 (eql-eval 2 '(block twin (block twin (return-from twin 1)) 2))
297 ;; both-case-p - function
298 (eq-test t #'both-case-p #\a)
299 (eq-test nil #'both-case-p #\1)
302 (eql-eval 1 '(setq x 1))
303 (eq-test t #'boundp 'x)
305 (eq-test nil #'boundp 'x)
306 (eq-eval nil '(let ((x 1)) (boundp 'x)))
307 (error-test #'boundp 1)
309 ;; butlast, nbutlast - function
310 (setq x '(1 2 3 4 5 6 7 8 9))
311 (equal-test '(1 2 3 4 5 6 7 8) #'butlast x)
312 (equal-eval '(1 2 3 4 5 6 7 8 9) 'x)
313 (eq-eval nil '(nbutlast x 9))
314 (equal-test '(1) #'nbutlast x 8)
316 (eq-test nil #'butlast nil)
317 (eq-test nil #'nbutlast '())
318 (error-test #'butlast 1 2)
319 (error-test #'butlast -1 '(1 2))
321 ;; car, cdr, caar ... - function
322 (eql-test 1 #'car '(1 2))
323 (eql-test 2 #'cdr '(1 . 2))
324 (eql-test 1 #'caar '((1 2)))
325 (eql-test 2 #'cadr '(1 2))
326 (eql-test 2 #'cdar '((1 . 2)))
327 (eql-test 3 #'cddr '(1 2 . 3))
328 (eql-test 1 #'caaar '(((1 2))))
329 (eql-test 2 #'caadr '(1 (2 3)))
330 (eql-test 2 #'cadar '((1 2) 2 3))
331 (eql-test 3 #'caddr '(1 2 3 4))
332 (eql-test 2 #'cdaar '(((1 . 2)) 3))
333 (eql-test 3 #'cdadr '(1 (2 . 3) 4))
334 (eql-test 3 #'cddar '((1 2 . 3) 3))
335 (eql-test 4 #'cdddr '(1 2 3 . 4))
336 (eql-test 1 #'caaaar '((((1 2)))))
337 (eql-test 2 #'caaadr '(1 ((2))))
338 (eql-test 2 #'caadar '((1 (2)) 3))
339 (eql-test 3 #'caaddr '(1 2 (3 4)))
340 (eql-test 2 #'cadaar '(((1 2)) 3))
341 (eql-test 3 #'cadadr '(1 (2 3) 4))
342 (eql-test 3 #'caddar '((1 2 3) 4))
343 (eql-test 4 #'cadddr '(1 2 3 4 5))
344 (eql-test 2 #'cdaaar '((((1 . 2))) 3))
345 (eql-test 3 #'cdaadr '(1 ((2 . 3)) 4))
346 (eql-test 3 #'cdadar '((1 (2 . 3)) 4))
347 (eql-test 4 #'cdaddr '(1 2 (3 . 4) 5))
348 (eql-test 3 #'cddaar '(((1 2 . 3)) 4))
349 (eql-test 4 #'cddadr '(1 (2 3 . 4) 5))
350 (eql-test 4 #'cdddar '((1 2 3 . 4) 5))
351 (eql-test 5 #'cddddr '(1 2 3 4 . 5))
353 ;; first ... tenth, rest - function
354 (eql-test 2 #'rest '(1 . 2))
355 (eql-test 1 #'first '(1 2))
356 (eql-test 2 #'second '(1 2 3))
357 (eql-test 2 #'second '(1 2 3))
358 (eql-test 3 #'third '(1 2 3 4))
359 (eql-test 4 #'fourth '(1 2 3 4 5))
360 (eql-test 5 #'fifth '(1 2 3 4 5 6))
361 (eql-test 6 #'sixth '(1 2 3 4 5 6 7))
362 (eql-test 7 #'seventh '(1 2 3 4 5 6 7 8))
363 (eql-test 8 #'eighth '(1 2 3 4 5 6 7 8 9))
364 (eql-test 9 #'ninth '(1 2 3 4 5 6 7 8 9 10))
365 (eql-test 10 #'tenth '(1 2 3 4 5 6 7 8 9 10 11))
367 (error-test #'car #c(1 2))
368 (error-test #'car #(1 2))
371 (eql-eval t '(let ((a 1)) (case a ((4 5 6) nil) ((3 2 1) t) (otherwise :error))))
372 (eql-eval t '(let ((a 1)) (case a ((3 2) nil) (1 t) (t :error))))
373 (error-eval '(let ((a 1)) (case a (2 :error) (t nil) (otherwise t))))
374 (error-eval '(let ((a 1)) (case a (2 :error) (otherwise t) (t nil))))
376 ;; catch - special operator
377 (eql-eval 3 '(catch 'dummy-tag 1 2 (throw 'dummy-tag 3) 4))
378 (eql-eval 4 '(catch 'dummy-tag 1 2 3 4))
379 (eq-eval 'throw-back '(defun throw-back (tag) (throw tag t)))
380 (eq-eval t '(catch 'dummy-tag (throw-back 'dummy-tag) 2))
383 (eql-test #\a #'char "abc" 0)
384 (eql-test #\b #'char "abc" 1)
385 (error-test #'char "abc" 3)
388 (eq-test nil #'alpha-char-p #\3)
389 (eq-test t #'alpha-char-p #\y)
390 (eql-test #\a #'char-downcase #\a)
391 (eql-test #\a #'char-downcase #\a)
392 (eql-test #\1 #'char-downcase #\1)
393 (error-test #'char-downcase 1)
394 (eql-test #\A #'char-upcase #\a)
395 (eql-test #\A #'char-upcase #\A)
396 (eql-test #\1 #'char-upcase #\1)
397 (error-test #'char-upcase 1)
398 (eq-test t #'lower-case-p #\a)
399 (eq-test nil #'lower-case-p #\A)
400 (eq-test t #'upper-case-p #\W)
401 (eq-test nil #'upper-case-p #\w)
402 (eq-test t #'both-case-p #\x)
403 (eq-test nil #'both-case-p #\%)
404 (eq-test t #'char= #\d #\d)
405 (eq-test t #'char-equal #\d #\d)
406 (eq-test nil #'char= #\A #\a)
407 (eq-test t #'char-equal #\A #\a)
408 (eq-test nil #'char= #\d #\x)
409 (eq-test nil #'char-equal #\d #\x)
410 (eq-test nil #'char= #\d #\D)
411 (eq-test t #'char-equal #\d #\D)
412 (eq-test nil #'char/= #\d #\d)
413 (eq-test nil #'char-not-equal #\d #\d)
414 (eq-test nil #'char/= #\d #\d)
415 (eq-test nil #'char-not-equal #\d #\d)
416 (eq-test t #'char/= #\d #\x)
417 (eq-test t #'char-not-equal #\d #\x)
418 (eq-test t #'char/= #\d #\D)
419 (eq-test nil #'char-not-equal #\d #\D)
420 (eq-test t #'char= #\d #\d #\d #\d)
421 (eq-test t #'char-equal #\d #\d #\d #\d)
422 (eq-test nil #'char= #\d #\D #\d #\d)
423 (eq-test t #'char-equal #\d #\D #\d #\d)
424 (eq-test nil #'char/= #\d #\d #\d #\d)
425 (eq-test nil #'char-not-equal #\d #\d #\d #\d)
426 (eq-test nil #'char/= #\d #\d #\D #\d)
427 (eq-test nil #'char-not-equal #\d #\d #\D #\d)
428 (eq-test nil #'char= #\d #\d #\x #\d)
429 (eq-test nil #'char-equal #\d #\d #\x #\d)
430 (eq-test nil #'char/= #\d #\d #\x #\d)
431 (eq-test nil #'char-not-equal #\d #\d #\x #\d)
432 (eq-test nil #'char= #\d #\y #\x #\c)
433 (eq-test nil #'char-equal #\d #\y #\x #\c)
434 (eq-test t #'char/= #\d #\y #\x #\c)
435 (eq-test t #'char-not-equal #\d #\y #\x #\c)
436 (eq-test nil #'char= #\d #\c #\d)
437 (eq-test nil #'char-equal #\d #\c #\d)
438 (eq-test nil #'char/= #\d #\c #\d)
439 (eq-test nil #'char-not-equal #\d #\c #\d)
440 (eq-test t #'char< #\d #\x)
441 (eq-test t #'char-lessp #\d #\x)
442 (eq-test t #'char-lessp #\d #\X)
443 (eq-test t #'char-lessp #\D #\x)
444 (eq-test t #'char-lessp #\D #\X)
445 (eq-test t #'char<= #\d #\x)
446 (eq-test t #'char-not-greaterp #\d #\x)
447 (eq-test t #'char-not-greaterp #\d #\X)
448 (eq-test t #'char-not-greaterp #\D #\x)
449 (eq-test t #'char-not-greaterp #\D #\X)
450 (eq-test nil #'char< #\d #\d)
451 (eq-test nil #'char-lessp #\d #\d)
452 (eq-test nil #'char-lessp #\d #\D)
453 (eq-test nil #'char-lessp #\D #\d)
454 (eq-test nil #'char-lessp #\D #\D)
455 (eq-test t #'char<= #\d #\d)
456 (eq-test t #'char-not-greaterp #\d #\d)
457 (eq-test t #'char-not-greaterp #\d #\D)
458 (eq-test t #'char-not-greaterp #\D #\d)
459 (eq-test t #'char-not-greaterp #\D #\D)
460 (eq-test t #'char< #\a #\e #\y #\z)
461 (eq-test t #'char-lessp #\a #\e #\y #\z)
462 (eq-test t #'char-lessp #\a #\e #\y #\Z)
463 (eq-test t #'char-lessp #\a #\E #\y #\z)
464 (eq-test t #'char-lessp #\A #\e #\y #\Z)
465 (eq-test t #'char<= #\a #\e #\y #\z)
466 (eq-test t #'char-not-greaterp #\a #\e #\y #\z)
467 (eq-test t #'char-not-greaterp #\a #\e #\y #\Z)
468 (eq-test t #'char-not-greaterp #\A #\e #\y #\z)
469 (eq-test nil #'char< #\a #\e #\e #\y)
470 (eq-test nil #'char-lessp #\a #\e #\e #\y)
471 (eq-test nil #'char-lessp #\a #\e #\E #\y)
472 (eq-test nil #'char-lessp #\A #\e #\E #\y)
473 (eq-test t #'char<= #\a #\e #\e #\y)
474 (eq-test t #'char-not-greaterp #\a #\e #\e #\y)
475 (eq-test t #'char-not-greaterp #\a #\E #\e #\y)
476 (eq-test t #'char> #\e #\d)
477 (eq-test t #'char-greaterp #\e #\d)
478 (eq-test t #'char-greaterp #\e #\D)
479 (eq-test t #'char-greaterp #\E #\d)
480 (eq-test t #'char-greaterp #\E #\D)
481 (eq-test t #'char>= #\e #\d)
482 (eq-test t #'char-not-lessp #\e #\d)
483 (eq-test t #'char-not-lessp #\e #\D)
484 (eq-test t #'char-not-lessp #\E #\d)
485 (eq-test t #'char-not-lessp #\E #\D)
486 (eq-test t #'char> #\d #\c #\b #\a)
487 (eq-test t #'char-greaterp #\d #\c #\b #\a)
488 (eq-test t #'char-greaterp #\d #\c #\b #\A)
489 (eq-test t #'char-greaterp #\d #\c #\B #\a)
490 (eq-test t #'char-greaterp #\d #\C #\b #\a)
491 (eq-test t #'char-greaterp #\D #\C #\b #\a)
492 (eq-test t #'char>= #\d #\c #\b #\a)
493 (eq-test t #'char-not-lessp #\d #\c #\b #\a)
494 (eq-test t #'char-not-lessp #\d #\c #\b #\A)
495 (eq-test t #'char-not-lessp #\D #\c #\b #\a)
496 (eq-test t #'char-not-lessp #\d #\C #\B #\a)
497 (eq-test nil #'char> #\d #\d #\c #\a)
498 (eq-test nil #'char-greaterp #\d #\d #\c #\a)
499 (eq-test nil #'char-greaterp #\d #\d #\c #\A)
500 (eq-test nil #'char-greaterp #\d #\D #\c #\a)
501 (eq-test nil #'char-greaterp #\d #\D #\C #\a)
502 (eq-test t #'char>= #\d #\d #\c #\a)
503 (eq-test t #'char-not-lessp #\d #\d #\c #\a)
504 (eq-test t #'char-not-lessp #\d #\D #\c #\a)
505 (eq-test t #'char-not-lessp #\D #\d #\c #\a)
506 (eq-test t #'char-not-lessp #\D #\D #\c #\A)
507 (eq-test nil #'char> #\e #\d #\b #\c #\a)
508 (eq-test nil #'char-greaterp #\e #\d #\b #\c #\a)
509 (eq-test nil #'char-greaterp #\E #\d #\b #\c #\a)
510 (eq-test nil #'char-greaterp #\e #\D #\b #\c #\a)
511 (eq-test nil #'char-greaterp #\E #\d #\B #\c #\A)
512 (eq-test nil #'char>= #\e #\d #\b #\c #\a)
513 (eq-test nil #'char-not-lessp #\e #\d #\b #\c #\a)
514 (eq-test nil #'char-not-lessp #\e #\d #\b #\c #\A)
515 (eq-test nil #'char-not-lessp #\E #\d #\B #\c #\a)
517 ;; char-code - function
519 (eql-test 49 #'char-code #\1)
520 (eql-test 90 #'char-code #\Z)
521 (eql-test 127 #'char-code #\Delete)
522 (eql-test 27 #'char-code #\Escape)
523 (eql-test 13 #'char-code #\Return)
524 (eql-test 0 #'char-code #\Null)
525 (eql-test 10 #'char-code #\Newline)
526 (error-test #'char-code 65)
528 ;; character - function
529 (eql-test #\a #'character #\a)
530 (eql-test #\a #'character "a")
531 (eql-test #\A #'character 'a)
533 ;; XXX assumes ASCII, and should be allowed to fail?
534 (eql-test #\A #'character 65)
536 (error-test #'character 1/2)
537 (error-test #'character "abc")
538 (error-test #'character :test)
539 (eq-test #\T #'character t)
540 (error-test #'character nil)
542 ;; characterp - function
543 (eq-test t #'characterp #\a)
544 (eq-test nil #'characterp 1)
545 (eq-test nil #'characterp 1/2)
546 (eq-test nil #'characterp 'a)
547 (eq-test nil #'characterp '`a)
558 (eql-eval 2 '(let ((a 1)) (cond ((= a 2) 1) ((= a 1) 2) ((= a 0) 1) (t nil))))
559 (eql-eval nil '(let ((a 1)) (cond ((= a 2) 1) (t nil) ((= a 1) 2) ((= a 0) 1))))
561 ;; consp - function (predicate)
562 (eq-test t #'consp '(1 2))
563 (eq-test t #'consp '(1 . 2))
564 (eq-test nil #'consp nil)
565 (eq-test nil #'consp 1)
567 ;; constantp - function (predicate)
568 (eq-test t #'constantp 1)
569 (eq-test t #'constantp #\x)
570 (eq-test t #'constantp :test)
571 (eq-test nil #'constantp 'test)
572 (eq-test t #'constantp ''1)
573 (eq-test t #'constantp '(quote 1))
574 (eq-test t #'constantp "string")
575 (eq-test t #'constantp #c(1 2))
576 (eq-test t #'constantp #(1 2))
577 (eq-test nil #'constantp #p"test")
578 (eq-test nil #'constantp '(1 2))
579 (eq-test nil #'constantp (make-hash-table))
580 (eq-test nil #'constantp *package*)
581 (eq-test nil #'constantp *standard-input*)
583 ;; copy-list, copy-alist and copy-tree - function
584 (equal-test '(1 2) #'copy-list '(1 2))
585 (equal-test '(1 . 2) #'copy-list '(1 . 2))
586 (eq-test nil #'copy-list nil)
587 (error-test #'copy-list 1)
588 (equal-eval '(1 (2 3)) '(setq x '(1 (2 3))))
589 (equal-eval x '(setq y (copy-list x)))
590 (equal-test '("one" (2 3)) #'rplaca x "one")
592 (equal-test '("two" 3) #'rplaca (cadr x) "two")
593 (eq-test (caadr x) #'caadr y)
594 (equal-eval '(1 (2 3) 4) '(setq a '(1 (2 3) 4) b (copy-list a)))
595 (eq-eval t '(eq (cadr a) (cadr b)))
596 (eq-eval t '(eq (car a) (car b)))
597 (setq a '(1 (2 3) 4) b (copy-alist a))
598 (eq-eval nil '(eq (cadr a) (cadr b)))
599 (eq-eval t '(eq (car a) (car b)))
600 (eq-test nil #'copy-alist nil)
601 (eq-test nil #'copy-list nil)
602 (error-test #'copy-list 1)
603 (setq a '(1 (2 (3))))
604 (setq as-list (copy-list a))
605 (setq as-alist (copy-alist a))
606 (setq as-tree (copy-tree a))
607 (eq-eval t '(eq (cadadr a) (cadadr as-list)))
608 (eq-eval t '(eq (cadadr a) (cadadr as-alist)))
609 (eq-eval nil '(eq (cadadr a) (cadadr as-tree)))
613 (eql-eval 1 '(decf n))
616 (eql-eval -2147483649 '(decf n))
617 (eql-eval -2147483649 'n)
619 (eql-eval -0.5d0 '(decf n 0.5d0))
622 (eql-eval 1/2 '(decf n 1/2))
625 ;; delete and remove - function
626 (setq a '(1 3 4 5 9) b a)
627 (equal-test '(1 3 5 9) #'remove 4 a)
628 (eq-eval t '(eq a b))
629 (setq a (delete 4 a))
630 (equal-eval '(1 3 5 9) 'a)
631 (setq a '(1 2 4 1 3 4 5) b a)
632 (equal-test '(1 2 1 3 5) #'remove 4 a)
633 (eq-eval t '(eq a b))
634 (equal-test '(1 2 1 3 4 5) #'remove 4 a :count 1)
635 (eq-eval t '(eq a b))
636 (equal-test '(1 2 4 1 3 5) #'remove 4 a :count 1 :from-end t)
637 (eq-eval t '(eq a b))
638 (equal-test '(4 3 4 5) #'remove 3 a :test #'>)
639 (eq-eval t '(eq a b))
640 (setq a (delete 4 '(1 2 4 1 3 4 5)))
641 (equal-eval '(1 2 1 3 5) 'a)
642 (setq a (delete 4 '(1 2 4 1 3 4 5) :count 1))
643 (equal-eval '(1 2 1 3 4 5) 'a)
644 (setq a (delete 4 '(1 2 4 1 3 4 5) :count 1 :from-end t))
645 (equal-eval '(1 2 4 1 3 5) 'a)
646 (equal-test "abc" #'delete-if #'digit-char-p "a1b2c3")
647 (equal-test "123" #'delete-if-not #'digit-char-p "a1b2c3")
648 (eq-test nil #'delete 1 nil)
649 (eq-test nil #'remove 1 nil)
650 (setq a '(1 2 3 4 :test 5 6 7 8) b a)
651 (equal-test '(1 2 :test 7 8) #'remove-if #'numberp a :start 2 :end 7)
652 (eq-eval t '(eq a b))
653 (setq a (delete-if #'numberp a :start 2 :end 7))
654 (equal-eval '(1 2 :test 7 8) 'a)
656 ;; digit-char - function
657 (eql-test #\0 #'digit-char 0)
658 (eql-test #\A #'digit-char 10 11)
659 (eq-test nil #'digit-char 10 10)
660 (eql-test 35 #'digit-char-p #\z 36)
661 (error-test #'digit-char #\a)
662 (error-test #'digit-char-p 1/2)
666 ;; TODO directory (known to have problems with parameters like "../*/../*/")
671 (eql-test #\a #'elt "xabc" 1)
672 (eql-test 3 #'elt '(0 1 2 3) 3)
673 (error-test #'elt nil 0)
676 (eql-test t #'endp nil)
677 (error-test #'endp t)
678 (eql-test nil #'endp '(1 . 2))
679 (error-test #'endp #(1 2))
682 (eql-test t #'every 'not-used ())
683 (eql-test t #'every #'characterp "abc")
684 (eql-test nil #'every #'< '(1 2 3) '(4 5 6) #(7 8 -1))
685 (eql-test t #'every #'< '(1 2 3) '(4 5 6) #(7 8))
687 ;; fboundp and fmakunbound - function
688 (eq-test t #'fboundp 'car)
689 (eq-eval 'test '(defun test ()))
690 (eq-test t #'fboundp 'test)
691 (eq-test 'test #'fmakunbound 'test)
692 (eq-test nil #'fboundp 'test)
693 (eq-eval 'test '(defmacro test (x) x))
694 (eq-test t #'fboundp 'test)
695 (eq-test 'test #'fmakunbound 'test)
698 (setq x (list 1 2 3 4))
699 (equal-test '((4 4 4 4) (4 4 4 4) (4 4 4 4) (4 4 4 4)) #'fill x '(4 4 4 4))
700 (eq-eval t '(eq (car x) (cadr x)))
701 (equalp-test '#(a z z d e) #'fill '#(a b c d e) 'z :start 1 :end 3)
702 (equal-test "012ee" #'fill (xseq "01234") #\e :start 3)
703 (error-test #'fill 1 #\a)
706 (eql-test #\Space #'find #\d "here are some letters that can be looked at" :test #'char>)
707 (eql-test 3 #'find-if #'oddp '(1 2 3 4 5) :end 3 :from-end t)
708 (eq-test nil #'find-if-not #'complexp '#(3.5 2 #C(1.0 0.0) #C(0.0 1.0)) :start 2)
709 (eq-test nil #'find 1 "abc")
710 (error-test #'find 1 #c(1 2))
712 ;; find-symbol - function
713 (equal-eval '(nil nil)
714 '(multiple-value-list (find-symbol "NEVER-BEFORE-USED")))
715 (equal-eval '(nil nil)
716 '(multiple-value-list (find-symbol "NEVER-BEFORE-USED")))
717 (setq test (multiple-value-list (intern "NEVER-BEFORE-USED")))
718 (equal-eval test '(read-from-string "(never-before-used nil)"))
719 (equal-eval '(never-before-used :internal)
720 '(multiple-value-list (intern "NEVER-BEFORE-USED")))
721 (equal-eval '(never-before-used :internal)
722 '(multiple-value-list (find-symbol "NEVER-BEFORE-USED")))
723 (equal-eval '(nil nil)
724 '(multiple-value-list (find-symbol "never-before-used")))
725 (equal-eval '(car :inherited)
726 '(multiple-value-list (find-symbol "CAR" 'common-lisp-user)))
727 (equal-eval '(car :external)
728 '(multiple-value-list (find-symbol "CAR" 'common-lisp)))
729 ;; XXX these will generate wrong results, NIL is not really a symbol
730 ;; currently in the interpreter
731 (equal-eval '(nil :inherited)
732 '(multiple-value-list (find-symbol "NIL" 'common-lisp-user)))
733 (equal-eval '(nil :external)
734 '(multiple-value-list (find-symbol "NIL" 'common-lisp)))
735 (setq test (multiple-value-list
736 (find-symbol "NIL" (prog1 (make-package "JUST-TESTING" :use '())
737 (intern "NIL" "JUST-TESTING")))))
738 (equal-eval (read-from-string "(just-testing::nil :internal)") 'test)
739 (eq-eval t '(export 'just-testing::nil 'just-testing))
740 (equal-eval '(just-testing:nil :external)
741 '(multiple-value-list (find-symbol "NIL" 'just-testing)))
743 #+xedit (equal-eval '(nil nil)
744 '(multiple-value-list (find-symbol "NIL" "KEYWORD")))
746 ;; optional result of previous form:
747 (equal-eval '(:nil :external)
748 '(multiple-value-list (find-symbol "NIL" "KEYWORD")))
753 ;; funcall - function
754 (eql-test 6 #'funcall #'+ 1 2 3)
755 (eql-test 1 #'funcall #'car '(1 2 3))
756 (equal-test '(1 2 3) #'funcall #'list 1 2 3)
760 ;; TODO properly implement ``function''
764 ;; functionp - function (predicate)
765 (eq-test nil #'functionp 'append)
766 (eq-test t #'functionp #'append)
767 (eq-test nil #'functionp '(lambda (x) (* x x)))
768 (eq-test t #'functionp #'(lambda (x) (* x x)))
769 (eq-test t #'functionp (symbol-function 'append))
770 (eq-test nil #'functionp 1)
771 (eq-test nil #'functionp nil)
775 (eq-test nil #'symbol-package sym1)
776 (setq sym1 (gensym 100))
777 (setq sym2 (gensym 100))
778 (eq-test nil #'eq sym1 sym2)
779 (eq-test nil #'equalp (gensym) (gensym))
782 (defun make-person (first-name last-name)
783 (let ((person (gensym "PERSON")))
784 (setf (get person 'first-name) first-name)
785 (setf (get person 'last-name) last-name)
787 (eq-eval '*john* '(defvar *john* (make-person "John" "Dow")))
788 (eq-eval '*sally* '(defvar *sally* (make-person "Sally" "Jones")))
789 (equal-eval "John" '(get *john* 'first-name))
790 (equal-eval "Jones" '(get *sally* 'last-name))
791 (defun marry (man woman married-name)
792 (setf (get man 'wife) woman)
793 (setf (get woman 'husband) man)
794 (setf (get man 'last-name) married-name)
795 (setf (get woman 'last-name) married-name)
797 (equal-eval "Dow-Jones" '(marry *john* *sally* "Dow-Jones"))
798 (equal-eval "Dow-Jones" '(get *john* 'last-name))
799 (equal-eval "Sally" '(get (get *john* 'wife) 'first-name))
800 (equal-eval `(wife ,*sally* last-name "Dow-Jones" first-name "John")
801 '(symbol-plist *john*))
803 '(defmacro age (person &optional (default ''thirty-something))
804 `(get ,person 'age ,default)))
805 (eq-eval 'thirty-something '(age *john*))
806 (eql-eval 20 '(age *john* 20))
807 (eql-eval 25 '(setf (age *john*) 25))
808 (eql-eval 25 '(age *john*))
809 (eql-eval 25 '(age *john* 20))
811 ;; graphic-char-p - function
812 (eq-test t #'graphic-char-p #\a)
813 (eq-test t #'graphic-char-p #\Space)
814 (eq-test nil #'graphic-char-p #\Newline)
815 (eq-test nil #'graphic-char-p #\Tab)
816 (eq-test nil #'graphic-char-p #\Rubout)
818 ;; if - special operator
819 (eq-eval nil '(if nil t))
820 (eq-eval nil '(if t nil t))
821 (eq-eval nil '(if nil t nil))
822 (eq-eval nil '(if nil t (if nil (if nil t) nil)))
826 (eql-eval 2 '(incf n))
829 (eql-eval 2147483648 '(incf n))
830 (eql-eval 2147483648 'n)
832 (eql-eval 0.5d0 '(incf n 0.5d0))
835 (eql-eval 3/2 '(incf n 1/2))
838 ;; intersection - function
839 (setq list1 (list 1 1 2 3 4 'a 'b 'c "A" "B" "C" "d")
840 list2 (list 1 4 5 'b 'c 'd "a" "B" "c" "D"))
841 (equal-test '(1 1 4 b c) #'intersection list1 list2)
842 (equal-test '(1 1 4 b c "B") #'intersection list1 list2 :test 'equal)
843 (equal-test '(1 1 4 b c "A" "B" "C" "d")
844 #'intersection list1 list2 :test #'equalp)
845 (setq list1 (nintersection list1 list2))
846 (equal-eval '(1 1 4 b c) 'list1)
847 (setq list1 (copy-list '((1 . 2) (2 . 3) (3 . 4) (4 . 5))))
848 (setq list2 (copy-list '((1 . 3) (2 . 4) (3 . 6) (4 . 8))))
849 (equal-test '((2 . 3) (3 . 4)) #'nintersection list1 list2 :key #'cdr)
851 ;; keywordp - function (predicate)
852 (eq-test t #'keywordp :test)
853 (eq-test nil #'keywordp 'test)
854 (eq-test nil #'keywordp '#:test)
855 (eq-test nil #'keywordp 1)
856 (eq-test nil #'keywordp #'keywordp)
857 (eq-test nil #'keywordp nil)
860 (equal-test '(3) #'last '(1 2 3))
861 (equal-test '(2 . 3) #'last '(1 2 . 3))
862 (eq-test nil #'last nil)
863 (eql-test () #'last '(1 2 3) 0)
865 (eql-test 2 #'last a 0)
866 (eq-test a #'last a 1)
867 (eq-test a #'last a 2)
869 (equal-test #c(1 2) #'last #c(1 2))
870 (equalp-test #(1 2 3) #'last #(1 2 3))
873 (eql-test 3 #'length "abc")
874 (eql-test 0 #'length nil)
875 (eql-test 1 #'length '(1 . 2))
876 (eql-test 2 #'length #(1 2))
877 (error-test #'length #c(1 2))
878 (error-test #'length t)
880 ;; let - special operator
881 (eql-eval 2 '(setq a 1 b 2))
882 (eql-eval 2 '(let ((a 2)) a))
884 (eql-eval 1 '(let ((a 3) (b a)) b))
887 ;; let* - special operator
889 (eql-eval 2 '(let* ((a 2)) a))
891 (eql-eval 3 '(let* ((a 3) (b a)) b))
895 (equal-test '(1) #'list 1)
896 (equal-test '(3 4 a b 4) #'list 3 4 'a (car '(b . c)) (+ 6 -2))
899 ;; list-length - function
900 (eql-test 4 #'list-length '(a b c d))
901 (eql-test 3 #'list-length '(a (b c) d))
902 (eql-test 0 #'list-length '())
903 (eql-test 0 #'list-length nil)
904 (defun circular-list (&rest elements)
905 (let ((cycle (copy-list elements)))
906 (nconc cycle cycle)))
907 (eq-test nil #'list-length (circular-list 'a 'b))
908 (eq-test nil #'list-length (circular-list 'a))
909 (eql-test 0 #'list-length (circular-list))
912 (eql-test 1 #'list* 1)
913 (equal-test '(a b c . d) #'list* 'a 'b 'c 'd)
916 (eq-test a #'list* a)
918 ;; listp - function (predicate)
919 (eq-test t #'listp nil)
920 (eq-test t #'listp '(1 . 2))
921 (eq-test nil #'listp t)
922 (eq-test nil #'listp #'listp)
923 (eq-test nil #'listp #(1 2))
924 (eq-test nil #'listp #c(1 2))
926 ;; lower-case-p - function
927 (eq-test t #'lower-case-p #\a)
928 (eq-test nil #'lower-case-p #\1)
929 (eq-test nil #'lower-case-p #\Newline)
930 (error-test #'lower-case-p 1)
934 ;; TODO make-array (will be rewritten)
938 ;; make-list - function
939 (equal-test '(nil nil nil) #'make-list 3)
940 (equal-test '((1 2) (1 2)) #'make-list 2 :initial-element '(1 2))
941 (eq-test nil #'make-list 0)
942 (eq-test nil #'make-list 0 :initial-element 1)
944 ;; make-package - function
945 (setq pack1 (make-package "PACKAGE-1" :nicknames '("PACK-1" "PACK1")))
946 (setq pack2 (make-package "PACKAGE-2" :nicknames '("PACK-2" "PACK2") :use '("PACK1")))
947 (equal-test (list pack2) #'package-used-by-list pack1)
948 (equal-test (list pack1) #'package-use-list pack2)
949 (eq-test pack1 #'symbol-package 'pack1::test)
950 (eq-test pack2 #'symbol-package 'pack2::test)
952 ;; make-string - function
953 (equal-test "55555" #'make-string 5 :initial-element #\5)
954 (equal-test "" #'make-string 0)
955 (error-test #'make-string 10 :initial-element t)
956 (error-test #'make-string 10 :initial-element nil)
957 (error-test #'make-string 10 :initial-element 1)
958 (eql-test 10 #'length (make-string 10))
960 ;; make-symbol - function
963 (eq-test nil #'eq (make-symbol a) (make-symbol a))
964 (equal-test a #'symbol-name (make-symbol a))
965 (setq temp-string "temp")
966 (setq temp-symbol (make-symbol temp-string))
967 (equal-test temp-string #'symbol-name temp-symbol)
968 (equal-eval '(nil nil) '(multiple-value-list (find-symbol temp-string)))
970 ;; makunbound - function
971 (eq-eval 1 '(setf (symbol-value 'a) 1))
972 (eq-test t #'boundp 'a)
974 (eq-test 'a #'makunbound 'a)
975 (eq-test nil #'boundp 'a)
976 (error-test #'makunbound 1)
980 (equal-test '(1 2 3 4)
981 #'mapc #'(lambda (&rest x) (setq dummy (append dummy x)))
985 (equal-eval '(1 a x 2 b y 3 c z) 'dummy)
988 (equal-test '(d 4 e 5)
989 #'mapcan #'(lambda (x y) (if (null x) nil (list x y)))
992 (equal-test '(1 3 4 5)
993 #'mapcan #'(lambda (x) (and (numberp x) (list x)))
997 (equal-test '(1 2 3) #'mapcar #'car '((1 a) (2 b) (3 c)))
998 (equal-test '(3 4 2 5 6) #'mapcar #'abs '(3 -4 2 -5 -6))
999 (equal-test '((a . 1) (b . 2) (c . 3)) #'mapcar #'cons '(a b c) '(1 2 3))
1000 (equal-test '((1 3 5)) #'mapcar #'list* '(1 2) '(3 4) '((5)))
1001 (equal-test '((1 3 5) (2 4 6)) #'mapcar #'list* '(1 2) '(3 4) '((5) (6)))
1003 ;; mapcon - function
1004 (equal-test '(1 a 2 b (3) c) #'mapcon #'car '((1 a) (2 b) ((3) c)))
1005 (equal-test '((1 2 3 4) (2 3 4) (3 4) (4)) #'mapcon #'list '(1 2 3 4))
1009 (equal-test '(1 2 3 4) #'mapl #'(lambda (x) (push x dummy)) '(1 2 3 4))
1010 (equal-eval '((4) (3 4) (2 3 4) (1 2 3 4)) 'dummy)
1012 ;; maplist - function
1013 (equal-test '((1 2 3 4 1 2 1 2 3) (2 3 4 2 2 3))
1014 #'maplist #'append '(1 2 3 4) '(1 2) '(1 2 3))
1015 (equal-test '((foo a b c d) (foo b c d) (foo c d) (foo d))
1016 #'maplist #'(lambda (x) (cons 'foo x)) '(a b c d))
1017 (equal-test '(0 0 1 0 1 1 1)
1018 #'maplist #'(lambda (x) (if (member (car x) (cdr x)) 0 1)) '(a b a c d b c))
1020 ;; member - function
1022 (eq-test (cdr a) #'member 2 a)
1023 (setq a '((1 . 2) (3 . 4)))
1024 (eq-test (cdr a) #'member 2 a :test-not #'= :key #'cdr)
1025 (eq-test nil #'member 'e '(a b c d))
1026 (eq-test nil #'member 1 nil)
1027 (error-test #'member 2 '(1 . 2))
1028 (setq a '(a b nil c d))
1029 (eq-test (cddr a) #'member-if #'listp a)
1030 (setq a '(a #\Space 5/3 foo))
1031 (eq-test (cddr a) #'member-if #'numberp a)
1032 (setq a '(3 6 9 11 . 12))
1033 (eq-test (cdddr a) #'member-if-not #'zerop a :key #'(lambda (x) (mod x 3)))
1035 ;; multiple-value-bind - macro
1036 (equal-eval '(11 9) '(multiple-value-bind (f r) (floor 130 11) (list f r)))
1038 ;; multiple-value-call - special operator
1039 (equal-eval '(1 / 2 3 / / 2 0.5)
1040 '(multiple-value-call #'list 1 '/ (values 2 3) '/ (values) '/ (floor 2.5)))
1041 (eql-eval 10 '(multiple-value-call #'+ (floor 5 3) (floor 19 4)))
1043 ;; multiple-value-list - macro
1044 (equal-eval '(-1 1) '(multiple-value-list (floor -3 4)))
1045 (eql-eval nil '(multiple-value-list (values)))
1046 (equal-eval '(nil) '(multiple-value-list (values nil)))
1048 ;; multiple-value-prog1 - special operator
1049 (setq temp '(1 2 3))
1051 '(multiple-value-list
1052 (multiple-value-prog1
1055 (values-list temp))))
1057 ;; multiple-value-setq - macro
1058 (eql-eval 1 '(multiple-value-setq (quotient remainder) (truncate 3.5d0 2)))
1059 (eql-eval 1 quotient)
1060 (eql-eval 1.5d0 'remainder)
1061 (eql-eval 1 '(multiple-value-setq (a b c) (values 1 2)))
1065 (eql-eval 4 '(multiple-value-setq (a b) (values 4 5 6)))
1069 (eql-eval nil '(multiple-value-setq (a) (values)))
1073 (eq-test nil #'nconc)
1076 (equal-test '(a b c d e f) #'nconc x y)
1077 (equal-eval '(a b c d e f) 'x)
1078 (eq-test y #'cdddr x)
1079 (equal-test '(1 . 2) #'nconc (list 1) 2)
1080 (error-test #'nconc 1 2 3)
1081 (equal-eval '(k l m)
1082 '(setq foo (list 'a 'b 'c 'd 'e)
1083 bar (list 'f 'g 'h 'i 'j)
1084 baz (list 'k 'l 'm)))
1085 (equal-test '(a b c d e f g h i j k l m) #'nconc foo bar baz)
1086 (equal-eval '(a b c d e f g h i j k l m) 'foo)
1087 (equal-eval (nthcdr 5 foo) 'bar)
1088 (equal-eval (nthcdr 10 foo) 'baz)
1089 (setq foo (list 'a 'b 'c 'd 'e)
1090 bar (list 'f 'g 'h 'i 'j)
1091 baz (list 'k 'l 'm))
1092 (equal-eval '(a b c d e f g h i j k l m) '(setq foo (nconc nil foo bar nil baz)))
1093 (equal-eval '(a b c d e f g h i j k l m) 'foo)
1094 (equal-eval (nthcdr 5 foo) 'bar)
1095 (equal-eval (nthcdr 10 foo) 'baz)
1097 ;; notany - function
1098 (eql-test t #'notany #'> '(1 2 3 4) '(5 6 7 8) '(9 10 11 12))
1099 (eql-test t #'notany 'not-used ())
1100 (eql-test nil #'notany #'characterp #(1 2 3 4 5 #\6 7 8))
1102 ;; notevery - function
1103 (eql-test nil #'notevery #'< '(1 2 3 4) '(5 6 7 8) '(9 10 11 12))
1104 (eql-test nil #'notevery 'not-used ())
1105 (eql-test t #'notevery #'numberp #(1 2 3 4 5 #\6 7 8))
1107 ;; nth - accessor (function)
1108 (eql-test 'foo #'nth 0 '(foo bar baz))
1109 (eql-test 'bar #'nth 1 '(foo bar baz))
1110 (eq-test nil #'nth 3 '(foo bar baz))
1111 (error-test #'nth 0 #c(1 2))
1112 (error-test #'nth 0 #(1 2))
1113 (error-test #'nth 0 "test")
1115 ;; nth-value - macro
1116 (equal-eval 'a '(nth-value 0 (values 'a 'b)))
1117 (equal-eval 'b '(nth-value 1 (values 'a 'b)))
1118 (eq-eval nil '(nth-value 2 (values 'a 'b)))
1119 (equal-eval '(3332987528 3332987528 t)
1120 '(multiple-value-list
1121 (let* ((x 83927472397238947423879243432432432)
1123 (a (nth-value 1 (floor x y)))
1125 (values a b (= a b)))))
1127 ;; nthcdr - function
1128 (eq-test nil #'nthcdr 0 '())
1129 (eq-test nil #'nthcdr 3 '())
1130 (equal-test '(a b c) #'nthcdr 0 '(a b c))
1131 (equal-test '(c) #'nthcdr 2 '(a b c))
1132 (eq-test () #'nthcdr 4 '(a b c))
1133 (eql-test 1 #'nthcdr 1 '(0 . 1))
1134 (error-test #'nthcdr -1 '(1 2))
1135 (error-test #'nthcdr #\Null '(1 2))
1136 (error-test #'nthcdr 1 t)
1137 (error-test #'nthcdr 1 #(1 2 3))
1141 (setq temp0 nil temp1 10 temp2 20 temp3 30)
1142 (eql-eval 10 '(or temp0 temp1 (setq temp2 37)))
1143 (eql-eval 20 'temp2)
1144 (eql-eval 11 '(or (incf temp1) (incf temp2) (incf temp3)))
1145 (eql-eval 11 'temp1)
1147 (eql-eval 30 'temp3)
1148 (eql-eval 11 '(or (values) temp1))
1149 (eql-eval 11 '(or (values temp1 temp2) temp3))
1150 (equal-eval '(11 20) '(multiple-value-list (or temp0 (values temp1 temp2))))
1151 (equal-eval '(20 30)
1152 '(multiple-value-list (or (values temp0 temp1) (values temp2 temp3))))
1154 ;; packagep - function (predicate)
1155 (eq-test t #'packagep *package*)
1156 (eq-test nil #'packagep 10)
1157 (eq-test t #'packagep (make-package "TEST-PACKAGE"))
1158 (eq-test nil #'packagep 'keyword)
1159 (eq-test t #'packagep (find-package 'keyword))
1161 ;; pairlis - function
1162 #+xedit ;; order of result may vary
1164 (equal-test '((one . 1) (two . 2) (three . 3) (four . 19))
1165 #'pairlis '(one two) '(1 2) '((three . 3) (four . 19)))
1167 data '("one" "two" "three")
1168 alist '((4 . "four")))
1169 (equal-test '((1 . "one") (2 . "two") (3 . "three"))
1170 #'pairlis keys data)
1171 (equal-test '((1 . "one") (2 . "two") (3 . "three") (4 . "four"))
1172 #'pairlis keys data alist)
1173 (equal-eval '(1 2 3) 'keys)
1174 (equal-eval '("one" "two" "three") 'data)
1175 (equal-eval '((4 . "four")) 'alist)
1176 (eq-test nil #'pairlis 1 2)
1177 (error-test #'pairlis '(1 2 3) '(4 5))
1181 (setq stack '(a b c) test stack)
1182 (eq-eval 'a '(pop stack))
1183 (eq-eval (cdr test) 'stack)
1184 (setq llst '((1 2 3 4)) test (car llst))
1185 (eq-eval 1 '(pop (car llst)))
1186 (eq-eval (cdr test) '(car llst))
1187 (error-eval '(pop 1))
1188 (error-eval '(pop nil))
1190 (setq stack (cons 1 2))
1191 (eq-eval 1 '(pop stack))
1192 (error-eval '(pop stack))
1194 (setq stack '#1=(1 . #1#) *print-circle* t)
1195 (eql-eval 1 '(pop stack))
1196 (eql-eval 1 '(pop stack))
1197 (eql-eval 1 '(pop (cdr stack)))
1199 ;; position - function
1200 (eql-test 4 #'position #\a "baobab" :from-end t)
1201 (eql-test 2 #'position-if #'oddp '((1) (2) (3) (4)) :start 1 :key #'car)
1202 (eq-test nil #'position 595 '())
1203 (eq-test 4 #'position-if-not #'integerp '(1 2 3 4 5.0))
1204 (eql-test 1 #'position (char-int #\1) "0123" :key #'char-int)
1207 (eq-eval nil '(prog () :error))
1210 l1 (if (< a 10) (go l3) (go l2))
1218 (eq-eval '/= '(prog ((a 2) (b a)) (return (if (= a b) '= '/=))))
1222 (eq-eval nil '(prog* () :error))
1224 '(prog* ((a 0) (b 0))
1225 l1 (if (< a 10) (go l3) (go l2))
1227 l2 (if (< b 10) (go l4) (return 'ok))
1231 l4 (incf b) (setq a 0) (go l1)
1234 (eq-eval '= '(prog* ((a 2) (b a)) (return (if (= a b) '= '/=))))
1238 (eql-eval 1 '(prog1 temp (incf temp) (eql-eval 2 'temp) temp))
1240 (eql-eval 2 '(prog1 temp (setq temp nil) (eql-eval nil 'temp) temp))
1242 (eql-eval 1 '(prog1 (values 1 2 3) 4))
1243 (setq temp (list 'a 'b 'c))
1244 (eq-eval 'a '(prog1 (car temp) (setf (car temp) 'alpha)))
1245 (equal-eval '(alpha b c) 'temp)
1247 '(multiple-value-list (prog1 (values 1 2) (values 4 5))))
1251 (eql-eval 3 '(prog2 (incf temp) (incf temp) (incf temp)))
1253 (eql-eval 2 '(prog2 1 (values 2 3 4) 5))
1255 '(multiple-value-list (prog2 (values 1 2) (values 3 4) (values 5 6))))
1257 ;; progn - special operator
1258 (eq-eval nil '(progn))
1259 (eql-eval 3 '(progn 1 2 3))
1260 (equal-eval '(1 2 3) '(multiple-value-list (progn (values 1 2 3))))
1262 (eq-eval 'here '(if a (progn (setq a nil) 'here) (progn (setq a t) 'there)))
1265 ;; progv - special operator
1266 (makunbound '*x*) ;; make sure it is not bound
1268 (eql-eval 2 '(progv '(*x*) '(2) *x*))
1271 '(let ((*x* 3)) (progv '(*x*) '(4) (list *x* (symbol-value '*x*)))))
1275 '(let ((*x* 3)) (progv '(*x*) '(4) (list *x* (symbol-value '*x*)))))
1277 '(multiple-value-list
1279 (progv '(*x*) '(4) (values-list (list *x* (symbol-value '*x*)))))))
1283 (equal-eval '(1) '(push 1 (car llst)))
1284 (equal-eval '((1)) 'llst)
1285 (equal-eval '(1 1) '(push 1 (car llst)))
1286 (equal-eval '((1 1)) 'llst)
1287 (setq x '(a (b c) d))
1288 (equal-eval '(5 B C) '(push 5 (cadr x)))
1289 (equal-eval '(a (5 b c) d) 'x)
1292 (setq x '(a (b c) d))
1293 (equal-eval '(5 b c) '(pushnew 5 (cadr x)))
1294 (equal-eval '(a (5 b c) d) 'x)
1295 (equal-eval '(5 b c) '(pushnew 'b (cadr x)))
1296 (equal-eval '(a (5 b c) d) 'x)
1297 (setq lst '((1) (1 2) (1 2 3)))
1298 (equal-eval '((2) (1) (1 2) (1 2 3)) '(pushnew '(2) lst))
1299 (equal-eval '((1) (2) (1) (1 2) (1 2 3)) '(pushnew '(1) lst))
1300 (equal-eval '((1) (2) (1) (1 2) (1 2 3)) '(pushnew '(1) lst :test 'equal))
1301 (equal-eval '((1) (2) (1) (1 2) (1 2 3)) '(pushnew '(1) lst :key #'car))
1303 ;; remove-duplicates - function
1304 (equal-test "aBcD" #'remove-duplicates "aBcDAbCd" :test #'char-equal :from-end t)
1305 (equal-test '(a c b d e) #'remove-duplicates '(a b c b d d e))
1306 (equal-test '(a b c d e) #'remove-duplicates '(a b c b d d e) :from-end t)
1307 (equal-test '((bar #\%) (baz #\A))
1308 #'remove-duplicates '((foo #\a) (bar #\%) (baz #\A))
1309 :test #'char-equal :key #'cadr)
1310 (equal-test '((foo #\a) (bar #\%))
1311 #'remove-duplicates '((foo #\a) (bar #\%) (baz #\A))
1312 :test #'char-equal :key #'cadr :from-end t)
1313 (setq tester (list 0 1 2 3 4 5 6))
1314 (equal-test '(0 4 5 6) #'delete-duplicates tester :key #'oddp :start 1 :end 6)
1316 ;; replace - function
1317 (equal-test "abcd456hij"
1318 #'replace (copy-seq "abcdefghij") "0123456789" :start1 4 :end1 7 :start2 4)
1319 (setq lst (xseq "012345678"))
1320 (equal-test "010123456" #'replace lst lst :start1 2 :start2 0)
1321 (equal-eval "010123456" 'lst)
1324 (equal-eval '(2) '(rest '(1 2)))
1325 (eql-eval 2 '(rest '(1 . 2)))
1326 (eq-eval nil '(rest '(1)))
1327 (setq *cons* '(1 . 2))
1328 (equal-eval "two" '(setf (rest *cons*) "two"))
1329 (equal-eval '(1 . "two") '*cons*)
1332 (eq-eval nil '(block nil (return) 1))
1333 (eql-eval 1 '(block nil (return 1) 2))
1334 (equal-eval '(1 2) '(multiple-value-list (block nil (return (values 1 2)) 3)))
1335 (eql-eval 1 '(block nil (block alpha (return 1) 2)))
1336 (eql-eval 2 '(block alpha (block nil (return 1)) 2))
1337 (eql-eval 1 '(block nil (block nil (return 1) 2)))
1339 ;; return-from - special operator
1340 (eq-eval nil '(block alpha (return-from alpha) 1))
1341 (eql-eval 1 '(block alpha (return-from alpha 1) 2))
1343 '(multiple-value-list (block alpha (return-from alpha (values 1 2)) 3)))
1345 '(let ((a 0)) (dotimes (i 10) (incf a) (when (oddp i) (return))) a))
1346 (eq-eval 'temp '(defun temp (x) (if x (return-from temp ''dummy)) 44))
1347 (eql-eval 44 '(temp nil))
1348 (eq-eval 'dummy (temp t))
1349 (eql-eval 2 (block nil (unwind-protect (return-from nil 1) (return-from nil 2))))
1350 (error-eval '(funcall (block nil #'(lambda () (return-from nil)))))
1352 ;; reverse - function
1353 (setq str (xseq "abc") test str)
1354 (equal-test "cba" #'reverse str)
1356 (equal-eval "cba" '(setq test (nreverse str)))
1357 (equal-eval "cba" 'test)
1358 (setq l (list 1 2 3) test l)
1359 (equal-eval '(3 2 1) '(setq test (nreverse l)))
1360 (equal-eval '(3 2 1) 'test)
1362 ;; rplac? - function
1363 (eql-eval '*some-list*
1364 '(defparameter *some-list* (list* 'one 'two 'three 'four)))
1365 (equal-eval '(one two three . four) '*some-list*)
1366 (equal-test '(uno two three . four) #'rplaca *some-list* 'uno)
1367 (equal-eval '(uno two three . four) '*some-list*)
1368 (equal-test '(three iv) #'rplacd (last *some-list*) (list 'iv))
1369 (equal-eval '(uno two three iv) '*some-list*)
1371 ;; search - function
1372 (eql-test 7 #'search "dog" "it's a dog's life")
1373 (eql-test 2 #'search '(0 1) '(2 4 6 1 3 5) :key #'oddp)
1374 (eql-test 8 #'search "foo" "foooobarfooooobarfo" :from-end t)
1377 (mapcar #'(lambda (x) (+ x (char-code #\0)))
1378 '(1 2 34 3 2 1 2 3 4 3 2 1)) :from-end t
1379 :key #'(lambda (x) (if (integerp x) (code-char x) x)))
1380 (eql-test 0 #'search "abc" "abcd" :from-end t)
1381 (eql-test 3 #'search "bar" "foobar")
1384 (eql-eval 1 '(setf (symbol-value 'n) 1))
1385 (eql-test 2 #'set 'n 2)
1386 (eql-test 2 #'symbol-value 'n)
1390 (setf (symbol-value 'n) (* n 10))
1391 (set 'n (+ (symbol-value 'n) n))
1397 (setq *n* (+ *n* 1))
1398 (setf (symbol-value '*n*) (* *n* 10))
1399 (set '*n* (+ (symbol-value '*n*) *n*))
1402 (eq-eval '*even-count* '(defvar *even-count* 0))
1403 (eq-eval '*odd-count* '(defvar *odd-count* 0))
1404 (eql-eval 'tally-list
1405 '(defun tally-list (list)
1406 (dolist (element list)
1407 (set (if (evenp element) '*even-count* '*odd-count*)
1408 (+ element (if (evenp element) *even-count* *odd-count*))))))
1409 (eq-eval nil '(tally-list '(1 9 4 3 2 7)))
1410 (eql-eval 6 '*even-count*)
1411 (eql-eval 20 '*odd-count*)
1413 ;; set-difference - function
1414 (setq lst1 (list "A" "b" "C" "d") lst2 (list "a" "B" "C" "d"))
1415 (equal-test '("A" "b" "C" "d") #'set-difference lst1 lst2)
1416 (equal-test '("A" "b") #'set-difference lst1 lst2 :test 'equal)
1417 (eq-test nil #'set-difference lst1 lst2 :test #'equalp)
1418 (equal-test '("A" "b") #'nset-difference lst1 lst2 :test #'string=)
1419 (setq lst1 '(("a" . "b") ("c" . "d") ("e" . "f"))
1420 lst2 '(("c" . "a") ("e" . "b") ("d" . "a")))
1421 (equal-test '(("c" . "d") ("e" . "f"))
1422 #'nset-difference lst1 lst2 :test #'string= :key #'cdr)
1423 (equal-eval '(("c" . "a") ("e" . "b") ("d" . "a")) 'lst2)
1424 (equal-test '("banana" "lemon" "rhubarb")
1426 '("strawberry" "chocolate" "banana" "lemon" "pistachio" "rhubarb")
1427 '(#\c #\w) :test #'(lambda (s c) (find c s)))
1429 ;; set-exclusive-or - function
1430 (setq lst1 (list 1 "a" "b") lst2 (list 1 "A" "b"))
1431 (equal-test '("a" "b" "A" "b") #'set-exclusive-or lst1 lst2)
1432 (equal-test '("a" "A") #'set-exclusive-or lst1 lst2 :test #'equal)
1433 (eq-test nil #'set-exclusive-or lst1 lst2 :test 'equalp)
1434 (equal-test '("a" "b" "A" "b") #'nset-exclusive-or lst1 lst2)
1435 (setq lst1 '(("a" . "b") ("c" . "d") ("e" . "f"))
1436 lst2 '(("c" . "a") ("e" . "b") ("d" . "a")))
1437 (equal-test '(("c" . "d") ("e" . "f") ("c" . "a") ("d" . "a"))
1438 #'nset-exclusive-or lst1 lst2 :test #'string= :key #'cdr)
1441 (setq x (cons 'a 'b) y (list 1 2 3))
1442 (equal-eval '(1 x 3) '(setf (car x) 'x (cadr y) (car x) (cdr x) y))
1443 (equal-eval '(x 1 x 3) 'x)
1444 (equal-eval '(1 x 3) 'y)
1445 (setq x (cons 'a 'b) y (list 1 2 3))
1446 (eq-eval nil '(psetf (car x) 'x (cadr y) (car x) (cdr x) y))
1447 (equal-eval '(x 1 a 3) 'x)
1448 (equal-eval '(1 a 3) 'y)
1449 (error-eval '(setf x))
1450 (error-eval '(psetf x))
1452 ;; setq - special form
1453 (eql-eval 3 '(setq a 1 b 2 c 3))
1457 (eql-eval 7 '(setq a (1+ b) b (1+ a) c (+ a b)))
1461 (eq-eval nil '(psetq a 1 b 2 c 3))
1466 '(multiple-value-list (let ((a 1) (b 2)) (psetq a b b a) (values a b))))
1467 (error-eval '(setq x))
1468 (error-eval '(setq x 1 y))
1471 (eq-test t #'some #'= '(1 2 3 4 5) '(5 4 3 2 1))
1474 (setq tester (copy-seq "lkjashd"))
1475 (equal-test "adhjkls" #'sort tester #'char-lessp)
1476 (setq tester (list '(1 2 3) '(4 5 6) '(7 8 9)))
1477 (equal-test '((7 8 9) (4 5 6) (1 2 3)) #'sort tester #'> :key #'car)
1478 (setq tester (list 1 2 3 4 5 6 7 8 9 0))
1479 (equal-test '(1 3 5 7 9 2 4 6 8 0)
1480 #'stable-sort tester #'(lambda (x y) (and (oddp x) (evenp y))))
1482 #((("Kathy" "Chapman") "Editorial")
1483 (("Dick" "Gabriel") "Objects")
1484 (("Gregor" "Kiczales") "Objects")
1485 (("Sandra" "Loosemore") "Compiler")
1486 (("Larry" "Masinter") "Cleanup")
1487 (("David" "Moon") "Objects")
1488 (("Kent" "Pitman") "Conditions")
1489 (("Dick" "Waters") "Iteration")
1490 (("JonL" "White") "Iteration"))
1491 #'sort (setq committee-data
1492 (vector (list (list "JonL" "White") "Iteration")
1493 (list (list "Dick" "Waters") "Iteration")
1494 (list (list "Dick" "Gabriel") "Objects")
1495 (list (list "Kent" "Pitman") "Conditions")
1496 (list (list "Gregor" "Kiczales") "Objects")
1497 (list (list "David" "Moon") "Objects")
1498 (list (list "Kathy" "Chapman") "Editorial")
1499 (list (list "Larry" "Masinter") "Cleanup")
1500 (list (list "Sandra" "Loosemore") "Compiler")))
1501 #'string-lessp :key #'cadar)
1503 #((("Larry" "Masinter") "Cleanup")
1504 (("Sandra" "Loosemore") "Compiler")
1505 (("Kent" "Pitman") "Conditions")
1506 (("Kathy" "Chapman") "Editorial")
1507 (("Dick" "Waters") "Iteration")
1508 (("JonL" "White") "Iteration")
1509 (("Dick" "Gabriel") "Objects")
1510 (("Gregor" "Kiczales") "Objects")
1511 (("David" "Moon") "Objects"))
1512 '(setq committee-data
1513 (stable-sort committee-data #'string-lessp :key #'cadr)))
1514 (error-test #'sort #c(1 2))
1516 ;; string - function
1517 (setq a "already a string")
1518 (eq-test a #'string a)
1519 (equal-test "ELM" #'string 'elm)
1520 (equal-test "c" #'string #\c)
1522 ;; string-* - function
1523 (eq-test t #'string= "foo" "foo")
1524 (eq-test nil #'string= "foo" "Foo")
1525 (eq-test nil #'string= "foo" "bar")
1526 (eq-test t #'string= "together" "frog" :start1 1 :end1 3 :start2 2)
1527 (eq-test t #'string-equal "foo" "Foo")
1528 (eq-test t #'string= "abcd" "01234abcd9012" :start2 5 :end2 9)
1529 (eql-test 3 #'string< "aaaa" "aaab")
1530 (eql-test 4 #'string>= "aaaaa" "aaaa")
1531 (eql-test 5 #'string-not-greaterp "Abcde" "abcdE")
1532 (eql-test 6 #'string-lessp "012AAAA789" "01aaab6" :start1 3 :end1 7
1534 (eq-test nil #'string-not-equal "AAAA" "aaaA")
1535 (error-test #'string= #(1 2 3) '(1 2 3))
1536 (eql-test 0 #'string< "abcd" "efg")
1537 (eql-test 1 #'string< "abcd" "afg")
1538 (eql-test 0 #'string/= "foo" "baar")
1539 (eql-test nil #'string/= "foobar" "foobar")
1541 ;; string-{upcase,downcase,capitalize} - function
1542 (equal-test "ABCDE" #'string-upcase "abcde")
1543 (equal-test "aBCDe" #'string-upcase "abcde" :start 1 :end 4)
1544 (equal-test "aBCDe" #'nstring-upcase (xseq "abcde") :start 1 :end 4)
1545 (equal-test "DR. LIVINGSTON, I PRESUME?"
1546 #'string-upcase "Dr. Livingston, I presume?")
1547 (equal-test "Dr. LIVINGSTON, I Presume?"
1548 #'string-upcase "Dr. Livingston, I presume?" :start 4 :end 19)
1549 (equal-test "Dr. LIVINGSTON, I Presume?"
1550 #'nstring-upcase (xseq "Dr. Livingston, I presume?") :start 4 :end 19)
1551 (equal-test "Dr. LiVINGston, I presume?"
1552 #'string-upcase "Dr. Livingston, I presume?" :start 6 :end 10)
1553 (equal-test "Dr. LiVINGston, I presume?"
1554 #'nstring-upcase (xseq "Dr. Livingston, I presume?") :start 6 :end 10)
1555 (equal-test "dr. livingston, i presume?"
1556 #'string-downcase "Dr. Livingston, I presume?")
1557 (equal-test "Dr. livingston, i Presume?"
1558 #'string-downcase "Dr. Livingston, I Presume?" :start 1 :end 17)
1559 (equal-test "Dr. livingston, i Presume?"
1560 #'nstring-downcase (xseq "Dr. Livingston, I Presume?") :start 1 :end 17)
1561 (equal-test "Elm 13c Arthur;Fig Don'T"
1562 #'string-capitalize "elm 13c arthur;fig don't")
1563 (equal-test "elm 13C Arthur;Fig Don't"
1564 #'string-capitalize "elm 13c arthur;fig don't" :start 6 :end 21)
1565 (equal-test "elm 13C Arthur;Fig Don't"
1566 #'nstring-capitalize (xseq "elm 13c arthur;fig don't") :start 6 :end 21)
1567 (equal-test " Hello " #'string-capitalize " hello ")
1568 (equal-test " Hello " #'nstring-capitalize (xseq " hello "))
1569 (equal-test "Occluded Casements Forestall Inadvertent Defenestration"
1570 #'string-capitalize "occlUDeD cASEmenTs FOreSTAll iNADVertent DEFenestraTION")
1571 (equal-test "Don'T!" #'string-capitalize "DON'T!")
1572 (equal-test "Pipe 13a, Foo16c" #'string-capitalize "pipe 13a, foo16c")
1573 (setq str (copy-seq "0123ABCD890a"))
1574 (equal-test "0123AbcD890a" #'nstring-downcase str :start 5 :end 7)
1575 (equal-eval "0123AbcD890a" 'str)
1576 (error-test #'nstring-capitalize 1)
1577 (error-test #'string-capitalize "foobar" :start 4 :end 2)
1578 (equal-test "foobar" #'string-capitalize "foobar" :start 0 :end 0)
1580 ;; string-{,left-,right-}trim - function
1581 (equal-test "kaaak" #'string-trim "abc" "abcaakaaakabcaaa")
1582 #+xedit (equal-test "kaaak" #'nstring-trim "abc" "abcaakaaakabcaaa")
1583 (equal-test "garbanzo beans"
1584 #'string-trim '(#\Space #\Tab #\Newline) " garbanzo beans
1586 #+xedit (equal-test "garbanzo beans"
1587 #'nstring-trim '(#\Space #\Tab #\Newline) " garbanzo beans
1589 (equal-test "three (silly) words"
1590 #'string-trim " (*)" " ( *three (silly) words* ) ")
1591 #+xedit (equal-test "three (silly) words"
1592 #'nstring-trim " (*)" " ( *three (silly) words* ) ")
1593 (equal-test "labcabcabc" #'string-left-trim "abc" "labcabcabc")
1594 #+xedit (equal-test "labcabcabc" #'nstring-left-trim "abc" "labcabcabc")
1595 (equal-test "three (silly) words* ) "
1596 #'string-left-trim " (*)" " ( *three (silly) words* ) ")
1597 #+xedit (equal-test "three (silly) words* ) "
1598 #'nstring-left-trim " (*)" " ( *three (silly) words* ) ")
1599 (equal-test " ( *three (silly) words"
1600 #'string-right-trim " (*)" " ( *three (silly) words* ) ")
1601 #+xedit (equal-test " ( *three (silly) words"
1602 #'nstring-right-trim " (*)" " ( *three (silly) words* ) ")
1603 (error-test #'string-trim 123 "123")
1604 (error-test #'string-left-trim 123 "123")
1606 ;; stringp - function (predicate)
1607 (eq-test t #'stringp "abc")
1608 (eq-test nil #'stringp #\a)
1609 (eq-test nil #'stringp 1)
1610 (eq-test nil #'stringp #(#\a #\b #\c))
1612 ;; subseq - accessor
1613 (setq str (xseq "012345"))
1614 (equal-test "2345" #'subseq str 2)
1615 (equal-test "34" #'subseq str 3 5)
1616 (equal-eval "abc" '(setf (subseq str 4) "abc"))
1617 (equal-eval "0123ab" 'str)
1618 (equal-eval "A" '(setf (subseq str 0 2) "A"))
1619 (equal-eval "A123ab" 'str)
1621 ;; subsetp - function
1622 (setq cosmos '(1 "a" (1 2)))
1623 (eq-test t #'subsetp '(1) cosmos)
1624 (eq-test nil #'subsetp '((1 2)) cosmos)
1625 (eq-test t #'subsetp '((1 2)) cosmos :test 'equal)
1626 (eq-test t #'subsetp '(1 "A") cosmos :test #'equalp)
1627 (eq-test nil #'subsetp '((1) (2)) '((1) (2)))
1628 (eq-test t #'subsetp '((1) (2)) '((1) (2)) :key #'car)
1631 ;; XXX vectors will be reimplemented, just a test for the current implementation
1632 (setq v (vector 1 2 'sirens))
1633 (eql-eval 1 '(svref v 0))
1634 (eql-eval 'sirens '(svref v 2))
1635 (eql-eval 'newcomer '(setf (svref v 1) 'newcomer))
1636 (equalp-eval #(1 newcomer sirens) 'v)
1638 ;; symbol-name - function
1639 (equal-test "TEMP" #'symbol-name 'temp)
1640 (equal-test "START" #'symbol-name :start)
1641 (error-test #'symbol-name 1)
1643 ;; symbol-package - function
1644 (eq-test (find-package "LISP") #'symbol-package 'car)
1645 (eql-test *package* #'symbol-package 'bus)
1646 (eq-test (find-package "KEYWORD") #'symbol-package :optional)
1647 ;; Gensyms are uninterned, so have no home package.
1648 (eq-test nil #'symbol-package (gensym))
1649 (setq pk1 (make-package 'pk1))
1650 (intern "SAMPLE1" "PK1")
1651 (eq-eval t '(export (find-symbol "SAMPLE1" "PK1") "PK1"))
1652 (setq pk2 (make-package 'pk2 :use '(pk1)))
1653 (equal-eval '(pk1:sample1 :inherited)
1654 '(multiple-value-list (find-symbol "SAMPLE1" "PK2")))
1655 (eq-test pk1 #'symbol-package 'pk1::sample1)
1656 (eq-test pk1 #'symbol-package 'pk2::sample1)
1657 (eq-test pk1 #'symbol-package 'pk1::sample2)
1658 (eq-test pk2 #'symbol-package 'pk2::sample2)
1659 ;; The next several forms create a scenario in which a symbol
1660 ;; is not really uninterned, but is "apparently uninterned",
1661 ;; and so SYMBOL-PACKAGE still returns NIL.
1662 (setq s3 'pk1::sample3)
1663 (eq-eval t '(import s3 'pk2))
1664 (eq-eval t '(unintern s3 'pk1)) ;; XXX unintern not yet implemented
1665 (eq-test nil #'symbol-package s3) ;; fail due to unintern not implemented
1666 (eq-test t #'eq s3 'pk2::sample3)
1668 ;; symbol-plist - accessor
1670 (eq-eval () '(symbol-plist sym))
1671 (eq-eval 'val1 '(setf (get sym 'prop1) 'val1))
1672 (equal-eval '(prop1 val1) '(symbol-plist sym))
1673 (eq-eval 'val2 '(setf (get sym 'prop2) 'val2))
1674 (equal-eval '(prop2 val2 prop1 val1) '(symbol-plist sym))
1675 (setq sym-plist (list 'prop3 'val3))
1676 (eq-eval sym-plist '(setf (symbol-plist sym) sym-plist))
1677 (eq-eval sym-plist '(symbol-plist sym))
1679 ;; symbol-value - accessor
1680 (eql-eval 1 '(setf (symbol-value 'a) 1))
1681 (eql-eval 1 '(symbol-value 'a))
1682 ;; SYMBOL-VALUE cannot see lexical variables.
1683 (eql-eval 1 '(let ((a 2)) (symbol-value 'a)))
1684 (eql-eval 1 '(let ((a 2)) (setq a 3) (symbol-value 'a)))
1686 #+xedit ;; incorrect...
1688 ;; SYMBOL-VALUE can see dynamic variables.
1689 ;; declare not yet implemented
1690 (proclaim '(special a))
1691 (eql-eval 2 '(let ((a 2)) (symbol-value 'a)))
1693 (eql-eval 3 '(let ((a 2)) (setq a 3) (symbol-value 'a)))
1695 ;; declare not yet implement
1697 (eql-eval 2 '(let ((a 2)) (setf (symbol-value 'a) 3) a))
1699 (eql-eval 3 '(symbol-value 'a))
1700 ;; declare not yet implement
1703 '(multiple-value-list
1706 ;; declare not yet implemented
1709 (let ((b (symbol-value 'a)))
1710 (setf (symbol-value 'a) 5)
1714 (eq-eval :any-keyword '(symbol-value :any-keyword))
1715 ;; XXX these will fail
1716 (eq-eval nil '(symbol-value 'nil))
1717 (eq-eval nil '(symbol-value '()))
1719 ;; symbolp - function (predicate)
1720 (eq-test t #'symbolp 'elephant)
1721 (eq-test nil #'symbolp 12)
1722 ;; XXX these will fail
1723 (eq-test t #'symbolp nil)
1724 (eq-test t #'symbolp '())
1725 (eq-test t #'symbolp :test)
1726 (eq-test nil #'symbolp "hello")
1728 ;; remprop - function
1729 (setq test (make-symbol "PSEUDO-PI"))
1730 (eq-eval () '(symbol-plist test))
1731 (eq-eval t '(setf (get test 'constant) t))
1732 (eql-eval 3.14 '(setf (get test 'approximation) 3.14))
1733 (eql-eval 'noticeable '(setf (get test 'error-range) 'noticeable))
1734 (equal-eval '(error-range noticeable approximation 3.14 constant t)
1735 '(symbol-plist test))
1736 (eq-eval nil '(setf (get test 'approximation) nil))
1737 (equal-eval '(error-range noticeable approximation nil constant t)
1738 '(symbol-plist test))
1739 (eq-eval nil (get test 'approximation))
1740 (eq-test t #'remprop test 'approximation)
1741 (eq-eval nil '(get test 'approximation))
1742 (equal-eval '(error-range noticeable constant t) '(symbol-plist test))
1743 (eq-test nil #'remprop test 'approximation)
1744 (equal-eval '(error-range noticeable constant t) '(symbol-plist test))
1745 (eq-test t #'remprop test 'error-range)
1746 (eql-eval 3 '(setf (get test 'approximation) 3))
1747 (equal-eval '(approximation 3 constant t) '(symbol-plist test))
1749 ;; throw - special operator
1751 '(multiple-value-list
1754 (loop (incf j 3) (incf i)
1755 (if (= i 3) (throw 'result (values i j)))))))
1756 (eql-eval 2 '(catch nil (unwind-protect (throw nil 1) (throw nil 2))))
1758 ;; XXX undefined consequences
1762 (unwind-protect (throw 'a 1)
1764 (eq-eval :outer-catch
1766 (setq string (format nil "The inner catch returns ~s."
1768 (unwind-protect (throw 'foo :first-throw)
1769 (throw 'foo :second-throw)))))
1771 (equal-eval "The inner catch returns :SECOND-THROW." 'string)
1773 ;; tree-equal - function
1774 (setq tree1 '(1 (1 2))
1776 (eq-test t #'tree-equal tree1 tree2)
1777 (eq-test nil #'eql tree1 tree2)
1778 (setq tree1 '('a ('b 'c))
1779 tree2 '('a ('b 'c)))
1780 (eq-test t #'tree-equal tree1 tree2 :test 'eq)
1781 (eq-test t #'tree-equal 1 1)
1782 (eq-test nil #'tree-equal (list 1 2) (cons 1 2))
1783 (eq-test nil #'tree-equal 1 2)
1786 (equal-test '(b c f a d) #'union '(a b c) '(f a d))
1787 (equal-test '((y 6) (z 2) (x 4))
1788 #'union '((x 5) (y 6)) '((z 2) (x 4)) :key #'car)
1789 (setq lst1 (list 1 2 '(1 2) "a" "b")
1790 lst2 (list 2 3 '(2 3) "B" "C"))
1791 (equal-test '(1 (1 2) "a" "b" 2 3 (2 3) "B" "C") #'nunion lst1 lst2)
1794 (eq-eval 'hello '(when t 'hello))
1795 (eq-eval nil '(unless t 'hello))
1796 (eq-eval nil (when nil 'hello))
1797 (eq-eval 'hello '(unless nil 'hello))
1798 (eq-eval nil (when t))
1799 (eql-eval nil '(unless nil))
1801 (equal-eval '(3 2 1) '(when t (push 1 test) (push 2 test) (push 3 test)))
1802 (equal-eval '(3 2 1) 'test)
1804 (eq-eval nil '(unless t (push 1 test) (push 2 test) (push 3 test)))
1806 (eq-eval nil '(when nil (push 1 test) (push 2 test) (push 3 test)))
1808 (equal-eval '(3 2 1) '(unless nil (push 1 test) (push 2 test) (push 3 test)))
1809 (equal-eval '(3 2 1) 'test)
1810 (equal-eval '((4) nil (5) nil 6 (6) 7 (7))
1812 (list (when (oddp x) (incf x) (list x))
1813 (when (oddp x) (incf x) (list x))
1814 (unless (oddp x) (incf x) (list x))
1815 (unless (oddp x) (incf x) (list x))
1816 (if (oddp x) (incf x) (list x))
1817 (if (oddp x) (incf x) (list x))
1818 (if (not (oddp x)) (incf x) (list x))
1819 (if (not (oddp x)) (incf x) (list x)))))
1821 ;; unwind-protect - special operator
1822 (defun dummy-function (x)
1823 (setq state 'running)
1824 (unless (numberp x) (throw 'abort 'not-a-number))
1825 (setq state (1+ x)))
1826 (eql-eval 2 '(catch 'abort (dummy-function 1)))
1828 (eq-eval 'not-a-number '(catch 'abort (dummy-function 'trash)))
1829 (eq-eval 'running 'state)
1830 (eq-eval 'not-a-number
1831 '(catch 'abort (unwind-protect (dummy-function 'trash)
1832 (setq state 'aborted))))
1833 (eq-eval 'aborted 'state)
1834 (eql-eval 2 '(block nil (unwind-protect (return 1) (return 2))))
1835 ;; XXX undefined consequences
1839 (unwind-protect (return-from a 1)
1840 (return-from b 2)))))
1841 (eql-eval 2 '(catch nil (unwind-protect (throw nil 1) (throw nil 2))))
1842 ;; XXX undefined consequences
1844 '(catch 'a (catch 'b (unwind-protect (throw 'a 1) (throw 'b 2)))))
1845 (eq-eval ':outer-catch
1848 (format nil "The inner catch returns ~s."
1850 (unwind-protect (throw 'foo :first-throw)
1851 (throw 'foo :second-throw)))))
1853 (equal-eval "The inner catch returns :SECOND-THROW." 'string)
1857 (unwind-protect (1+ (catch 'a (throw 'b 1)))
1859 ;; XXX undefined consequences
1863 (unwind-protect (throw 'foo 3)
1869 (unwind-protect (throw 'foo 3)
1875 (unwind-protect (return)
1878 ;; upper-case-p - function
1879 (eq-test t #'upper-case-p #\A)
1880 (eq-test nil #'upper-case-p #\a)
1881 (eq-test nil #'upper-case-p #\5)
1882 (error-test #'upper-case-p 1)
1884 ;; values - accessor
1885 (eq-eval () '(multiple-value-list (values)))
1886 (equal-eval '(1) '(multiple-value-list (values 1)))
1887 (equal-eval '(1 2) '(multiple-value-list (values 1 2)))
1888 (equal-eval '(1 2 3) '(multiple-value-list (values 1 2 3)))
1889 (equal-eval '(1 4 5) '(multiple-value-list (values (values 1 2 3) 4 5)))
1891 ;; values-list - function
1892 (eq-eval nil '(multiple-value-list (values-list nil)))
1893 (equal-eval '(1) '(multiple-value-list (values-list '(1))))
1894 (equal-eval '(1 2) '(multiple-value-list (values-list '(1 2))))
1895 (equal-eval '(1 2 3) '(multiple-value-list (values-list '(1 2 3))))