summaryrefslogtreecommitdiff
path: root/lisp/test/list.lsp
diff options
context:
space:
mode:
Diffstat (limited to 'lisp/test/list.lsp')
-rw-r--r--lisp/test/list.lsp1895
1 files changed, 1895 insertions, 0 deletions
diff --git a/lisp/test/list.lsp b/lisp/test/list.lsp
new file mode 100644
index 0000000..23f4496
--- /dev/null
+++ b/lisp/test/list.lsp
@@ -0,0 +1,1895 @@
+;;
+;; Copyright (c) 2002 by The XFree86 Project, Inc.
+;;
+;; Permission is hereby granted, free of charge, to any person obtaining a
+;; copy of this software and associated documentation files (the "Software"),
+;; to deal in the Software without restriction, including without limitation
+;; the rights to use, copy, modify, merge, publish, distribute, sublicense,
+;; and/or sell copies of the Software, and to permit persons to whom the
+;; Software is furnished to do so, subject to the following conditions:
+;;
+;; The above copyright notice and this permission notice shall be included in
+;; all copies or substantial portions of the Software.
+;;
+;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL
+;; THE XFREE86 PROJECT BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
+;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF
+;; OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+;; SOFTWARE.
+;;
+;; Except as contained in this notice, the name of the XFree86 Project shall
+;; not be used in advertising or otherwise to promote the sale, use or other
+;; dealings in this Software without prior written authorization from the
+;; XFree86 Project.
+;;
+;; Author: Paulo César Pereira de Andrade
+;;
+;;
+;; $XFree86: xc/programs/xedit/lisp/test/list.lsp,v 1.6 2002/12/06 03:25:29 paulo Exp $
+;;
+
+;; basic lisp function tests
+
+;; Most of the tests are just the examples from the
+;;
+;; Common Lisp HyperSpec (TM)
+;; Copyright 1996-2001, Xanalys Inc. All rights reserved.
+;;
+;; Some tests are hand crafted, to test how the interpreter treats
+;; uncommon arguments or special conditions
+
+
+#|
+ MAJOR PROBLEMS:
+
+ o NIL and T should be always treated as symbols, actually it is
+ legal to say (defun nil (...) ...)
+ o There aren't true uninterned symbols, there are only symbols that
+ did not yet establish the home package, but once one is created, an
+ interned symbol is always returned.
+|#
+
+(defun compare-test (test expect function arguments
+ &aux result (error t) unused error-value)
+ (multiple-value-setq
+ (unused error-value)
+ (ignore-errors
+ (setq result (apply function arguments))
+ (setq error nil)
+ )
+ )
+ (if error
+ (format t "ERROR: (~S~{ ~S~}) => ~S~%" function arguments error-value)
+ (or (funcall test result expect)
+ (format t "(~S~{ ~S~}) => should be ~S not ~S~%"
+ function arguments expect result
+ )
+ )
+ )
+)
+
+(defun compare-eval (test expect form
+ &aux result (error t) unused error-value)
+ (multiple-value-setq
+ (unused error-value)
+ (ignore-errors
+ (setq result (eval form))
+ (setq error nil)
+ )
+ )
+ (if error
+ (format t "ERROR: ~S => ~S~%" form error-value)
+ (or (funcall test result expect)
+ (format t "~S => should be ~S not ~S~%"
+ form expect result
+ )
+ )
+ )
+)
+
+(defun error-test (function &rest arguments &aux result (error t))
+ (ignore-errors
+ (setq result (apply function arguments))
+ (setq error nil)
+ )
+ (or error
+ (format t "ERROR: no error for (~S~{ ~S~}), result was ~S~%"
+ function arguments result)
+ )
+)
+
+(defun error-eval (form &aux result (error t))
+ (ignore-errors
+ (setq result (eval form))
+ (setq error nil)
+ )
+ (or error
+ (format t "ERROR: no error for ~S, result was ~S~%" form result)
+ )
+)
+
+(defun eq-test (expect function &rest arguments)
+ (compare-test #'eq expect function arguments))
+
+(defun eql-test (expect function &rest arguments)
+ (compare-test #'eql expect function arguments))
+
+(defun equal-test (expect function &rest arguments)
+ (compare-test #'equal expect function arguments))
+
+(defun equalp-test (expect function &rest arguments)
+ (compare-test #'equalp expect function arguments))
+
+
+(defun eq-eval (expect form)
+ (compare-eval #'eq expect form))
+
+(defun eql-eval (expect form)
+ (compare-eval #'eql expect form))
+
+(defun equal-eval (expect form)
+ (compare-eval #'equal expect form))
+
+(defun equalp-eval (expect form)
+ (compare-eval #'equalp expect form))
+
+;; clisp treats strings loaded from a file as constants
+(defun xseq (sequence)
+ #+clisp (if *load-pathname* (copy-seq sequence) sequence)
+ #-clisp sequence
+)
+
+;; apply - function
+(equal-test '((+ 2 3) . 4) #'apply 'cons '((+ 2 3) 4))
+(eql-test -1 #'apply #'- '(1 2))
+(eql-test 7 #'apply #'max 3 5 '(2 7 3))
+(error-test #'apply #'+ 1)
+(error-test #'apply #'+ 1 2)
+(error-test #'apply #'+ 1 . 2)
+(error-test #'apply #'+ 1 2 3)
+(error-test #'apply #'+ 1 2 . 3)
+(eql-test 6 #'apply #'+ 1 2 3 ())
+
+;; eq - function
+(eq-eval t '(let* ((a #\a) (b a)) (eq a b)))
+(eq-test t #'eq 'a 'a)
+(eq-test nil #'eq 'a 'b)
+(eq-eval t '(eq #1=1 #1#))
+(eq-test nil #'eq "abc" "abc")
+(setq a '('x #c(1 2) #\z))
+(eq-test nil #'eq a (copy-seq a))
+
+;; eql - function
+(eq-test t #'eql 1 1)
+(eq-test t #'eql 1.3d0 1.3d0)
+(eq-test nil #'eql 1 1d0)
+(eq-test t #'eql #c(1 -5) #c(1 -5))
+(eq-test t #'eql 'a 'a)
+(eq-test nil #'eql :a 'a)
+(eq-test t #'eql #c(5d0 0) 5d0)
+(eq-test nil #'eql #c(5d0 0d0) 5d0)
+(eq-test nil #'eql "abc" "abc")
+(equal-eval '(1 5/6 #p"test" #\#) '(setq a '(1 5/6 #p"test" #\#)))
+(eq-test nil #'eql a (copy-seq a))
+
+(setf
+ hash0 (make-hash-table)
+ hash1 (make-hash-table)
+ (gethash 1 hash0) 2
+ (gethash 1 hash1) 2
+ (gethash :foo hash0) :bar
+ (gethash :foo hash1) :bar
+)
+(defstruct test a b c)
+(setq
+ struc0 (make-test :a 1 :b 2 :c #\c)
+ struc1 (make-test :a 1 :b 2 :c #\c)
+)
+
+;; equal - function
+(eq-test t #'equal "abc" "abc")
+(eq-test t #'equal 1 1)
+(eq-test t #'equal #c(1 2) #c(1 2))
+(eq-test nil #'equal #c(1 2) #c(1 2d0))
+(eq-test t #'equal #\A #\A)
+(eq-test nil #'equal #\A #\a)
+(eq-test nil #'equal "abc" "Abc")
+(equal-eval '(1 2 3/5 #\a) '(setq a '(1 2 3/5 #\a)))
+(eq-test t #'equal a (copy-seq a))
+(eq-test nil #'equal hash0 hash1)
+(eq-test nil #'equal struc0 struc1)
+(eq-test nil #'equal #(1 2 3 4) #(1 2 3 4))
+
+;; equalp - function
+(eq-test t #'equalp hash0 hash1)
+(setf
+ (gethash 2 hash0) "FoObAr"
+ (gethash 2 hash1) "fOoBaR"
+)
+(eq-test t #'equalp hash0 hash1)
+(setf
+ (gethash 3 hash0) 3
+ (gethash 3d0 hash1) 3
+)
+(eq-test nil #'equalp hash0 hash1)
+(eq-test t #'equalp struc0 struc1)
+(setf
+ (test-a struc0) #\a
+ (test-a struc1) #\A
+)
+(eq-test t #'equalp struc0 struc1)
+(setf
+ (test-b struc0) 'test
+ (test-b struc1) :test
+)
+(eq-test nil #'equalp struc0 struc1)
+(eq-test t #'equalp #c(1/2 1d0) #c(0.5d0 1))
+(eq-test t #'equalp 1 1d0)
+(eq-test t #'equalp #(1 2 3 4) #(1 2 3 4))
+(eq-test t #'equalp #(1 #\a 3 4d0) #(1 #\A 3 4))
+
+;; acons - function
+(equal-test '((1 . "one")) #'acons 1 "one" nil)
+(equal-test '((2 . "two") (1 . "one")) #'acons 2 "two" '((1 . "one")))
+
+;; adjoin - function
+(equal-test '(nil) #'adjoin nil nil)
+(equal-test '(a) #'adjoin 'a nil)
+(equal-test '(1 2 3) #'adjoin 1 '(1 2 3))
+(equal-test '(1 2 3) #'adjoin 2 '(1 2 3))
+(equal-test '((1) (1) (2) (3)) #'adjoin '(1) '((1) (2) (3)))
+(equal-test '((1) (2) (3)) #'adjoin '(1) '((1) (2) (3)) :key #'car)
+(error-test #'adjoin nil 1)
+
+;; alpha-char-p - function
+(eq-test t #'alpha-char-p #\a)
+(eq-test nil #'alpha-char-p #\5)
+(error-test #'alpha-char-p 'a)
+
+;; alphanumericp - function
+(eq-test t #'alphanumericp #\Z)
+(eq-test t #'alphanumericp #\8)
+(eq-test nil #'alphanumericp #\#)
+
+;; and - macro
+(eql-eval 1 '(setq temp1 1 temp2 1 temp3 1))
+(eql-eval 2 '(and (incf temp1) (incf temp2) (incf temp3)))
+(eq-eval t '(and (eql 2 temp1) (eql 2 temp2) (eql 2 temp3)))
+(eql-eval 1 '(decf temp3))
+(eq-eval nil '(and (decf temp1) (decf temp2) (eq temp3 'nil) (decf temp3)))
+(eq-eval t '(and (eql temp1 temp2) (eql temp2 temp3)))
+(eq-eval t '(and))
+(equal-eval '(1 2 3) '(multiple-value-list (and (values 'a) (values 1 2 3))))
+(equal-eval nil '(and (values) t))
+
+;; append - function
+(equal-test '(a b c d e f g) #'append '(a b c) '(d e f) '() '(g))
+(equal-test '(a b c . d) #'append '(a b c) 'd)
+(eq-test nil #'append)
+(eql-test 'a #'append nil 'a)
+(error-test #'append 1 2)
+
+;; assoc - function
+(equal-test '(1 . "one") #'assoc 1 '((2 . "two") (1 . "one")))
+(equal-test '(2 . "two") #'assoc 2 '((1 . "one") (2 . "two")))
+(eq-test nil #'assoc 1 nil)
+(equal-test '(2 . "two") #'assoc-if #'evenp '((1 . "one") (2 . "two")))
+(equal-test '(3 . "three") #'assoc-if-not #'(lambda(x) (< x 3))
+ '((1 . "one") (2 . "two") (3 . "three")))
+(equal-test '("two" . 2) #'assoc #\o '(("one" . 1) ("two" . 2) ("three" . 3))
+ :key #'(lambda (x) (char x 2)))
+(equal-test '(a . b) #'assoc 'a '((x . a) (y . b) (a . b) (a . c)))
+
+;; atom - function
+(eq-test t #'atom 1)
+(eq-test t #'atom '())
+(eq-test nil #'atom '(1))
+(eq-test t #'atom 'a)
+
+;; block - special operator
+(eq-eval nil '(block empty))
+(eql-eval 2 '(let ((x 1))
+ (block stop (setq x 2) (return-from stop) (setq x 3)) x))
+(eql-eval 2 '(block twin (block twin (return-from twin 1)) 2))
+
+;; both-case-p - function
+(eq-test t #'both-case-p #\a)
+(eq-test nil #'both-case-p #\1)
+
+;; boundp - function
+(eql-eval 1 '(setq x 1))
+(eq-test t #'boundp 'x)
+(makunbound 'x)
+(eq-test nil #'boundp 'x)
+(eq-eval nil '(let ((x 1)) (boundp 'x)))
+(error-test #'boundp 1)
+
+;; butlast, nbutlast - function
+(setq x '(1 2 3 4 5 6 7 8 9))
+(equal-test '(1 2 3 4 5 6 7 8) #'butlast x)
+(equal-eval '(1 2 3 4 5 6 7 8 9) 'x)
+(eq-eval nil '(nbutlast x 9))
+(equal-test '(1) #'nbutlast x 8)
+(equal-eval '(1) 'x)
+(eq-test nil #'butlast nil)
+(eq-test nil #'nbutlast '())
+(error-test #'butlast 1 2)
+(error-test #'butlast -1 '(1 2))
+
+;; car, cdr, caar ... - function
+(eql-test 1 #'car '(1 2))
+(eql-test 2 #'cdr '(1 . 2))
+(eql-test 1 #'caar '((1 2)))
+(eql-test 2 #'cadr '(1 2))
+(eql-test 2 #'cdar '((1 . 2)))
+(eql-test 3 #'cddr '(1 2 . 3))
+(eql-test 1 #'caaar '(((1 2))))
+(eql-test 2 #'caadr '(1 (2 3)))
+(eql-test 2 #'cadar '((1 2) 2 3))
+(eql-test 3 #'caddr '(1 2 3 4))
+(eql-test 2 #'cdaar '(((1 . 2)) 3))
+(eql-test 3 #'cdadr '(1 (2 . 3) 4))
+(eql-test 3 #'cddar '((1 2 . 3) 3))
+(eql-test 4 #'cdddr '(1 2 3 . 4))
+(eql-test 1 #'caaaar '((((1 2)))))
+(eql-test 2 #'caaadr '(1 ((2))))
+(eql-test 2 #'caadar '((1 (2)) 3))
+(eql-test 3 #'caaddr '(1 2 (3 4)))
+(eql-test 2 #'cadaar '(((1 2)) 3))
+(eql-test 3 #'cadadr '(1 (2 3) 4))
+(eql-test 3 #'caddar '((1 2 3) 4))
+(eql-test 4 #'cadddr '(1 2 3 4 5))
+(eql-test 2 #'cdaaar '((((1 . 2))) 3))
+(eql-test 3 #'cdaadr '(1 ((2 . 3)) 4))
+(eql-test 3 #'cdadar '((1 (2 . 3)) 4))
+(eql-test 4 #'cdaddr '(1 2 (3 . 4) 5))
+(eql-test 3 #'cddaar '(((1 2 . 3)) 4))
+(eql-test 4 #'cddadr '(1 (2 3 . 4) 5))
+(eql-test 4 #'cdddar '((1 2 3 . 4) 5))
+(eql-test 5 #'cddddr '(1 2 3 4 . 5))
+
+;; first ... tenth, rest - function
+(eql-test 2 #'rest '(1 . 2))
+(eql-test 1 #'first '(1 2))
+(eql-test 2 #'second '(1 2 3))
+(eql-test 2 #'second '(1 2 3))
+(eql-test 3 #'third '(1 2 3 4))
+(eql-test 4 #'fourth '(1 2 3 4 5))
+(eql-test 5 #'fifth '(1 2 3 4 5 6))
+(eql-test 6 #'sixth '(1 2 3 4 5 6 7))
+(eql-test 7 #'seventh '(1 2 3 4 5 6 7 8))
+(eql-test 8 #'eighth '(1 2 3 4 5 6 7 8 9))
+(eql-test 9 #'ninth '(1 2 3 4 5 6 7 8 9 10))
+(eql-test 10 #'tenth '(1 2 3 4 5 6 7 8 9 10 11))
+(error-test #'car 1)
+(error-test #'car #c(1 2))
+(error-test #'car #(1 2))
+
+;; case - macro
+(eql-eval t '(let ((a 1)) (case a ((4 5 6) nil) ((3 2 1) t) (otherwise :error))))
+(eql-eval t '(let ((a 1)) (case a ((3 2) nil) (1 t) (t :error))))
+(error-eval '(let ((a 1)) (case a (2 :error) (t nil) (otherwise t))))
+(error-eval '(let ((a 1)) (case a (2 :error) (otherwise t) (t nil))))
+
+;; catch - special operator
+(eql-eval 3 '(catch 'dummy-tag 1 2 (throw 'dummy-tag 3) 4))
+(eql-eval 4 '(catch 'dummy-tag 1 2 3 4))
+(eq-eval 'throw-back '(defun throw-back (tag) (throw tag t)))
+(eq-eval t '(catch 'dummy-tag (throw-back 'dummy-tag) 2))
+
+;; char - function
+(eql-test #\a #'char "abc" 0)
+(eql-test #\b #'char "abc" 1)
+(error-test #'char "abc" 3)
+
+;; char-* - function
+(eq-test nil #'alpha-char-p #\3)
+(eq-test t #'alpha-char-p #\y)
+(eql-test #\a #'char-downcase #\a)
+(eql-test #\a #'char-downcase #\a)
+(eql-test #\1 #'char-downcase #\1)
+(error-test #'char-downcase 1)
+(eql-test #\A #'char-upcase #\a)
+(eql-test #\A #'char-upcase #\A)
+(eql-test #\1 #'char-upcase #\1)
+(error-test #'char-upcase 1)
+(eq-test t #'lower-case-p #\a)
+(eq-test nil #'lower-case-p #\A)
+(eq-test t #'upper-case-p #\W)
+(eq-test nil #'upper-case-p #\w)
+(eq-test t #'both-case-p #\x)
+(eq-test nil #'both-case-p #\%)
+(eq-test t #'char= #\d #\d)
+(eq-test t #'char-equal #\d #\d)
+(eq-test nil #'char= #\A #\a)
+(eq-test t #'char-equal #\A #\a)
+(eq-test nil #'char= #\d #\x)
+(eq-test nil #'char-equal #\d #\x)
+(eq-test nil #'char= #\d #\D)
+(eq-test t #'char-equal #\d #\D)
+(eq-test nil #'char/= #\d #\d)
+(eq-test nil #'char-not-equal #\d #\d)
+(eq-test nil #'char/= #\d #\d)
+(eq-test nil #'char-not-equal #\d #\d)
+(eq-test t #'char/= #\d #\x)
+(eq-test t #'char-not-equal #\d #\x)
+(eq-test t #'char/= #\d #\D)
+(eq-test nil #'char-not-equal #\d #\D)
+(eq-test t #'char= #\d #\d #\d #\d)
+(eq-test t #'char-equal #\d #\d #\d #\d)
+(eq-test nil #'char= #\d #\D #\d #\d)
+(eq-test t #'char-equal #\d #\D #\d #\d)
+(eq-test nil #'char/= #\d #\d #\d #\d)
+(eq-test nil #'char-not-equal #\d #\d #\d #\d)
+(eq-test nil #'char/= #\d #\d #\D #\d)
+(eq-test nil #'char-not-equal #\d #\d #\D #\d)
+(eq-test nil #'char= #\d #\d #\x #\d)
+(eq-test nil #'char-equal #\d #\d #\x #\d)
+(eq-test nil #'char/= #\d #\d #\x #\d)
+(eq-test nil #'char-not-equal #\d #\d #\x #\d)
+(eq-test nil #'char= #\d #\y #\x #\c)
+(eq-test nil #'char-equal #\d #\y #\x #\c)
+(eq-test t #'char/= #\d #\y #\x #\c)
+(eq-test t #'char-not-equal #\d #\y #\x #\c)
+(eq-test nil #'char= #\d #\c #\d)
+(eq-test nil #'char-equal #\d #\c #\d)
+(eq-test nil #'char/= #\d #\c #\d)
+(eq-test nil #'char-not-equal #\d #\c #\d)
+(eq-test t #'char< #\d #\x)
+(eq-test t #'char-lessp #\d #\x)
+(eq-test t #'char-lessp #\d #\X)
+(eq-test t #'char-lessp #\D #\x)
+(eq-test t #'char-lessp #\D #\X)
+(eq-test t #'char<= #\d #\x)
+(eq-test t #'char-not-greaterp #\d #\x)
+(eq-test t #'char-not-greaterp #\d #\X)
+(eq-test t #'char-not-greaterp #\D #\x)
+(eq-test t #'char-not-greaterp #\D #\X)
+(eq-test nil #'char< #\d #\d)
+(eq-test nil #'char-lessp #\d #\d)
+(eq-test nil #'char-lessp #\d #\D)
+(eq-test nil #'char-lessp #\D #\d)
+(eq-test nil #'char-lessp #\D #\D)
+(eq-test t #'char<= #\d #\d)
+(eq-test t #'char-not-greaterp #\d #\d)
+(eq-test t #'char-not-greaterp #\d #\D)
+(eq-test t #'char-not-greaterp #\D #\d)
+(eq-test t #'char-not-greaterp #\D #\D)
+(eq-test t #'char< #\a #\e #\y #\z)
+(eq-test t #'char-lessp #\a #\e #\y #\z)
+(eq-test t #'char-lessp #\a #\e #\y #\Z)
+(eq-test t #'char-lessp #\a #\E #\y #\z)
+(eq-test t #'char-lessp #\A #\e #\y #\Z)
+(eq-test t #'char<= #\a #\e #\y #\z)
+(eq-test t #'char-not-greaterp #\a #\e #\y #\z)
+(eq-test t #'char-not-greaterp #\a #\e #\y #\Z)
+(eq-test t #'char-not-greaterp #\A #\e #\y #\z)
+(eq-test nil #'char< #\a #\e #\e #\y)
+(eq-test nil #'char-lessp #\a #\e #\e #\y)
+(eq-test nil #'char-lessp #\a #\e #\E #\y)
+(eq-test nil #'char-lessp #\A #\e #\E #\y)
+(eq-test t #'char<= #\a #\e #\e #\y)
+(eq-test t #'char-not-greaterp #\a #\e #\e #\y)
+(eq-test t #'char-not-greaterp #\a #\E #\e #\y)
+(eq-test t #'char> #\e #\d)
+(eq-test t #'char-greaterp #\e #\d)
+(eq-test t #'char-greaterp #\e #\D)
+(eq-test t #'char-greaterp #\E #\d)
+(eq-test t #'char-greaterp #\E #\D)
+(eq-test t #'char>= #\e #\d)
+(eq-test t #'char-not-lessp #\e #\d)
+(eq-test t #'char-not-lessp #\e #\D)
+(eq-test t #'char-not-lessp #\E #\d)
+(eq-test t #'char-not-lessp #\E #\D)
+(eq-test t #'char> #\d #\c #\b #\a)
+(eq-test t #'char-greaterp #\d #\c #\b #\a)
+(eq-test t #'char-greaterp #\d #\c #\b #\A)
+(eq-test t #'char-greaterp #\d #\c #\B #\a)
+(eq-test t #'char-greaterp #\d #\C #\b #\a)
+(eq-test t #'char-greaterp #\D #\C #\b #\a)
+(eq-test t #'char>= #\d #\c #\b #\a)
+(eq-test t #'char-not-lessp #\d #\c #\b #\a)
+(eq-test t #'char-not-lessp #\d #\c #\b #\A)
+(eq-test t #'char-not-lessp #\D #\c #\b #\a)
+(eq-test t #'char-not-lessp #\d #\C #\B #\a)
+(eq-test nil #'char> #\d #\d #\c #\a)
+(eq-test nil #'char-greaterp #\d #\d #\c #\a)
+(eq-test nil #'char-greaterp #\d #\d #\c #\A)
+(eq-test nil #'char-greaterp #\d #\D #\c #\a)
+(eq-test nil #'char-greaterp #\d #\D #\C #\a)
+(eq-test t #'char>= #\d #\d #\c #\a)
+(eq-test t #'char-not-lessp #\d #\d #\c #\a)
+(eq-test t #'char-not-lessp #\d #\D #\c #\a)
+(eq-test t #'char-not-lessp #\D #\d #\c #\a)
+(eq-test t #'char-not-lessp #\D #\D #\c #\A)
+(eq-test nil #'char> #\e #\d #\b #\c #\a)
+(eq-test nil #'char-greaterp #\e #\d #\b #\c #\a)
+(eq-test nil #'char-greaterp #\E #\d #\b #\c #\a)
+(eq-test nil #'char-greaterp #\e #\D #\b #\c #\a)
+(eq-test nil #'char-greaterp #\E #\d #\B #\c #\A)
+(eq-test nil #'char>= #\e #\d #\b #\c #\a)
+(eq-test nil #'char-not-lessp #\e #\d #\b #\c #\a)
+(eq-test nil #'char-not-lessp #\e #\d #\b #\c #\A)
+(eq-test nil #'char-not-lessp #\E #\d #\B #\c #\a)
+
+;; char-code - function
+;; XXX assumes ASCII
+(eql-test 49 #'char-code #\1)
+(eql-test 90 #'char-code #\Z)
+(eql-test 127 #'char-code #\Delete)
+(eql-test 27 #'char-code #\Escape)
+(eql-test 13 #'char-code #\Return)
+(eql-test 0 #'char-code #\Null)
+(eql-test 10 #'char-code #\Newline)
+(error-test #'char-code 65)
+
+;; character - function
+(eql-test #\a #'character #\a)
+(eql-test #\a #'character "a")
+(eql-test #\A #'character 'a)
+
+;; XXX assumes ASCII, and should be allowed to fail?
+(eql-test #\A #'character 65)
+
+(error-test #'character 1/2)
+(error-test #'character "abc")
+(error-test #'character :test)
+(eq-test #\T #'character t)
+(error-test #'character nil)
+
+;; characterp - function
+(eq-test t #'characterp #\a)
+(eq-test nil #'characterp 1)
+(eq-test nil #'characterp 1/2)
+(eq-test nil #'characterp 'a)
+(eq-test nil #'characterp '`a)
+
+
+
+
+;; TODO coerce
+
+
+
+
+;; cond - macro
+(eql-eval 2 '(let ((a 1)) (cond ((= a 2) 1) ((= a 1) 2) ((= a 0) 1) (t nil))))
+(eql-eval nil '(let ((a 1)) (cond ((= a 2) 1) (t nil) ((= a 1) 2) ((= a 0) 1))))
+
+;; consp - function (predicate)
+(eq-test t #'consp '(1 2))
+(eq-test t #'consp '(1 . 2))
+(eq-test nil #'consp nil)
+(eq-test nil #'consp 1)
+
+;; constantp - function (predicate)
+(eq-test t #'constantp 1)
+(eq-test t #'constantp #\x)
+(eq-test t #'constantp :test)
+(eq-test nil #'constantp 'test)
+(eq-test t #'constantp ''1)
+(eq-test t #'constantp '(quote 1))
+(eq-test t #'constantp "string")
+(eq-test t #'constantp #c(1 2))
+(eq-test t #'constantp #(1 2))
+(eq-test nil #'constantp #p"test")
+(eq-test nil #'constantp '(1 2))
+(eq-test nil #'constantp (make-hash-table))
+(eq-test nil #'constantp *package*)
+(eq-test nil #'constantp *standard-input*)
+
+;; copy-list, copy-alist and copy-tree - function
+(equal-test '(1 2) #'copy-list '(1 2))
+(equal-test '(1 . 2) #'copy-list '(1 . 2))
+(eq-test nil #'copy-list nil)
+(error-test #'copy-list 1)
+(equal-eval '(1 (2 3)) '(setq x '(1 (2 3))))
+(equal-eval x '(setq y (copy-list x)))
+(equal-test '("one" (2 3)) #'rplaca x "one")
+(eql-test 1 #'car y)
+(equal-test '("two" 3) #'rplaca (cadr x) "two")
+(eq-test (caadr x) #'caadr y)
+(equal-eval '(1 (2 3) 4) '(setq a '(1 (2 3) 4) b (copy-list a)))
+(eq-eval t '(eq (cadr a) (cadr b)))
+(eq-eval t '(eq (car a) (car b)))
+(setq a '(1 (2 3) 4) b (copy-alist a))
+(eq-eval nil '(eq (cadr a) (cadr b)))
+(eq-eval t '(eq (car a) (car b)))
+(eq-test nil #'copy-alist nil)
+(eq-test nil #'copy-list nil)
+(error-test #'copy-list 1)
+(setq a '(1 (2 (3))))
+(setq as-list (copy-list a))
+(setq as-alist (copy-alist a))
+(setq as-tree (copy-tree a))
+(eq-eval t '(eq (cadadr a) (cadadr as-list)))
+(eq-eval t '(eq (cadadr a) (cadadr as-alist)))
+(eq-eval nil '(eq (cadadr a) (cadadr as-tree)))
+
+;; decf - macro
+(setq n 2)
+(eql-eval 1 '(decf n))
+(eql-eval 1 'n)
+(setq n -2147483648)
+(eql-eval -2147483649 '(decf n))
+(eql-eval -2147483649 'n)
+(setq n 0)
+(eql-eval -0.5d0 '(decf n 0.5d0))
+(eql-eval -0.5d0 'n)
+(setq n 1)
+(eql-eval 1/2 '(decf n 1/2))
+(eql-eval 1/2 'n)
+
+;; delete and remove - function
+(setq a '(1 3 4 5 9) b a)
+(equal-test '(1 3 5 9) #'remove 4 a)
+(eq-eval t '(eq a b))
+(setq a (delete 4 a))
+(equal-eval '(1 3 5 9) 'a)
+(setq a '(1 2 4 1 3 4 5) b a)
+(equal-test '(1 2 1 3 5) #'remove 4 a)
+(eq-eval t '(eq a b))
+(equal-test '(1 2 1 3 4 5) #'remove 4 a :count 1)
+(eq-eval t '(eq a b))
+(equal-test '(1 2 4 1 3 5) #'remove 4 a :count 1 :from-end t)
+(eq-eval t '(eq a b))
+(equal-test '(4 3 4 5) #'remove 3 a :test #'>)
+(eq-eval t '(eq a b))
+(setq a (delete 4 '(1 2 4 1 3 4 5)))
+(equal-eval '(1 2 1 3 5) 'a)
+(setq a (delete 4 '(1 2 4 1 3 4 5) :count 1))
+(equal-eval '(1 2 1 3 4 5) 'a)
+(setq a (delete 4 '(1 2 4 1 3 4 5) :count 1 :from-end t))
+(equal-eval '(1 2 4 1 3 5) 'a)
+(equal-test "abc" #'delete-if #'digit-char-p "a1b2c3")
+(equal-test "123" #'delete-if-not #'digit-char-p "a1b2c3")
+(eq-test nil #'delete 1 nil)
+(eq-test nil #'remove 1 nil)
+(setq a '(1 2 3 4 :test 5 6 7 8) b a)
+(equal-test '(1 2 :test 7 8) #'remove-if #'numberp a :start 2 :end 7)
+(eq-eval t '(eq a b))
+(setq a (delete-if #'numberp a :start 2 :end 7))
+(equal-eval '(1 2 :test 7 8) 'a)
+
+;; digit-char - function
+(eql-test #\0 #'digit-char 0)
+(eql-test #\A #'digit-char 10 11)
+(eq-test nil #'digit-char 10 10)
+(eql-test 35 #'digit-char-p #\z 36)
+(error-test #'digit-char #\a)
+(error-test #'digit-char-p 1/2)
+
+
+
+;; TODO directory (known to have problems with parameters like "../*/../*/")
+
+
+
+;; elt - function
+(eql-test #\a #'elt "xabc" 1)
+(eql-test 3 #'elt '(0 1 2 3) 3)
+(error-test #'elt nil 0)
+
+;; endp - function
+(eql-test t #'endp nil)
+(error-test #'endp t)
+(eql-test nil #'endp '(1 . 2))
+(error-test #'endp #(1 2))
+
+;; every - function
+(eql-test t #'every 'not-used ())
+(eql-test t #'every #'characterp "abc")
+(eql-test nil #'every #'< '(1 2 3) '(4 5 6) #(7 8 -1))
+(eql-test t #'every #'< '(1 2 3) '(4 5 6) #(7 8))
+
+;; fboundp and fmakunbound - function
+(eq-test t #'fboundp 'car)
+(eq-eval 'test '(defun test ()))
+(eq-test t #'fboundp 'test)
+(eq-test 'test #'fmakunbound 'test)
+(eq-test nil #'fboundp 'test)
+(eq-eval 'test '(defmacro test (x) x))
+(eq-test t #'fboundp 'test)
+(eq-test 'test #'fmakunbound 'test)
+
+;; fill - function
+(setq x (list 1 2 3 4))
+(equal-test '((4 4 4 4) (4 4 4 4) (4 4 4 4) (4 4 4 4)) #'fill x '(4 4 4 4))
+(eq-eval t '(eq (car x) (cadr x)))
+(equalp-test '#(a z z d e) #'fill '#(a b c d e) 'z :start 1 :end 3)
+(equal-test "012ee" #'fill (xseq "01234") #\e :start 3)
+(error-test #'fill 1 #\a)
+
+;; find - function
+(eql-test #\Space #'find #\d "here are some letters that can be looked at" :test #'char>)
+(eql-test 3 #'find-if #'oddp '(1 2 3 4 5) :end 3 :from-end t)
+(eq-test nil #'find-if-not #'complexp '#(3.5 2 #C(1.0 0.0) #C(0.0 1.0)) :start 2)
+(eq-test nil #'find 1 "abc")
+(error-test #'find 1 #c(1 2))
+
+;; find-symbol - function
+(equal-eval '(nil nil)
+ '(multiple-value-list (find-symbol "NEVER-BEFORE-USED")))
+(equal-eval '(nil nil)
+ '(multiple-value-list (find-symbol "NEVER-BEFORE-USED")))
+(setq test (multiple-value-list (intern "NEVER-BEFORE-USED")))
+(equal-eval test '(read-from-string "(never-before-used nil)"))
+(equal-eval '(never-before-used :internal)
+ '(multiple-value-list (intern "NEVER-BEFORE-USED")))
+(equal-eval '(never-before-used :internal)
+ '(multiple-value-list (find-symbol "NEVER-BEFORE-USED")))
+(equal-eval '(nil nil)
+ '(multiple-value-list (find-symbol "never-before-used")))
+(equal-eval '(car :inherited)
+ '(multiple-value-list (find-symbol "CAR" 'common-lisp-user)))
+(equal-eval '(car :external)
+ '(multiple-value-list (find-symbol "CAR" 'common-lisp)))
+;; XXX these will generate wrong results, NIL is not really a symbol
+;; currently in the interpreter
+(equal-eval '(nil :inherited)
+ '(multiple-value-list (find-symbol "NIL" 'common-lisp-user)))
+(equal-eval '(nil :external)
+ '(multiple-value-list (find-symbol "NIL" 'common-lisp)))
+(setq test (multiple-value-list
+ (find-symbol "NIL" (prog1 (make-package "JUST-TESTING" :use '())
+ (intern "NIL" "JUST-TESTING")))))
+(equal-eval (read-from-string "(just-testing::nil :internal)") 'test)
+(eq-eval t '(export 'just-testing::nil 'just-testing))
+(equal-eval '(just-testing:nil :external)
+ '(multiple-value-list (find-symbol "NIL" 'just-testing)))
+
+#+xedit (equal-eval '(nil nil)
+ '(multiple-value-list (find-symbol "NIL" "KEYWORD")))
+#|
+;; optional result of previous form:
+(equal-eval '(:nil :external)
+ '(multiple-value-list (find-symbol "NIL" "KEYWORD")))
+|#
+
+
+
+;; funcall - function
+(eql-test 6 #'funcall #'+ 1 2 3)
+(eql-test 1 #'funcall #'car '(1 2 3))
+(equal-test '(1 2 3) #'funcall #'list 1 2 3)
+
+
+
+;; TODO properly implement ``function''
+
+
+
+;; functionp - function (predicate)
+(eq-test nil #'functionp 'append)
+(eq-test t #'functionp #'append)
+(eq-test nil #'functionp '(lambda (x) (* x x)))
+(eq-test t #'functionp #'(lambda (x) (* x x)))
+(eq-test t #'functionp (symbol-function 'append))
+(eq-test nil #'functionp 1)
+(eq-test nil #'functionp nil)
+
+;; gensym - function
+(setq sym1 (gensym))
+(eq-test nil #'symbol-package sym1)
+(setq sym1 (gensym 100))
+(setq sym2 (gensym 100))
+(eq-test nil #'eq sym1 sym2)
+(eq-test nil #'equalp (gensym) (gensym))
+
+;; get - accessor
+(defun make-person (first-name last-name)
+ (let ((person (gensym "PERSON")))
+ (setf (get person 'first-name) first-name)
+ (setf (get person 'last-name) last-name)
+ person))
+(eq-eval '*john* '(defvar *john* (make-person "John" "Dow")))
+(eq-eval '*sally* '(defvar *sally* (make-person "Sally" "Jones")))
+(equal-eval "John" '(get *john* 'first-name))
+(equal-eval "Jones" '(get *sally* 'last-name))
+(defun marry (man woman married-name)
+ (setf (get man 'wife) woman)
+ (setf (get woman 'husband) man)
+ (setf (get man 'last-name) married-name)
+ (setf (get woman 'last-name) married-name)
+ married-name)
+(equal-eval "Dow-Jones" '(marry *john* *sally* "Dow-Jones"))
+(equal-eval "Dow-Jones" '(get *john* 'last-name))
+(equal-eval "Sally" '(get (get *john* 'wife) 'first-name))
+(equal-eval `(wife ,*sally* last-name "Dow-Jones" first-name "John")
+ '(symbol-plist *john*))
+(eq-eval 'age
+ '(defmacro age (person &optional (default ''thirty-something))
+ `(get ,person 'age ,default)))
+(eq-eval 'thirty-something '(age *john*))
+(eql-eval 20 '(age *john* 20))
+(eql-eval 25 '(setf (age *john*) 25))
+(eql-eval 25 '(age *john*))
+(eql-eval 25 '(age *john* 20))
+
+;; graphic-char-p - function
+(eq-test t #'graphic-char-p #\a)
+(eq-test t #'graphic-char-p #\Space)
+(eq-test nil #'graphic-char-p #\Newline)
+(eq-test nil #'graphic-char-p #\Tab)
+(eq-test nil #'graphic-char-p #\Rubout)
+
+;; if - special operator
+(eq-eval nil '(if nil t))
+(eq-eval nil '(if t nil t))
+(eq-eval nil '(if nil t nil))
+(eq-eval nil '(if nil t (if nil (if nil t) nil)))
+
+;; incf - macro
+(setq n 1)
+(eql-eval 2 '(incf n))
+(eql-eval 2 'n)
+(setq n 2147483647)
+(eql-eval 2147483648 '(incf n))
+(eql-eval 2147483648 'n)
+(setq n 0)
+(eql-eval 0.5d0 '(incf n 0.5d0))
+(eql-eval 0.5d0 'n)
+(setq n 1)
+(eql-eval 3/2 '(incf n 1/2))
+(eql-eval 3/2 'n)
+
+;; intersection - function
+(setq list1 (list 1 1 2 3 4 'a 'b 'c "A" "B" "C" "d")
+ list2 (list 1 4 5 'b 'c 'd "a" "B" "c" "D"))
+(equal-test '(1 1 4 b c) #'intersection list1 list2)
+(equal-test '(1 1 4 b c "B") #'intersection list1 list2 :test 'equal)
+(equal-test '(1 1 4 b c "A" "B" "C" "d")
+ #'intersection list1 list2 :test #'equalp)
+(setq list1 (nintersection list1 list2))
+(equal-eval '(1 1 4 b c) 'list1)
+(setq list1 (copy-list '((1 . 2) (2 . 3) (3 . 4) (4 . 5))))
+(setq list2 (copy-list '((1 . 3) (2 . 4) (3 . 6) (4 . 8))))
+(equal-test '((2 . 3) (3 . 4)) #'nintersection list1 list2 :key #'cdr)
+
+;; keywordp - function (predicate)
+(eq-test t #'keywordp :test)
+(eq-test nil #'keywordp 'test)
+(eq-test nil #'keywordp '#:test)
+(eq-test nil #'keywordp 1)
+(eq-test nil #'keywordp #'keywordp)
+(eq-test nil #'keywordp nil)
+
+;; last - function
+(equal-test '(3) #'last '(1 2 3))
+(equal-test '(2 . 3) #'last '(1 2 . 3))
+(eq-test nil #'last nil)
+(eql-test () #'last '(1 2 3) 0)
+(setq a '(1 . 2))
+(eql-test 2 #'last a 0)
+(eq-test a #'last a 1)
+(eq-test a #'last a 2)
+(eq-test t #'last t)
+(equal-test #c(1 2) #'last #c(1 2))
+(equalp-test #(1 2 3) #'last #(1 2 3))
+
+;; length - function
+(eql-test 3 #'length "abc")
+(eql-test 0 #'length nil)
+(eql-test 1 #'length '(1 . 2))
+(eql-test 2 #'length #(1 2))
+(error-test #'length #c(1 2))
+(error-test #'length t)
+
+;; let - special operator
+(eql-eval 2 '(setq a 1 b 2))
+(eql-eval 2 '(let ((a 2)) a))
+(eql-eval 1 'a)
+(eql-eval 1 '(let ((a 3) (b a)) b))
+(eql-eval 2 'b)
+
+;; let* - special operator
+(setq a 1 b 2)
+(eql-eval 2 '(let* ((a 2)) a))
+(eql-eval 1 'a)
+(eql-eval 3 '(let* ((a 3) (b a)) b))
+(eql-eval 2 'b)
+
+;; list - function
+(equal-test '(1) #'list 1)
+(equal-test '(3 4 a b 4) #'list 3 4 'a (car '(b . c)) (+ 6 -2))
+(eq-test nil #'list)
+
+;; list-length - function
+(eql-test 4 #'list-length '(a b c d))
+(eql-test 3 #'list-length '(a (b c) d))
+(eql-test 0 #'list-length '())
+(eql-test 0 #'list-length nil)
+(defun circular-list (&rest elements)
+ (let ((cycle (copy-list elements)))
+ (nconc cycle cycle)))
+(eq-test nil #'list-length (circular-list 'a 'b))
+(eq-test nil #'list-length (circular-list 'a))
+(eql-test 0 #'list-length (circular-list))
+
+;; list* - function
+(eql-test 1 #'list* 1)
+(equal-test '(a b c . d) #'list* 'a 'b 'c 'd)
+(error-test #'list*)
+(setq a '(1 2))
+(eq-test a #'list* a)
+
+;; listp - function (predicate)
+(eq-test t #'listp nil)
+(eq-test t #'listp '(1 . 2))
+(eq-test nil #'listp t)
+(eq-test nil #'listp #'listp)
+(eq-test nil #'listp #(1 2))
+(eq-test nil #'listp #c(1 2))
+
+;; lower-case-p - function
+(eq-test t #'lower-case-p #\a)
+(eq-test nil #'lower-case-p #\1)
+(eq-test nil #'lower-case-p #\Newline)
+(error-test #'lower-case-p 1)
+
+
+
+;; TODO make-array (will be rewritten)
+
+
+
+;; make-list - function
+(equal-test '(nil nil nil) #'make-list 3)
+(equal-test '((1 2) (1 2)) #'make-list 2 :initial-element '(1 2))
+(eq-test nil #'make-list 0)
+(eq-test nil #'make-list 0 :initial-element 1)
+
+;; make-package - function
+(setq pack1 (make-package "PACKAGE-1" :nicknames '("PACK-1" "PACK1")))
+(setq pack2 (make-package "PACKAGE-2" :nicknames '("PACK-2" "PACK2") :use '("PACK1")))
+(equal-test (list pack2) #'package-used-by-list pack1)
+(equal-test (list pack1) #'package-use-list pack2)
+(eq-test pack1 #'symbol-package 'pack1::test)
+(eq-test pack2 #'symbol-package 'pack2::test)
+
+;; make-string - function
+(equal-test "55555" #'make-string 5 :initial-element #\5)
+(equal-test "" #'make-string 0)
+(error-test #'make-string 10 :initial-element t)
+(error-test #'make-string 10 :initial-element nil)
+(error-test #'make-string 10 :initial-element 1)
+(eql-test 10 #'length (make-string 10))
+
+;; make-symbol - function
+(setq a "TEST")
+;; This will fail
+(eq-test nil #'eq (make-symbol a) (make-symbol a))
+(equal-test a #'symbol-name (make-symbol a))
+(setq temp-string "temp")
+(setq temp-symbol (make-symbol temp-string))
+(equal-test temp-string #'symbol-name temp-symbol)
+(equal-eval '(nil nil) '(multiple-value-list (find-symbol temp-string)))
+
+;; makunbound - function
+(eq-eval 1 '(setf (symbol-value 'a) 1))
+(eq-test t #'boundp 'a)
+(eql-eval 1 'a)
+(eq-test 'a #'makunbound 'a)
+(eq-test nil #'boundp 'a)
+(error-test #'makunbound 1)
+
+;; mapc - function
+(setq dummy nil)
+(equal-test '(1 2 3 4)
+ #'mapc #'(lambda (&rest x) (setq dummy (append dummy x)))
+ '(1 2 3 4)
+ '(a b c d e)
+ '(x y z))
+(equal-eval '(1 a x 2 b y 3 c z) 'dummy)
+
+;; mapcan - function
+(equal-test '(d 4 e 5)
+ #'mapcan #'(lambda (x y) (if (null x) nil (list x y)))
+ '(nil nil nil d e)
+ '(1 2 3 4 5 6))
+(equal-test '(1 3 4 5)
+ #'mapcan #'(lambda (x) (and (numberp x) (list x)))
+ '(a 1 b c 3 4 d 5))
+
+;; mapcar - function
+(equal-test '(1 2 3) #'mapcar #'car '((1 a) (2 b) (3 c)))
+(equal-test '(3 4 2 5 6) #'mapcar #'abs '(3 -4 2 -5 -6))
+(equal-test '((a . 1) (b . 2) (c . 3)) #'mapcar #'cons '(a b c) '(1 2 3))
+(equal-test '((1 3 5)) #'mapcar #'list* '(1 2) '(3 4) '((5)))
+(equal-test '((1 3 5) (2 4 6)) #'mapcar #'list* '(1 2) '(3 4) '((5) (6)))
+
+;; mapcon - function
+(equal-test '(1 a 2 b (3) c) #'mapcon #'car '((1 a) (2 b) ((3) c)))
+(equal-test '((1 2 3 4) (2 3 4) (3 4) (4)) #'mapcon #'list '(1 2 3 4))
+
+;; mapl - function
+(setq dummy nil)
+(equal-test '(1 2 3 4) #'mapl #'(lambda (x) (push x dummy)) '(1 2 3 4))
+(equal-eval '((4) (3 4) (2 3 4) (1 2 3 4)) 'dummy)
+
+;; maplist - function
+(equal-test '((1 2 3 4 1 2 1 2 3) (2 3 4 2 2 3))
+ #'maplist #'append '(1 2 3 4) '(1 2) '(1 2 3))
+(equal-test '((foo a b c d) (foo b c d) (foo c d) (foo d))
+ #'maplist #'(lambda (x) (cons 'foo x)) '(a b c d))
+(equal-test '(0 0 1 0 1 1 1)
+ #'maplist #'(lambda (x) (if (member (car x) (cdr x)) 0 1)) '(a b a c d b c))
+
+;; member - function
+(setq a '(1 2 3))
+(eq-test (cdr a) #'member 2 a)
+(setq a '((1 . 2) (3 . 4)))
+(eq-test (cdr a) #'member 2 a :test-not #'= :key #'cdr)
+(eq-test nil #'member 'e '(a b c d))
+(eq-test nil #'member 1 nil)
+(error-test #'member 2 '(1 . 2))
+(setq a '(a b nil c d))
+(eq-test (cddr a) #'member-if #'listp a)
+(setq a '(a #\Space 5/3 foo))
+(eq-test (cddr a) #'member-if #'numberp a)
+(setq a '(3 6 9 11 . 12))
+(eq-test (cdddr a) #'member-if-not #'zerop a :key #'(lambda (x) (mod x 3)))
+
+;; multiple-value-bind - macro
+(equal-eval '(11 9) '(multiple-value-bind (f r) (floor 130 11) (list f r)))
+
+;; multiple-value-call - special operator
+(equal-eval '(1 / 2 3 / / 2 0.5)
+ '(multiple-value-call #'list 1 '/ (values 2 3) '/ (values) '/ (floor 2.5)))
+(eql-eval 10 '(multiple-value-call #'+ (floor 5 3) (floor 19 4)))
+
+;; multiple-value-list - macro
+(equal-eval '(-1 1) '(multiple-value-list (floor -3 4)))
+(eql-eval nil '(multiple-value-list (values)))
+(equal-eval '(nil) '(multiple-value-list (values nil)))
+
+;; multiple-value-prog1 - special operator
+(setq temp '(1 2 3))
+(equal-eval temp
+ '(multiple-value-list
+ (multiple-value-prog1
+ (values-list temp)
+ (setq temp nil)
+ (values-list temp))))
+
+;; multiple-value-setq - macro
+(eql-eval 1 '(multiple-value-setq (quotient remainder) (truncate 3.5d0 2)))
+(eql-eval 1 quotient)
+(eql-eval 1.5d0 'remainder)
+(eql-eval 1 '(multiple-value-setq (a b c) (values 1 2)))
+(eql-eval 1 'a)
+(eql-eval 2 'b)
+(eq-eval nil 'c)
+(eql-eval 4 '(multiple-value-setq (a b) (values 4 5 6)))
+(eql-eval 4 'a)
+(eql-eval 5 'b)
+(setq a 1)
+(eql-eval nil '(multiple-value-setq (a) (values)))
+(eql-eval nil 'a)
+
+;; nconc - function
+(eq-test nil #'nconc)
+(setq x '(a b c))
+(setq y '(d e f))
+(equal-test '(a b c d e f) #'nconc x y)
+(equal-eval '(a b c d e f) 'x)
+(eq-test y #'cdddr x)
+(equal-test '(1 . 2) #'nconc (list 1) 2)
+(error-test #'nconc 1 2 3)
+(equal-eval '(k l m)
+ '(setq foo (list 'a 'b 'c 'd 'e)
+ bar (list 'f 'g 'h 'i 'j)
+ baz (list 'k 'l 'm)))
+(equal-test '(a b c d e f g h i j k l m) #'nconc foo bar baz)
+(equal-eval '(a b c d e f g h i j k l m) 'foo)
+(equal-eval (nthcdr 5 foo) 'bar)
+(equal-eval (nthcdr 10 foo) 'baz)
+(setq foo (list 'a 'b 'c 'd 'e)
+ bar (list 'f 'g 'h 'i 'j)
+ baz (list 'k 'l 'm))
+(equal-eval '(a b c d e f g h i j k l m) '(setq foo (nconc nil foo bar nil baz)))
+(equal-eval '(a b c d e f g h i j k l m) 'foo)
+(equal-eval (nthcdr 5 foo) 'bar)
+(equal-eval (nthcdr 10 foo) 'baz)
+
+;; notany - function
+(eql-test t #'notany #'> '(1 2 3 4) '(5 6 7 8) '(9 10 11 12))
+(eql-test t #'notany 'not-used ())
+(eql-test nil #'notany #'characterp #(1 2 3 4 5 #\6 7 8))
+
+;; notevery - function
+(eql-test nil #'notevery #'< '(1 2 3 4) '(5 6 7 8) '(9 10 11 12))
+(eql-test nil #'notevery 'not-used ())
+(eql-test t #'notevery #'numberp #(1 2 3 4 5 #\6 7 8))
+
+;; nth - accessor (function)
+(eql-test 'foo #'nth 0 '(foo bar baz))
+(eql-test 'bar #'nth 1 '(foo bar baz))
+(eq-test nil #'nth 3 '(foo bar baz))
+(error-test #'nth 0 #c(1 2))
+(error-test #'nth 0 #(1 2))
+(error-test #'nth 0 "test")
+
+;; nth-value - macro
+(equal-eval 'a '(nth-value 0 (values 'a 'b)))
+(equal-eval 'b '(nth-value 1 (values 'a 'b)))
+(eq-eval nil '(nth-value 2 (values 'a 'b)))
+(equal-eval '(3332987528 3332987528 t)
+ '(multiple-value-list
+ (let* ((x 83927472397238947423879243432432432)
+ (y 32423489732)
+ (a (nth-value 1 (floor x y)))
+ (b (mod x y)))
+ (values a b (= a b)))))
+
+;; nthcdr - function
+(eq-test nil #'nthcdr 0 '())
+(eq-test nil #'nthcdr 3 '())
+(equal-test '(a b c) #'nthcdr 0 '(a b c))
+(equal-test '(c) #'nthcdr 2 '(a b c))
+(eq-test () #'nthcdr 4 '(a b c))
+(eql-test 1 #'nthcdr 1 '(0 . 1))
+(error-test #'nthcdr -1 '(1 2))
+(error-test #'nthcdr #\Null '(1 2))
+(error-test #'nthcdr 1 t)
+(error-test #'nthcdr 1 #(1 2 3))
+
+;; or - macro
+(eq-eval nil '(or))
+(setq temp0 nil temp1 10 temp2 20 temp3 30)
+(eql-eval 10 '(or temp0 temp1 (setq temp2 37)))
+(eql-eval 20 'temp2)
+(eql-eval 11 '(or (incf temp1) (incf temp2) (incf temp3)))
+(eql-eval 11 'temp1)
+(eql-eval 20 temp2)
+(eql-eval 30 'temp3)
+(eql-eval 11 '(or (values) temp1))
+(eql-eval 11 '(or (values temp1 temp2) temp3))
+(equal-eval '(11 20) '(multiple-value-list (or temp0 (values temp1 temp2))))
+(equal-eval '(20 30)
+ '(multiple-value-list (or (values temp0 temp1) (values temp2 temp3))))
+
+;; packagep - function (predicate)
+(eq-test t #'packagep *package*)
+(eq-test nil #'packagep 10)
+(eq-test t #'packagep (make-package "TEST-PACKAGE"))
+(eq-test nil #'packagep 'keyword)
+(eq-test t #'packagep (find-package 'keyword))
+
+;; pairlis - function
+#+xedit ;; order of result may vary
+(progn
+ (equal-test '((one . 1) (two . 2) (three . 3) (four . 19))
+ #'pairlis '(one two) '(1 2) '((three . 3) (four . 19)))
+ (setq keys '(1 2 3)
+ data '("one" "two" "three")
+ alist '((4 . "four")))
+ (equal-test '((1 . "one") (2 . "two") (3 . "three"))
+ #'pairlis keys data)
+ (equal-test '((1 . "one") (2 . "two") (3 . "three") (4 . "four"))
+ #'pairlis keys data alist)
+ (equal-eval '(1 2 3) 'keys)
+ (equal-eval '("one" "two" "three") 'data)
+ (equal-eval '((4 . "four")) 'alist)
+ (eq-test nil #'pairlis 1 2)
+ (error-test #'pairlis '(1 2 3) '(4 5))
+)
+
+;; pop - macro
+(setq stack '(a b c) test stack)
+(eq-eval 'a '(pop stack))
+(eq-eval (cdr test) 'stack)
+(setq llst '((1 2 3 4)) test (car llst))
+(eq-eval 1 '(pop (car llst)))
+(eq-eval (cdr test) '(car llst))
+(error-eval '(pop 1))
+(error-eval '(pop nil))
+;; dotted list
+(setq stack (cons 1 2))
+(eq-eval 1 '(pop stack))
+(error-eval '(pop stack))
+;; circular list
+(setq stack '#1=(1 . #1#) *print-circle* t)
+(eql-eval 1 '(pop stack))
+(eql-eval 1 '(pop stack))
+(eql-eval 1 '(pop (cdr stack)))
+
+;; position - function
+(eql-test 4 #'position #\a "baobab" :from-end t)
+(eql-test 2 #'position-if #'oddp '((1) (2) (3) (4)) :start 1 :key #'car)
+(eq-test nil #'position 595 '())
+(eq-test 4 #'position-if-not #'integerp '(1 2 3 4 5.0))
+(eql-test 1 #'position (char-int #\1) "0123" :key #'char-int)
+
+;; prog - macro
+(eq-eval nil '(prog () :error))
+(eq-eval 'ok
+ '(prog ((a 0))
+ l1 (if (< a 10) (go l3) (go l2))
+ (return 'failed)
+ l2 (return 'ok)
+ (return 'failed)
+ l3 (incf a) (go l1)
+ (return 'failed)
+ ))
+(setq a 1)
+(eq-eval '/= '(prog ((a 2) (b a)) (return (if (= a b) '= '/=))))
+
+;; prog* - macro
+(setq a 1)
+(eq-eval nil '(prog* () :error))
+(eq-eval 'ok
+ '(prog* ((a 0) (b 0))
+ l1 (if (< a 10) (go l3) (go l2))
+ (return 'failed)
+ l2 (if (< b 10) (go l4) (return 'ok))
+ (return 'failed)
+ l3 (incf a) (go l1)
+ (return 'failed)
+ l4 (incf b) (setq a 0) (go l1)
+ (return 'failed)
+ ))
+(eq-eval '= '(prog* ((a 2) (b a)) (return (if (= a b) '= '/=))))
+
+;; prog1 - macro
+(setq temp 1)
+(eql-eval 1 '(prog1 temp (incf temp) (eql-eval 2 'temp) temp))
+(eql-eval 2 'temp)
+(eql-eval 2 '(prog1 temp (setq temp nil) (eql-eval nil 'temp) temp))
+(eq-eval nil 'temp)
+(eql-eval 1 '(prog1 (values 1 2 3) 4))
+(setq temp (list 'a 'b 'c))
+(eq-eval 'a '(prog1 (car temp) (setf (car temp) 'alpha)))
+(equal-eval '(alpha b c) 'temp)
+(equal-eval '(1)
+ '(multiple-value-list (prog1 (values 1 2) (values 4 5))))
+
+;; prog2 - macro
+(setq temp 1)
+(eql-eval 3 '(prog2 (incf temp) (incf temp) (incf temp)))
+(eql-eval 4 'temp)
+(eql-eval 2 '(prog2 1 (values 2 3 4) 5))
+(equal-eval '(3)
+ '(multiple-value-list (prog2 (values 1 2) (values 3 4) (values 5 6))))
+
+;; progn - special operator
+(eq-eval nil '(progn))
+(eql-eval 3 '(progn 1 2 3))
+(equal-eval '(1 2 3) '(multiple-value-list (progn (values 1 2 3))))
+(setq a 1)
+(eq-eval 'here '(if a (progn (setq a nil) 'here) (progn (setq a t) 'there)))
+(eq-eval nil 'a)
+
+;; progv - special operator
+(makunbound '*x*) ;; make sure it is not bound
+(setq *x* 1)
+(eql-eval 2 '(progv '(*x*) '(2) *x*))
+(eql-eval 1 '*x*)
+(equal-eval '(3 4)
+ '(let ((*x* 3)) (progv '(*x*) '(4) (list *x* (symbol-value '*x*)))))
+(makunbound '*x*)
+(defvar *x* 1)
+(equal-eval '(4 4)
+ '(let ((*x* 3)) (progv '(*x*) '(4) (list *x* (symbol-value '*x*)))))
+(equal-eval '(4 4)
+ '(multiple-value-list
+ (let ((*x* 3))
+ (progv '(*x*) '(4) (values-list (list *x* (symbol-value '*x*)))))))
+
+;; push - macro
+(setq llst '(nil))
+(equal-eval '(1) '(push 1 (car llst)))
+(equal-eval '((1)) 'llst)
+(equal-eval '(1 1) '(push 1 (car llst)))
+(equal-eval '((1 1)) 'llst)
+(setq x '(a (b c) d))
+(equal-eval '(5 B C) '(push 5 (cadr x)))
+(equal-eval '(a (5 b c) d) 'x)
+
+;; pushnew - macro
+(setq x '(a (b c) d))
+(equal-eval '(5 b c) '(pushnew 5 (cadr x)))
+(equal-eval '(a (5 b c) d) 'x)
+(equal-eval '(5 b c) '(pushnew 'b (cadr x)))
+(equal-eval '(a (5 b c) d) 'x)
+(setq lst '((1) (1 2) (1 2 3)))
+(equal-eval '((2) (1) (1 2) (1 2 3)) '(pushnew '(2) lst))
+(equal-eval '((1) (2) (1) (1 2) (1 2 3)) '(pushnew '(1) lst))
+(equal-eval '((1) (2) (1) (1 2) (1 2 3)) '(pushnew '(1) lst :test 'equal))
+(equal-eval '((1) (2) (1) (1 2) (1 2 3)) '(pushnew '(1) lst :key #'car))
+
+;; remove-duplicates - function
+(equal-test "aBcD" #'remove-duplicates "aBcDAbCd" :test #'char-equal :from-end t)
+(equal-test '(a c b d e) #'remove-duplicates '(a b c b d d e))
+(equal-test '(a b c d e) #'remove-duplicates '(a b c b d d e) :from-end t)
+(equal-test '((bar #\%) (baz #\A))
+ #'remove-duplicates '((foo #\a) (bar #\%) (baz #\A))
+ :test #'char-equal :key #'cadr)
+(equal-test '((foo #\a) (bar #\%))
+ #'remove-duplicates '((foo #\a) (bar #\%) (baz #\A))
+ :test #'char-equal :key #'cadr :from-end t)
+(setq tester (list 0 1 2 3 4 5 6))
+(equal-test '(0 4 5 6) #'delete-duplicates tester :key #'oddp :start 1 :end 6)
+
+;; replace - function
+(equal-test "abcd456hij"
+ #'replace (copy-seq "abcdefghij") "0123456789" :start1 4 :end1 7 :start2 4)
+(setq lst (xseq "012345678"))
+(equal-test "010123456" #'replace lst lst :start1 2 :start2 0)
+(equal-eval "010123456" 'lst)
+
+;; rest - accessor
+(equal-eval '(2) '(rest '(1 2)))
+(eql-eval 2 '(rest '(1 . 2)))
+(eq-eval nil '(rest '(1)))
+(setq *cons* '(1 . 2))
+(equal-eval "two" '(setf (rest *cons*) "two"))
+(equal-eval '(1 . "two") '*cons*)
+
+;; return - macro
+(eq-eval nil '(block nil (return) 1))
+(eql-eval 1 '(block nil (return 1) 2))
+(equal-eval '(1 2) '(multiple-value-list (block nil (return (values 1 2)) 3)))
+(eql-eval 1 '(block nil (block alpha (return 1) 2)))
+(eql-eval 2 '(block alpha (block nil (return 1)) 2))
+(eql-eval 1 '(block nil (block nil (return 1) 2)))
+
+;; return-from - special operator
+(eq-eval nil '(block alpha (return-from alpha) 1))
+(eql-eval 1 '(block alpha (return-from alpha 1) 2))
+(equal-eval '(1 2)
+ '(multiple-value-list (block alpha (return-from alpha (values 1 2)) 3)))
+(eql-eval 2
+ '(let ((a 0)) (dotimes (i 10) (incf a) (when (oddp i) (return))) a))
+(eq-eval 'temp '(defun temp (x) (if x (return-from temp ''dummy)) 44))
+(eql-eval 44 '(temp nil))
+(eq-eval 'dummy (temp t))
+(eql-eval 2 (block nil (unwind-protect (return-from nil 1) (return-from nil 2))))
+(error-eval '(funcall (block nil #'(lambda () (return-from nil)))))
+
+;; reverse - function
+(setq str (xseq "abc") test str)
+(equal-test "cba" #'reverse str)
+(eq-eval test 'str)
+(equal-eval "cba" '(setq test (nreverse str)))
+(equal-eval "cba" 'test)
+(setq l (list 1 2 3) test l)
+(equal-eval '(3 2 1) '(setq test (nreverse l)))
+(equal-eval '(3 2 1) 'test)
+
+;; rplac? - function
+(eql-eval '*some-list*
+ '(defparameter *some-list* (list* 'one 'two 'three 'four)))
+(equal-eval '(one two three . four) '*some-list*)
+(equal-test '(uno two three . four) #'rplaca *some-list* 'uno)
+(equal-eval '(uno two three . four) '*some-list*)
+(equal-test '(three iv) #'rplacd (last *some-list*) (list 'iv))
+(equal-eval '(uno two three iv) '*some-list*)
+
+;; search - function
+(eql-test 7 #'search "dog" "it's a dog's life")
+(eql-test 2 #'search '(0 1) '(2 4 6 1 3 5) :key #'oddp)
+(eql-test 8 #'search "foo" "foooobarfooooobarfo" :from-end t)
+(eql-test 5
+ #'search "123"
+ (mapcar #'(lambda (x) (+ x (char-code #\0)))
+ '(1 2 34 3 2 1 2 3 4 3 2 1)) :from-end t
+ :key #'(lambda (x) (if (integerp x) (code-char x) x)))
+(eql-test 0 #'search "abc" "abcd" :from-end t)
+(eql-test 3 #'search "bar" "foobar")
+
+;; set - function
+(eql-eval 1 '(setf (symbol-value 'n) 1))
+(eql-test 2 #'set 'n 2)
+(eql-test 2 #'symbol-value 'n)
+(eql-eval 4
+ '(let ((n 3))
+ (setq n (+ n 1))
+ (setf (symbol-value 'n) (* n 10))
+ (set 'n (+ (symbol-value 'n) n))
+ n))
+(eql-eval 44 'n)
+(defvar *n* 2)
+(eql-eval 80
+ '(let ((*n* 3))
+ (setq *n* (+ *n* 1))
+ (setf (symbol-value '*n*) (* *n* 10))
+ (set '*n* (+ (symbol-value '*n*) *n*))
+ *n*))
+(eql-eval 2 '*n*)
+(eq-eval '*even-count* '(defvar *even-count* 0))
+(eq-eval '*odd-count* '(defvar *odd-count* 0))
+(eql-eval 'tally-list
+ '(defun tally-list (list)
+ (dolist (element list)
+ (set (if (evenp element) '*even-count* '*odd-count*)
+ (+ element (if (evenp element) *even-count* *odd-count*))))))
+(eq-eval nil '(tally-list '(1 9 4 3 2 7)))
+(eql-eval 6 '*even-count*)
+(eql-eval 20 '*odd-count*)
+
+;; set-difference - function
+(setq lst1 (list "A" "b" "C" "d") lst2 (list "a" "B" "C" "d"))
+(equal-test '("A" "b" "C" "d") #'set-difference lst1 lst2)
+(equal-test '("A" "b") #'set-difference lst1 lst2 :test 'equal)
+(eq-test nil #'set-difference lst1 lst2 :test #'equalp)
+(equal-test '("A" "b") #'nset-difference lst1 lst2 :test #'string=)
+(setq lst1 '(("a" . "b") ("c" . "d") ("e" . "f"))
+ lst2 '(("c" . "a") ("e" . "b") ("d" . "a")))
+(equal-test '(("c" . "d") ("e" . "f"))
+ #'nset-difference lst1 lst2 :test #'string= :key #'cdr)
+(equal-eval '(("c" . "a") ("e" . "b") ("d" . "a")) 'lst2)
+(equal-test '("banana" "lemon" "rhubarb")
+ #'set-difference
+ '("strawberry" "chocolate" "banana" "lemon" "pistachio" "rhubarb")
+ '(#\c #\w) :test #'(lambda (s c) (find c s)))
+
+;; set-exclusive-or - function
+(setq lst1 (list 1 "a" "b") lst2 (list 1 "A" "b"))
+(equal-test '("a" "b" "A" "b") #'set-exclusive-or lst1 lst2)
+(equal-test '("a" "A") #'set-exclusive-or lst1 lst2 :test #'equal)
+(eq-test nil #'set-exclusive-or lst1 lst2 :test 'equalp)
+(equal-test '("a" "b" "A" "b") #'nset-exclusive-or lst1 lst2)
+(setq lst1 '(("a" . "b") ("c" . "d") ("e" . "f"))
+ lst2 '(("c" . "a") ("e" . "b") ("d" . "a")))
+(equal-test '(("c" . "d") ("e" . "f") ("c" . "a") ("d" . "a"))
+ #'nset-exclusive-or lst1 lst2 :test #'string= :key #'cdr)
+
+;; setf - macro
+(setq x (cons 'a 'b) y (list 1 2 3))
+(equal-eval '(1 x 3) '(setf (car x) 'x (cadr y) (car x) (cdr x) y))
+(equal-eval '(x 1 x 3) 'x)
+(equal-eval '(1 x 3) 'y)
+(setq x (cons 'a 'b) y (list 1 2 3))
+(eq-eval nil '(psetf (car x) 'x (cadr y) (car x) (cdr x) y))
+(equal-eval '(x 1 a 3) 'x)
+(equal-eval '(1 a 3) 'y)
+(error-eval '(setf x))
+(error-eval '(psetf x))
+
+;; setq - special form
+(eql-eval 3 '(setq a 1 b 2 c 3))
+(eql-eval 1 'a)
+(eql-eval 2 'b)
+(eql-eval 3 'c)
+(eql-eval 7 '(setq a (1+ b) b (1+ a) c (+ a b)))
+(eql-eval 3 'a)
+(eql-eval 4 'b)
+(eql-eval 7 'c)
+(eq-eval nil '(psetq a 1 b 2 c 3))
+(eql-eval 1 'a)
+(eql-eval 2 'b)
+(eql-eval 3 'c)
+(equal-eval '(2 1)
+ '(multiple-value-list (let ((a 1) (b 2)) (psetq a b b a) (values a b))))
+(error-eval '(setq x))
+(error-eval '(setq x 1 y))
+
+;; some - function
+(eq-test t #'some #'= '(1 2 3 4 5) '(5 4 3 2 1))
+
+;; sort - function
+(setq tester (copy-seq "lkjashd"))
+(equal-test "adhjkls" #'sort tester #'char-lessp)
+(setq tester (list '(1 2 3) '(4 5 6) '(7 8 9)))
+(equal-test '((7 8 9) (4 5 6) (1 2 3)) #'sort tester #'> :key #'car)
+(setq tester (list 1 2 3 4 5 6 7 8 9 0))
+(equal-test '(1 3 5 7 9 2 4 6 8 0)
+ #'stable-sort tester #'(lambda (x y) (and (oddp x) (evenp y))))
+(equalp-test
+ #((("Kathy" "Chapman") "Editorial")
+ (("Dick" "Gabriel") "Objects")
+ (("Gregor" "Kiczales") "Objects")
+ (("Sandra" "Loosemore") "Compiler")
+ (("Larry" "Masinter") "Cleanup")
+ (("David" "Moon") "Objects")
+ (("Kent" "Pitman") "Conditions")
+ (("Dick" "Waters") "Iteration")
+ (("JonL" "White") "Iteration"))
+ #'sort (setq committee-data
+ (vector (list (list "JonL" "White") "Iteration")
+ (list (list "Dick" "Waters") "Iteration")
+ (list (list "Dick" "Gabriel") "Objects")
+ (list (list "Kent" "Pitman") "Conditions")
+ (list (list "Gregor" "Kiczales") "Objects")
+ (list (list "David" "Moon") "Objects")
+ (list (list "Kathy" "Chapman") "Editorial")
+ (list (list "Larry" "Masinter") "Cleanup")
+ (list (list "Sandra" "Loosemore") "Compiler")))
+ #'string-lessp :key #'cadar)
+(equalp-eval
+ #((("Larry" "Masinter") "Cleanup")
+ (("Sandra" "Loosemore") "Compiler")
+ (("Kent" "Pitman") "Conditions")
+ (("Kathy" "Chapman") "Editorial")
+ (("Dick" "Waters") "Iteration")
+ (("JonL" "White") "Iteration")
+ (("Dick" "Gabriel") "Objects")
+ (("Gregor" "Kiczales") "Objects")
+ (("David" "Moon") "Objects"))
+ '(setq committee-data
+ (stable-sort committee-data #'string-lessp :key #'cadr)))
+(error-test #'sort #c(1 2))
+
+;; string - function
+(setq a "already a string")
+(eq-test a #'string a)
+(equal-test "ELM" #'string 'elm)
+(equal-test "c" #'string #\c)
+
+;; string-* - function
+(eq-test t #'string= "foo" "foo")
+(eq-test nil #'string= "foo" "Foo")
+(eq-test nil #'string= "foo" "bar")
+(eq-test t #'string= "together" "frog" :start1 1 :end1 3 :start2 2)
+(eq-test t #'string-equal "foo" "Foo")
+(eq-test t #'string= "abcd" "01234abcd9012" :start2 5 :end2 9)
+(eql-test 3 #'string< "aaaa" "aaab")
+(eql-test 4 #'string>= "aaaaa" "aaaa")
+(eql-test 5 #'string-not-greaterp "Abcde" "abcdE")
+(eql-test 6 #'string-lessp "012AAAA789" "01aaab6" :start1 3 :end1 7
+ :start2 2 :end2 6)
+(eq-test nil #'string-not-equal "AAAA" "aaaA")
+(error-test #'string= #(1 2 3) '(1 2 3))
+(eql-test 0 #'string< "abcd" "efg")
+(eql-test 1 #'string< "abcd" "afg")
+(eql-test 0 #'string/= "foo" "baar")
+(eql-test nil #'string/= "foobar" "foobar")
+
+;; string-{upcase,downcase,capitalize} - function
+(equal-test "ABCDE" #'string-upcase "abcde")
+(equal-test "aBCDe" #'string-upcase "abcde" :start 1 :end 4)
+(equal-test "aBCDe" #'nstring-upcase (xseq "abcde") :start 1 :end 4)
+(equal-test "DR. LIVINGSTON, I PRESUME?"
+ #'string-upcase "Dr. Livingston, I presume?")
+(equal-test "Dr. LIVINGSTON, I Presume?"
+ #'string-upcase "Dr. Livingston, I presume?" :start 4 :end 19)
+(equal-test "Dr. LIVINGSTON, I Presume?"
+ #'nstring-upcase (xseq "Dr. Livingston, I presume?") :start 4 :end 19)
+(equal-test "Dr. LiVINGston, I presume?"
+ #'string-upcase "Dr. Livingston, I presume?" :start 6 :end 10)
+(equal-test "Dr. LiVINGston, I presume?"
+ #'nstring-upcase (xseq "Dr. Livingston, I presume?") :start 6 :end 10)
+(equal-test "dr. livingston, i presume?"
+ #'string-downcase "Dr. Livingston, I presume?")
+(equal-test "Dr. livingston, i Presume?"
+ #'string-downcase "Dr. Livingston, I Presume?" :start 1 :end 17)
+(equal-test "Dr. livingston, i Presume?"
+ #'nstring-downcase (xseq "Dr. Livingston, I Presume?") :start 1 :end 17)
+(equal-test "Elm 13c Arthur;Fig Don'T"
+ #'string-capitalize "elm 13c arthur;fig don't")
+(equal-test "elm 13C Arthur;Fig Don't"
+ #'string-capitalize "elm 13c arthur;fig don't" :start 6 :end 21)
+(equal-test "elm 13C Arthur;Fig Don't"
+ #'nstring-capitalize (xseq "elm 13c arthur;fig don't") :start 6 :end 21)
+(equal-test " Hello " #'string-capitalize " hello ")
+(equal-test " Hello " #'nstring-capitalize (xseq " hello "))
+(equal-test "Occluded Casements Forestall Inadvertent Defenestration"
+ #'string-capitalize "occlUDeD cASEmenTs FOreSTAll iNADVertent DEFenestraTION")
+(equal-test "Don'T!" #'string-capitalize "DON'T!")
+(equal-test "Pipe 13a, Foo16c" #'string-capitalize "pipe 13a, foo16c")
+(setq str (copy-seq "0123ABCD890a"))
+(equal-test "0123AbcD890a" #'nstring-downcase str :start 5 :end 7)
+(equal-eval "0123AbcD890a" 'str)
+(error-test #'nstring-capitalize 1)
+(error-test #'string-capitalize "foobar" :start 4 :end 2)
+(equal-test "foobar" #'string-capitalize "foobar" :start 0 :end 0)
+
+;; string-{,left-,right-}trim - function
+(equal-test "kaaak" #'string-trim "abc" "abcaakaaakabcaaa")
+#+xedit (equal-test "kaaak" #'nstring-trim "abc" "abcaakaaakabcaaa")
+(equal-test "garbanzo beans"
+ #'string-trim '(#\Space #\Tab #\Newline) " garbanzo beans
+ ")
+#+xedit (equal-test "garbanzo beans"
+ #'nstring-trim '(#\Space #\Tab #\Newline) " garbanzo beans
+ ")
+(equal-test "three (silly) words"
+ #'string-trim " (*)" " ( *three (silly) words* ) ")
+#+xedit (equal-test "three (silly) words"
+ #'nstring-trim " (*)" " ( *three (silly) words* ) ")
+(equal-test "labcabcabc" #'string-left-trim "abc" "labcabcabc")
+#+xedit (equal-test "labcabcabc" #'nstring-left-trim "abc" "labcabcabc")
+(equal-test "three (silly) words* ) "
+ #'string-left-trim " (*)" " ( *three (silly) words* ) ")
+#+xedit (equal-test "three (silly) words* ) "
+ #'nstring-left-trim " (*)" " ( *three (silly) words* ) ")
+(equal-test " ( *three (silly) words"
+ #'string-right-trim " (*)" " ( *three (silly) words* ) ")
+#+xedit (equal-test " ( *three (silly) words"
+ #'nstring-right-trim " (*)" " ( *three (silly) words* ) ")
+(error-test #'string-trim 123 "123")
+(error-test #'string-left-trim 123 "123")
+
+;; stringp - function (predicate)
+(eq-test t #'stringp "abc")
+(eq-test nil #'stringp #\a)
+(eq-test nil #'stringp 1)
+(eq-test nil #'stringp #(#\a #\b #\c))
+
+;; subseq - accessor
+(setq str (xseq "012345"))
+(equal-test "2345" #'subseq str 2)
+(equal-test "34" #'subseq str 3 5)
+(equal-eval "abc" '(setf (subseq str 4) "abc"))
+(equal-eval "0123ab" 'str)
+(equal-eval "A" '(setf (subseq str 0 2) "A"))
+(equal-eval "A123ab" 'str)
+
+;; subsetp - function
+(setq cosmos '(1 "a" (1 2)))
+(eq-test t #'subsetp '(1) cosmos)
+(eq-test nil #'subsetp '((1 2)) cosmos)
+(eq-test t #'subsetp '((1 2)) cosmos :test 'equal)
+(eq-test t #'subsetp '(1 "A") cosmos :test #'equalp)
+(eq-test nil #'subsetp '((1) (2)) '((1) (2)))
+(eq-test t #'subsetp '((1) (2)) '((1) (2)) :key #'car)
+
+;; svref - function
+;; XXX vectors will be reimplemented, just a test for the current implementation
+(setq v (vector 1 2 'sirens))
+(eql-eval 1 '(svref v 0))
+(eql-eval 'sirens '(svref v 2))
+(eql-eval 'newcomer '(setf (svref v 1) 'newcomer))
+(equalp-eval #(1 newcomer sirens) 'v)
+
+;; symbol-name - function
+(equal-test "TEMP" #'symbol-name 'temp)
+(equal-test "START" #'symbol-name :start)
+(error-test #'symbol-name 1)
+
+;; symbol-package - function
+(eq-test (find-package "LISP") #'symbol-package 'car)
+(eql-test *package* #'symbol-package 'bus)
+(eq-test (find-package "KEYWORD") #'symbol-package :optional)
+;; Gensyms are uninterned, so have no home package.
+(eq-test nil #'symbol-package (gensym))
+(setq pk1 (make-package 'pk1))
+(intern "SAMPLE1" "PK1")
+(eq-eval t '(export (find-symbol "SAMPLE1" "PK1") "PK1"))
+(setq pk2 (make-package 'pk2 :use '(pk1)))
+(equal-eval '(pk1:sample1 :inherited)
+ '(multiple-value-list (find-symbol "SAMPLE1" "PK2")))
+(eq-test pk1 #'symbol-package 'pk1::sample1)
+(eq-test pk1 #'symbol-package 'pk2::sample1)
+(eq-test pk1 #'symbol-package 'pk1::sample2)
+(eq-test pk2 #'symbol-package 'pk2::sample2)
+;; The next several forms create a scenario in which a symbol
+;; is not really uninterned, but is "apparently uninterned",
+;; and so SYMBOL-PACKAGE still returns NIL.
+(setq s3 'pk1::sample3)
+(eq-eval t '(import s3 'pk2))
+(eq-eval t '(unintern s3 'pk1)) ;; XXX unintern not yet implemented
+(eq-test nil #'symbol-package s3) ;; fail due to unintern not implemented
+(eq-test t #'eq s3 'pk2::sample3)
+
+;; symbol-plist - accessor
+(setq sym (gensym))
+(eq-eval () '(symbol-plist sym))
+(eq-eval 'val1 '(setf (get sym 'prop1) 'val1))
+(equal-eval '(prop1 val1) '(symbol-plist sym))
+(eq-eval 'val2 '(setf (get sym 'prop2) 'val2))
+(equal-eval '(prop2 val2 prop1 val1) '(symbol-plist sym))
+(setq sym-plist (list 'prop3 'val3))
+(eq-eval sym-plist '(setf (symbol-plist sym) sym-plist))
+(eq-eval sym-plist '(symbol-plist sym))
+
+;; symbol-value - accessor
+(eql-eval 1 '(setf (symbol-value 'a) 1))
+(eql-eval 1 '(symbol-value 'a))
+;; SYMBOL-VALUE cannot see lexical variables.
+(eql-eval 1 '(let ((a 2)) (symbol-value 'a)))
+(eql-eval 1 '(let ((a 2)) (setq a 3) (symbol-value 'a)))
+
+#+xedit ;; incorrect...
+(progn
+ ;; SYMBOL-VALUE can see dynamic variables.
+ ;; declare not yet implemented
+ (proclaim '(special a))
+ (eql-eval 2 '(let ((a 2)) (symbol-value 'a)))
+ (eql-eval 1 'a)
+ (eql-eval 3 '(let ((a 2)) (setq a 3) (symbol-value 'a)))
+ (eql-eval 1 'a)
+ ;; declare not yet implement
+ (makunbound 'a)
+ (eql-eval 2 '(let ((a 2)) (setf (symbol-value 'a) 3) a))
+ (eql-eval 3 'a)
+ (eql-eval 3 '(symbol-value 'a))
+ ;; declare not yet implement
+ (makunbound 'a)
+ (equal-eval '(5 4)
+ '(multiple-value-list
+ (let ((a 4))
+
+ ;; declare not yet implemented
+ (defparameter a 3)
+
+ (let ((b (symbol-value 'a)))
+ (setf (symbol-value 'a) 5)
+ (values a b)))))
+ (eql-eval 3 'a)
+)
+(eq-eval :any-keyword '(symbol-value :any-keyword))
+;; XXX these will fail
+(eq-eval nil '(symbol-value 'nil))
+(eq-eval nil '(symbol-value '()))
+
+;; symbolp - function (predicate)
+(eq-test t #'symbolp 'elephant)
+(eq-test nil #'symbolp 12)
+;; XXX these will fail
+(eq-test t #'symbolp nil)
+(eq-test t #'symbolp '())
+(eq-test t #'symbolp :test)
+(eq-test nil #'symbolp "hello")
+
+;; remprop - function
+(setq test (make-symbol "PSEUDO-PI"))
+(eq-eval () '(symbol-plist test))
+(eq-eval t '(setf (get test 'constant) t))
+(eql-eval 3.14 '(setf (get test 'approximation) 3.14))
+(eql-eval 'noticeable '(setf (get test 'error-range) 'noticeable))
+(equal-eval '(error-range noticeable approximation 3.14 constant t)
+ '(symbol-plist test))
+(eq-eval nil '(setf (get test 'approximation) nil))
+(equal-eval '(error-range noticeable approximation nil constant t)
+ '(symbol-plist test))
+(eq-eval nil (get test 'approximation))
+(eq-test t #'remprop test 'approximation)
+(eq-eval nil '(get test 'approximation))
+(equal-eval '(error-range noticeable constant t) '(symbol-plist test))
+(eq-test nil #'remprop test 'approximation)
+(equal-eval '(error-range noticeable constant t) '(symbol-plist test))
+(eq-test t #'remprop test 'error-range)
+(eql-eval 3 '(setf (get test 'approximation) 3))
+(equal-eval '(approximation 3 constant t) '(symbol-plist test))
+
+;; throw - special operator
+(equal-eval '(3 9)
+ '(multiple-value-list
+ (catch 'result
+ (setq i 0 j 0)
+ (loop (incf j 3) (incf i)
+ (if (= i 3) (throw 'result (values i j)))))))
+(eql-eval 2 '(catch nil (unwind-protect (throw nil 1) (throw nil 2))))
+
+;; XXX undefined consequences
+(eql-eval 2
+ '(catch 'a
+ (catch 'b
+ (unwind-protect (throw 'a 1)
+ (throw 'b 2)))))
+(eq-eval :outer-catch
+ '(catch 'foo
+ (setq string (format nil "The inner catch returns ~s."
+ (catch 'foo
+ (unwind-protect (throw 'foo :first-throw)
+ (throw 'foo :second-throw)))))
+ :outer-catch))
+(equal-eval "The inner catch returns :SECOND-THROW." 'string)
+
+;; tree-equal - function
+(setq tree1 '(1 (1 2))
+ tree2 '(1 (1 2)))
+(eq-test t #'tree-equal tree1 tree2)
+(eq-test nil #'eql tree1 tree2)
+(setq tree1 '('a ('b 'c))
+ tree2 '('a ('b 'c)))
+(eq-test t #'tree-equal tree1 tree2 :test 'eq)
+(eq-test t #'tree-equal 1 1)
+(eq-test nil #'tree-equal (list 1 2) (cons 1 2))
+(eq-test nil #'tree-equal 1 2)
+
+;; union - function
+(equal-test '(b c f a d) #'union '(a b c) '(f a d))
+(equal-test '((y 6) (z 2) (x 4))
+ #'union '((x 5) (y 6)) '((z 2) (x 4)) :key #'car)
+(setq lst1 (list 1 2 '(1 2) "a" "b")
+ lst2 (list 2 3 '(2 3) "B" "C"))
+(equal-test '(1 (1 2) "a" "b" 2 3 (2 3) "B" "C") #'nunion lst1 lst2)
+
+;; unless - macro
+(eq-eval 'hello '(when t 'hello))
+(eq-eval nil '(unless t 'hello))
+(eq-eval nil (when nil 'hello))
+(eq-eval 'hello '(unless nil 'hello))
+(eq-eval nil (when t))
+(eql-eval nil '(unless nil))
+(setq test nil)
+(equal-eval '(3 2 1) '(when t (push 1 test) (push 2 test) (push 3 test)))
+(equal-eval '(3 2 1) 'test)
+(setq test nil)
+(eq-eval nil '(unless t (push 1 test) (push 2 test) (push 3 test)))
+(eq-eval nil 'test)
+(eq-eval nil '(when nil (push 1 test) (push 2 test) (push 3 test)))
+(eq-eval nil 'test)
+(equal-eval '(3 2 1) '(unless nil (push 1 test) (push 2 test) (push 3 test)))
+(equal-eval '(3 2 1) 'test)
+(equal-eval '((4) nil (5) nil 6 (6) 7 (7))
+ '(let ((x 3))
+ (list (when (oddp x) (incf x) (list x))
+ (when (oddp x) (incf x) (list x))
+ (unless (oddp x) (incf x) (list x))
+ (unless (oddp x) (incf x) (list x))
+ (if (oddp x) (incf x) (list x))
+ (if (oddp x) (incf x) (list x))
+ (if (not (oddp x)) (incf x) (list x))
+ (if (not (oddp x)) (incf x) (list x)))))
+
+;; unwind-protect - special operator
+(defun dummy-function (x)
+ (setq state 'running)
+ (unless (numberp x) (throw 'abort 'not-a-number))
+ (setq state (1+ x)))
+(eql-eval 2 '(catch 'abort (dummy-function 1)))
+(eql-eval 2 'state)
+(eq-eval 'not-a-number '(catch 'abort (dummy-function 'trash)))
+(eq-eval 'running 'state)
+(eq-eval 'not-a-number
+ '(catch 'abort (unwind-protect (dummy-function 'trash)
+ (setq state 'aborted))))
+(eq-eval 'aborted 'state)
+(eql-eval 2 '(block nil (unwind-protect (return 1) (return 2))))
+;; XXX undefined consequences
+(eql-eval 2
+ '(block a
+ (block b
+ (unwind-protect (return-from a 1)
+ (return-from b 2)))))
+(eql-eval 2 '(catch nil (unwind-protect (throw nil 1) (throw nil 2))))
+;; XXX undefined consequences
+(eql-eval 2
+ '(catch 'a (catch 'b (unwind-protect (throw 'a 1) (throw 'b 2)))))
+(eq-eval ':outer-catch
+ '(catch 'foo
+ (setq string
+ (format nil "The inner catch returns ~s."
+ (catch 'foo
+ (unwind-protect (throw 'foo :first-throw)
+ (throw 'foo :second-throw)))))
+ :outer-catch))
+(equal-eval "The inner catch returns :SECOND-THROW." 'string)
+(eql-eval 10
+ '(catch 'a
+ (catch 'b
+ (unwind-protect (1+ (catch 'a (throw 'b 1)))
+ (throw 'a 10)))))
+;; XXX undefined consequences
+(eql-eval 4
+ '(catch 'foo
+ (catch 'bar
+ (unwind-protect (throw 'foo 3)
+ (throw 'bar 4)
+ (print 'xxx)))))
+(eql-eval 4
+ '(catch 'bar
+ (catch 'foo
+ (unwind-protect (throw 'foo 3)
+ (throw 'bar 4)
+ (print 'xxx)))))
+(eql-eval 5
+ '(block nil
+ (let ((x 5))
+ (unwind-protect (return)
+ (return x)))))
+
+;; upper-case-p - function
+(eq-test t #'upper-case-p #\A)
+(eq-test nil #'upper-case-p #\a)
+(eq-test nil #'upper-case-p #\5)
+(error-test #'upper-case-p 1)
+
+;; values - accessor
+(eq-eval () '(multiple-value-list (values)))
+(equal-eval '(1) '(multiple-value-list (values 1)))
+(equal-eval '(1 2) '(multiple-value-list (values 1 2)))
+(equal-eval '(1 2 3) '(multiple-value-list (values 1 2 3)))
+(equal-eval '(1 4 5) '(multiple-value-list (values (values 1 2 3) 4 5)))
+
+;; values-list - function
+(eq-eval nil '(multiple-value-list (values-list nil)))
+(equal-eval '(1) '(multiple-value-list (values-list '(1))))
+(equal-eval '(1 2) '(multiple-value-list (values-list '(1 2))))
+(equal-eval '(1 2 3) '(multiple-value-list (values-list '(1 2 3))))
generated by cgit v1.2.3 (git 2.25.1) at 2024-11-21 18:22:14 +0000