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