1;;
2;; Copyright (c) 2002 by The XFree86 Project, Inc.
3;;
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:
10;;
11;; The above copyright notice and this permission notice shall be included in
12;; all copies or substantial portions of the Software.
13;;
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
20;; SOFTWARE.
21;;
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
25;; XFree86 Project.
26;;
27;; Author: Paulo César Pereira de Andrade
28;;
29;;
30;; $XFree86: xc/programs/xedit/lisp/test/list.lsp,v 1.5 2002/11/26 04:06:30 paulo Exp $
31;;
32
33;; basic lisp function tests
34
35;; Most of the tests are just the examples from the
36;;
37;;	Common Lisp HyperSpec (TM)
38;;	Copyright 1996-2001, Xanalys Inc. All rights reserved.
39;;
40;; Some tests are hand crafted, to test how the interpreter treats
41;; uncommon arguments or special conditions
42
43
44#|
45 MAJOR PROBLEMS:
46
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.
52|#
53
54(defun compare-test (test expect function arguments
55		     &aux result (error t) unused error-value)
56    (multiple-value-setq
57	(unused error-value)
58	(ignore-errors
59	    (setq result (apply function arguments))
60	    (setq error nil)
61	)
62    )
63    (if error
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
68	    )
69	)
70    )
71)
72
73(defun compare-eval (test expect form
74		     &aux result (error t) unused error-value)
75    (multiple-value-setq
76	(unused error-value)
77	(ignore-errors
78	    (setq result (eval form))
79	    (setq error nil)
80	)
81    )
82    (if error
83	(format t "ERROR: ~S => ~S~%" form error-value)
84	(or (funcall test result expect)
85	    (format t "~S => should be ~S not ~S~%"
86		form expect result
87	    )
88	)
89    )
90)
91
92(defun error-test (function &rest arguments &aux result (error t))
93    (ignore-errors
94	(setq result (apply function arguments))
95	(setq error nil)
96    )
97    (or error
98	(format t "ERROR: no error for (~S~{ ~S~}), result was ~S~%"
99	    function arguments result)
100    )
101)
102
103(defun error-eval (form &aux result (error t))
104    (ignore-errors
105	(setq result (eval form))
106	(setq error nil)
107    )
108    (or error
109	(format t "ERROR: no error for ~S, result was ~S~%" form result)
110    )
111)
112
113(defun eq-test (expect function &rest arguments)
114    (compare-test #'eq expect function arguments))
115
116(defun eql-test (expect function &rest arguments)
117    (compare-test #'eql expect function arguments))
118
119(defun equal-test (expect function &rest arguments)
120    (compare-test #'equal expect function arguments))
121
122(defun equalp-test (expect function &rest arguments)
123    (compare-test #'equalp expect function arguments))
124
125
126(defun eq-eval (expect form)
127    (compare-eval #'eq expect form))
128
129(defun eql-eval (expect form)
130    (compare-eval #'eql expect form))
131
132(defun equal-eval (expect form)
133    (compare-eval #'equal expect form))
134
135(defun equalp-eval (expect form)
136    (compare-eval #'equalp expect form))
137
138;; clisp treats strings loaded from a file as constants
139(defun xseq (sequence)
140    #+clisp (if *load-pathname* (copy-seq sequence) sequence)
141    #-clisp sequence
142)
143
144;; apply				- function
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 ())
154
155;; eq					- function
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))
163
164;; eql					- function
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))
176
177(setf
178    hash0 (make-hash-table)
179    hash1 (make-hash-table)
180    (gethash 1 hash0) 2
181    (gethash 1 hash1) 2
182    (gethash :foo hash0) :bar
183    (gethash :foo hash1) :bar
184)
185(defstruct test a b c)
186(setq
187    struc0 (make-test :a 1 :b 2 :c #\c)
188    struc1 (make-test :a 1 :b 2 :c #\c)
189)
190
191;; equal				- function
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))
204
205;; equalp				- function
206(eq-test t #'equalp hash0 hash1)
207(setf
208    (gethash 2 hash0) "FoObAr"
209    (gethash 2 hash1) "fOoBaR"
210)
211(eq-test t #'equalp hash0 hash1)
212(setf
213    (gethash 3 hash0) 3
214    (gethash 3d0 hash1) 3
215)
216(eq-test nil #'equalp hash0 hash1)
217(eq-test t #'equalp struc0 struc1)
218(setf
219    (test-a struc0) #\a
220    (test-a struc1) #\A
221)
222(eq-test t #'equalp struc0 struc1)
223(setf
224    (test-b struc0) 'test
225    (test-b struc1) :test
226)
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))
232
233;; acons				- function
234(equal-test '((1 . "one")) #'acons 1 "one" nil)
235(equal-test '((2 . "two") (1 . "one")) #'acons 2 "two" '((1 . "one")))
236
237;; adjoin				- function
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)
245
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)
250
251;; alphanumericp			- function
252(eq-test t #'alphanumericp #\Z)
253(eq-test t #'alphanumericp #\8)
254(eq-test nil #'alphanumericp #\#)
255
256;; and					- macro
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)))
263(eq-eval t '(and))
264(equal-eval '(1 2 3) '(multiple-value-list (and (values 'a) (values 1 2 3))))
265(equal-eval nil '(and (values) t))
266
267;; append				- function
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)
273
274;; assoc				- function
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)))
284
285;; atom					- function
286(eq-test t #'atom 1)
287(eq-test t #'atom '())
288(eq-test nil #'atom '(1))
289(eq-test t #'atom 'a)
290
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))
296
297;; both-case-p				- function
298(eq-test t #'both-case-p #\a)
299(eq-test nil #'both-case-p #\1)
300
301;; boundp				- function
302(eql-eval 1 '(setq x 1))
303(eq-test t #'boundp 'x)
304(makunbound 'x)
305(eq-test nil #'boundp 'x)
306(eq-eval nil '(let ((x 1)) (boundp 'x)))
307(error-test #'boundp 1)
308
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)
315(equal-eval '(1) 'x)
316(eq-test nil #'butlast nil)
317(eq-test nil #'nbutlast '())
318(error-test #'butlast 1 2)
319(error-test #'butlast -1 '(1 2))
320
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))
352
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))
366(error-test #'car 1)
367(error-test #'car #c(1 2))
368(error-test #'car #(1 2))
369
370;; case					- macro
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))))
375
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))
381
382;; char					- function
383(eql-test #\a #'char "abc" 0)
384(eql-test #\b #'char "abc" 1)
385(error-test #'char "abc" 3)
386
387;; char-*				- function
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)
516
517;; char-code				- function
518;; XXX assumes ASCII
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)
527
528;; character				- function
529(eql-test #\a #'character #\a)
530(eql-test #\a #'character "a")
531(eql-test #\A #'character 'a)
532
533;; XXX assumes ASCII, and should be allowed to fail?
534(eql-test #\A #'character 65)
535
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)
541
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)
548
549
550
551
552;; TODO coerce
553
554
555
556
557;; cond					- macro
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))))
560
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)
566
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*)
582
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")
591(eql-test 1 #'car y)
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)))
610
611;; decf					- macro
612(setq n 2)
613(eql-eval 1 '(decf n))
614(eql-eval 1 'n)
615(setq n -2147483648)
616(eql-eval -2147483649 '(decf n))
617(eql-eval -2147483649 'n)
618(setq n 0)
619(eql-eval -0.5d0 '(decf n 0.5d0))
620(eql-eval -0.5d0 'n)
621(setq n 1)
622(eql-eval 1/2 '(decf n 1/2))
623(eql-eval 1/2 'n)
624
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)
655
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)
663
664
665
666;; TODO directory (known to have problems with parameters like "../*/../*/")
667
668
669
670;; elt					- function
671(eql-test #\a #'elt "xabc" 1)
672(eql-test 3 #'elt '(0 1 2 3) 3)
673(error-test #'elt nil 0)
674
675;; endp					- function
676(eql-test t #'endp nil)
677(error-test #'endp t)
678(eql-test nil #'endp '(1 . 2))
679(error-test #'endp #(1 2))
680
681;; every				- function
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))
686
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)
696
697;; fill					- function
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)
704
705;; find					- function
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))
711
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)))
742
743#+xedit (equal-eval '(nil nil)
744	'(multiple-value-list (find-symbol "NIL" "KEYWORD")))
745#|
746;; optional result of previous form:
747(equal-eval '(:nil :external)
748    '(multiple-value-list (find-symbol "NIL" "KEYWORD")))
749|#
750
751
752
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)
757
758
759
760;; TODO properly implement ``function''
761
762
763
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)
772
773;; gensym				- function
774(setq sym1 (gensym))
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))
780
781;; get					- accessor
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)
786    person))
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)
796  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*))
802(eq-eval 'age
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))
810
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)
817
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)))
823
824;; incf					- macro
825(setq n 1)
826(eql-eval 2 '(incf n))
827(eql-eval 2 'n)
828(setq n 2147483647)
829(eql-eval 2147483648 '(incf n))
830(eql-eval 2147483648 'n)
831(setq n 0)
832(eql-eval 0.5d0 '(incf n 0.5d0))
833(eql-eval 0.5d0 'n)
834(setq n 1)
835(eql-eval 3/2 '(incf n 1/2))
836(eql-eval 3/2 'n)
837
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)
850
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)
858
859;; last					- function
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)
864(setq a '(1 . 2))
865(eql-test 2 #'last a 0)
866(eq-test a #'last a 1)
867(eq-test a #'last a 2)
868(eq-test t #'last t)
869(equal-test #c(1 2) #'last #c(1 2))
870(equalp-test #(1 2 3) #'last #(1 2 3))
871
872;; length				- function
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)
879
880;; let					- special operator
881(eql-eval 2 '(setq a 1 b 2))
882(eql-eval 2 '(let ((a 2)) a))
883(eql-eval 1 'a)
884(eql-eval 1 '(let ((a 3) (b a)) b))
885(eql-eval 2 'b)
886
887;; let*					- special operator
888(setq a 1 b 2)
889(eql-eval 2 '(let* ((a 2)) a))
890(eql-eval 1 'a)
891(eql-eval 3 '(let* ((a 3) (b a)) b))
892(eql-eval 2 'b)
893
894;; list					- function
895(equal-test '(1) #'list 1)
896(equal-test '(3 4 a b 4) #'list 3 4 'a (car '(b . c)) (+ 6 -2))
897(eq-test nil #'list)
898
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))
910
911;; list*				- function
912(eql-test 1 #'list* 1)
913(equal-test '(a b c . d) #'list* 'a 'b 'c 'd)
914(error-test #'list*)
915(setq a '(1 2))
916(eq-test a #'list* a)
917
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))
925
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)
931
932
933
934;; TODO make-array	(will be rewritten)
935
936
937
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)
943
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)
951
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))
959
960;; make-symbol				- function
961(setq a "TEST")
962;; This will fail
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)))
969
970;; makunbound				- function
971(eq-eval 1 '(setf (symbol-value 'a) 1))
972(eq-test t #'boundp 'a)
973(eql-eval 1 'a)
974(eq-test 'a #'makunbound 'a)
975(eq-test nil #'boundp 'a)
976(error-test #'makunbound 1)
977
978;; mapc					- function
979(setq dummy nil)
980(equal-test '(1 2 3 4)
981    #'mapc #'(lambda (&rest x) (setq dummy (append dummy x)))
982   '(1 2 3 4)
983   '(a b c d e)
984   '(x y z))
985(equal-eval '(1 a x 2 b y 3 c z) 'dummy)
986
987;; mapcan				- function
988(equal-test '(d 4 e 5)
989    #'mapcan #'(lambda (x y) (if (null x) nil (list x y)))
990    '(nil nil nil d e)
991    '(1 2 3 4 5 6))
992(equal-test '(1 3 4 5)
993    #'mapcan #'(lambda (x) (and (numberp x) (list x)))
994    '(a 1 b c 3 4 d 5))
995
996;; mapcar				- function
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)))
1002
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))
1006
1007;; mapl					- function
1008(setq dummy nil)
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)
1011
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))
1019
1020;; member				- function
1021(setq a '(1 2 3))
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)))
1034
1035;; multiple-value-bind			- macro
1036(equal-eval '(11 9) '(multiple-value-bind (f r) (floor 130 11) (list f r)))
1037
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)))
1042
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)))
1047
1048;; multiple-value-prog1			- special operator
1049(setq temp '(1 2 3))
1050(equal-eval temp
1051    '(multiple-value-list
1052	(multiple-value-prog1
1053	    (values-list temp)
1054	    (setq temp nil)
1055	    (values-list temp))))
1056
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)))
1062(eql-eval 1 'a)
1063(eql-eval 2 'b)
1064(eq-eval nil 'c)
1065(eql-eval 4 '(multiple-value-setq (a b) (values 4 5 6)))
1066(eql-eval 4 'a)
1067(eql-eval 5 'b)
1068(setq a 1)
1069(eql-eval nil '(multiple-value-setq (a) (values)))
1070(eql-eval nil 'a)
1071
1072;; nconc				- function
1073(eq-test nil #'nconc)
1074(setq x '(a b c))
1075(setq y '(d e f))
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)
1096
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))
1101
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))
1106
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")
1114
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)
1122	       (y 32423489732)
1123	       (a (nth-value 1 (floor x y)))
1124	       (b (mod x y)))
1125	  (values a b (= a b)))))
1126
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))
1138
1139;; or					- macro
1140(eq-eval nil '(or))
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)
1146(eql-eval 20 temp2)
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))))
1153
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))
1160
1161;; pairlis				- function
1162#+xedit	;; order of result may vary
1163(progn
1164    (equal-test '((one . 1) (two . 2) (three . 3) (four . 19))
1165	#'pairlis '(one two) '(1 2) '((three . 3) (four . 19)))
1166    (setq keys '(1 2 3)
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))
1178)
1179
1180;; pop					- macro
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))
1189;; dotted list
1190(setq stack (cons 1 2))
1191(eq-eval 1 '(pop stack))
1192(error-eval '(pop stack))
1193;; circular list
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)))
1198
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)
1205
1206;; prog					- macro
1207(eq-eval nil '(prog () :error))
1208(eq-eval 'ok
1209    '(prog ((a 0))
1210	l1 (if (< a 10) (go l3) (go l2))
1211	(return 'failed)
1212	l2 (return 'ok)
1213	(return 'failed)
1214	l3 (incf a) (go l1)
1215	(return 'failed)
1216    ))
1217(setq a 1)
1218(eq-eval '/= '(prog ((a 2) (b a)) (return (if (= a b) '= '/=))))
1219
1220;; prog*				- macro
1221(setq a 1)
1222(eq-eval nil '(prog* () :error))
1223(eq-eval 'ok
1224    '(prog* ((a 0) (b 0))
1225	l1 (if (< a 10) (go l3) (go l2))
1226	(return 'failed)
1227	l2 (if (< b 10) (go l4) (return 'ok))
1228	(return 'failed)
1229	l3 (incf a) (go l1)
1230	(return 'failed)
1231	l4 (incf b) (setq a 0) (go l1)
1232	(return 'failed)
1233    ))
1234(eq-eval '= '(prog* ((a 2) (b a)) (return (if (= a b) '= '/=))))
1235
1236;; prog1				- macro
1237(setq temp 1)
1238(eql-eval 1 '(prog1 temp (incf temp) (eql-eval 2 'temp) temp))
1239(eql-eval 2 'temp)
1240(eql-eval 2 '(prog1 temp (setq temp nil) (eql-eval nil 'temp) temp))
1241(eq-eval nil '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)
1246(equal-eval '(1)
1247    '(multiple-value-list (prog1 (values 1 2) (values 4 5))))
1248
1249;; prog2				- macro
1250(setq temp 1)
1251(eql-eval 3 '(prog2 (incf temp) (incf temp) (incf temp)))
1252(eql-eval 4 'temp)
1253(eql-eval 2 '(prog2 1 (values 2 3 4) 5))
1254(equal-eval '(3)
1255    '(multiple-value-list (prog2 (values 1 2) (values 3 4) (values 5 6))))
1256
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))))
1261(setq a 1)
1262(eq-eval 'here '(if a (progn (setq a nil) 'here) (progn (setq a t) 'there)))
1263(eq-eval nil 'a)
1264
1265;; progv				- special operator
1266(makunbound '*x*)	;; make sure it is not bound
1267(setq *x* 1)
1268(eql-eval 2 '(progv '(*x*) '(2) *x*))
1269(eql-eval 1 '*x*)
1270(equal-eval '(3 4)
1271    '(let ((*x* 3)) (progv '(*x*) '(4) (list *x* (symbol-value '*x*)))))
1272(makunbound '*x*)
1273(defvar *x* 1)
1274(equal-eval '(4 4)
1275    '(let ((*x* 3)) (progv '(*x*) '(4) (list *x* (symbol-value '*x*)))))
1276(equal-eval '(4 4)
1277    '(multiple-value-list
1278	(let ((*x* 3))
1279	     (progv '(*x*) '(4) (values-list (list *x* (symbol-value '*x*)))))))
1280
1281;; push					- macro
1282(setq llst '(nil))
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)
1290
1291;; pushnew				- macro
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))
1302
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)
1315
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)
1322
1323;; rest					- accessor
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*)
1330
1331;; return				- macro
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)))
1338
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))
1342(equal-eval '(1 2)
1343    '(multiple-value-list (block alpha (return-from alpha (values 1 2)) 3)))
1344(eql-eval 2
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)))))
1351
1352;; reverse				- function
1353(setq str (xseq "abc") test str)
1354(equal-test "cba" #'reverse str)
1355(eq-eval test '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)
1361
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*)
1370
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)
1375(eql-test 5
1376    #'search "123"
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")
1382
1383;; set					- function
1384(eql-eval 1 '(setf (symbol-value 'n) 1))
1385(eql-test 2 #'set 'n 2)
1386(eql-test 2 #'symbol-value 'n)
1387(eql-eval 4
1388   '(let ((n 3))
1389	(setq n (+ n 1))
1390	(setf (symbol-value 'n) (* n 10))
1391	(set 'n (+ (symbol-value 'n) n))
1392	n))
1393(eql-eval 44 'n)
1394(defvar *n* 2)
1395(eql-eval 80
1396   '(let ((*n* 3))
1397	(setq *n* (+ *n* 1))
1398	(setf (symbol-value '*n*) (* *n* 10))
1399	(set '*n* (+ (symbol-value '*n*) *n*))
1400	*n*))
1401(eql-eval 2 '*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*)
1412
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")
1425   #'set-difference
1426	'("strawberry" "chocolate" "banana" "lemon" "pistachio" "rhubarb")
1427	'(#\c #\w) :test #'(lambda (s c) (find c s)))
1428
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)
1439
1440;; setf					- macro
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))
1451
1452;; setq					- special form
1453(eql-eval 3 '(setq a 1 b 2 c 3))
1454(eql-eval 1 'a)
1455(eql-eval 2 'b)
1456(eql-eval 3 'c)
1457(eql-eval 7 '(setq a (1+ b) b (1+ a) c (+ a b)))
1458(eql-eval 3 'a)
1459(eql-eval 4 'b)
1460(eql-eval 7 'c)
1461(eq-eval nil '(psetq a 1 b 2 c 3))
1462(eql-eval 1 'a)
1463(eql-eval 2 'b)
1464(eql-eval 3 'c)
1465(equal-eval '(2 1)
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))
1469
1470;; some					- function
1471(eq-test t #'some #'= '(1 2 3 4 5) '(5 4 3 2 1))
1472
1473;; sort					- function
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))))
1481(equalp-test
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)
1502(equalp-eval
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))
1515
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)
1521
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
1533						  :start2 2 :end2 6)
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")
1540
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)
1579
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
1585        ")
1586#+xedit (equal-test "garbanzo beans"
1587    #'nstring-trim '(#\Space #\Tab #\Newline) " garbanzo beans
1588        ")
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")
1605
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))
1611
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)
1620
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)
1629
1630;; svref				- function
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)
1637
1638;; symbol-name				- function
1639(equal-test "TEMP" #'symbol-name 'temp)
1640(equal-test "START" #'symbol-name :start)
1641(error-test #'symbol-name 1)
1642
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)
1667
1668;; symbol-plist				- accessor
1669(setq sym (gensym))
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))
1678
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)))
1685
1686#+xedit	;; incorrect...
1687(progn
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)))
1692    (eql-eval 1 'a)
1693    (eql-eval 3 '(let ((a 2)) (setq a 3) (symbol-value 'a)))
1694    (eql-eval 1 'a)
1695	    ;; declare not yet implement
1696	    (makunbound 'a)
1697    (eql-eval 2 '(let ((a 2)) (setf (symbol-value 'a) 3) a))
1698    (eql-eval 3 'a)
1699    (eql-eval 3 '(symbol-value 'a))
1700	    ;; declare not yet implement
1701	    (makunbound 'a)
1702    (equal-eval '(5 4)
1703	'(multiple-value-list
1704	    (let ((a 4))
1705
1706			;; declare not yet implemented
1707			(defparameter a 3)
1708
1709	      (let ((b (symbol-value 'a)))
1710		(setf (symbol-value 'a) 5)
1711		(values a b)))))
1712    (eql-eval 3 'a)
1713)
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 '()))
1718
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")
1727
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))
1748
1749;; throw				- special operator
1750(equal-eval '(3 9)
1751    '(multiple-value-list
1752	(catch 'result
1753	    (setq i 0 j 0)
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))))
1757
1758;; XXX undefined consequences
1759(eql-eval 2
1760   '(catch 'a
1761      (catch 'b
1762	(unwind-protect (throw 'a 1)
1763	  (throw 'b 2)))))
1764(eq-eval :outer-catch
1765   '(catch 'foo
1766	(setq string (format nil "The inner catch returns ~s."
1767	    (catch 'foo
1768		(unwind-protect (throw 'foo :first-throw)
1769		    (throw 'foo :second-throw)))))
1770         :outer-catch))
1771(equal-eval "The inner catch returns :SECOND-THROW." 'string)
1772
1773;; tree-equal				- function
1774(setq tree1 '(1 (1 2))
1775      tree2 '(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)
1784
1785;; union				- function
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)
1792
1793;; unless				- macro
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))
1800(setq test 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)
1803(setq test nil)
1804(eq-eval nil '(unless t (push 1 test) (push 2 test) (push 3 test)))
1805(eq-eval nil 'test)
1806(eq-eval nil '(when nil (push 1 test) (push 2 test) (push 3 test)))
1807(eq-eval nil '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))
1811   '(let ((x 3))
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)))))
1820
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)))
1827(eql-eval 2 'state)
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
1836(eql-eval 2
1837   '(block a
1838	(block b
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
1843(eql-eval 2
1844   '(catch 'a (catch 'b (unwind-protect (throw 'a 1) (throw 'b 2)))))
1845(eq-eval ':outer-catch
1846   '(catch 'foo
1847	(setq string
1848	    (format nil "The inner catch returns ~s."
1849		(catch 'foo
1850		    (unwind-protect (throw 'foo :first-throw)
1851		    (throw 'foo :second-throw)))))
1852         :outer-catch))
1853(equal-eval "The inner catch returns :SECOND-THROW." 'string)
1854(eql-eval 10
1855   '(catch 'a
1856	(catch 'b
1857	    (unwind-protect (1+ (catch 'a (throw 'b 1)))
1858		(throw 'a 10)))))
1859;; XXX undefined consequences
1860(eql-eval 4
1861   '(catch 'foo
1862       (catch 'bar
1863	   (unwind-protect (throw 'foo 3)
1864	     (throw 'bar 4)
1865	     (print 'xxx)))))
1866(eql-eval 4
1867   '(catch 'bar
1868       (catch 'foo
1869	   (unwind-protect (throw 'foo 3)
1870	     (throw 'bar 4)
1871	     (print 'xxx)))))
1872(eql-eval 5
1873   '(block nil
1874       (let ((x 5))
1875	 (unwind-protect (return)
1876	   (return x)))))
1877
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)
1883
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)))
1890
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))))
1896