ttests.lisp - clic - Clic is an command line interactive client for gopher written in Common LISP HTML git clone git://bitreich.org/clic/ git://hg6vgqziawt5s4dj.onion/clic/ DIR Log DIR Files DIR Refs DIR Tags DIR LICENSE --- ttests.lisp (54259B) --- 1 (in-package :cl-user) 2 3 (defpackage :alexandria-tests 4 (:use :cl :alexandria #+sbcl :sb-rt #-sbcl :rtest) 5 (:import-from #+sbcl :sb-rt #-sbcl :rtest 6 #:*compile-tests* #:*expected-failures*)) 7 8 (in-package :alexandria-tests) 9 10 (defun run-tests (&key ((:compiled *compile-tests*))) 11 (do-tests)) 12 13 (defun hash-table-test-name (name) 14 ;; Workaround for Clisp calling EQL in a hash-table FASTHASH-EQL. 15 (hash-table-test (make-hash-table :test name))) 16 17 ;;;; Arrays 18 19 (deftest copy-array.1 20 (let* ((orig (vector 1 2 3)) 21 (copy (copy-array orig))) 22 (values (eq orig copy) (equalp orig copy))) 23 nil t) 24 25 (deftest copy-array.2 26 (let ((orig (make-array 1024 :fill-pointer 0))) 27 (vector-push-extend 1 orig) 28 (vector-push-extend 2 orig) 29 (vector-push-extend 3 orig) 30 (let ((copy (copy-array orig))) 31 (values (eq orig copy) (equalp orig copy) 32 (array-has-fill-pointer-p copy) 33 (eql (fill-pointer orig) (fill-pointer copy))))) 34 nil t t t) 35 36 (deftest copy-array.3 37 (let* ((orig (vector 1 2 3)) 38 (copy (copy-array orig))) 39 (typep copy 'simple-array)) 40 t) 41 42 (deftest copy-array.4 43 (let ((orig (make-array 21 44 :adjustable t 45 :fill-pointer 0))) 46 (dotimes (n 42) 47 (vector-push-extend n orig)) 48 (let ((copy (copy-array orig 49 :adjustable nil 50 :fill-pointer nil))) 51 (typep copy 'simple-array))) 52 t) 53 54 (deftest array-index.1 55 (typep 0 'array-index) 56 t) 57 58 ;;;; Conditions 59 60 (deftest unwind-protect-case.1 61 (let (result) 62 (unwind-protect-case () 63 (random 10) 64 (:normal (push :normal result)) 65 (:abort (push :abort result)) 66 (:always (push :always result))) 67 result) 68 (:always :normal)) 69 70 (deftest unwind-protect-case.2 71 (let (result) 72 (unwind-protect-case () 73 (random 10) 74 (:always (push :always result)) 75 (:normal (push :normal result)) 76 (:abort (push :abort result))) 77 result) 78 (:normal :always)) 79 80 (deftest unwind-protect-case.3 81 (let (result1 result2 result3) 82 (ignore-errors 83 (unwind-protect-case () 84 (error "FOOF!") 85 (:normal (push :normal result1)) 86 (:abort (push :abort result1)) 87 (:always (push :always result1)))) 88 (catch 'foof 89 (unwind-protect-case () 90 (throw 'foof 42) 91 (:normal (push :normal result2)) 92 (:abort (push :abort result2)) 93 (:always (push :always result2)))) 94 (block foof 95 (unwind-protect-case () 96 (return-from foof 42) 97 (:normal (push :normal result3)) 98 (:abort (push :abort result3)) 99 (:always (push :always result3)))) 100 (values result1 result2 result3)) 101 (:always :abort) 102 (:always :abort) 103 (:always :abort)) 104 105 (deftest unwind-protect-case.4 106 (let (result) 107 (unwind-protect-case (aborted-p) 108 (random 42) 109 (:always (setq result aborted-p))) 110 result) 111 nil) 112 113 (deftest unwind-protect-case.5 114 (let (result) 115 (block foof 116 (unwind-protect-case (aborted-p) 117 (return-from foof) 118 (:always (setq result aborted-p)))) 119 result) 120 t) 121 122 ;;;; Control flow 123 124 (deftest switch.1 125 (switch (13 :test =) 126 (12 :oops) 127 (13.0 :yay)) 128 :yay) 129 130 (deftest switch.2 131 (switch (13) 132 ((+ 12 2) :oops) 133 ((- 13 1) :oops2) 134 (t :yay)) 135 :yay) 136 137 (deftest eswitch.1 138 (let ((x 13)) 139 (eswitch (x :test =) 140 (12 :oops) 141 (13.0 :yay))) 142 :yay) 143 144 (deftest eswitch.2 145 (let ((x 13)) 146 (eswitch (x :key 1+) 147 (11 :oops) 148 (14 :yay))) 149 :yay) 150 151 (deftest cswitch.1 152 (cswitch (13 :test =) 153 (12 :oops) 154 (13.0 :yay)) 155 :yay) 156 157 (deftest cswitch.2 158 (cswitch (13 :key 1-) 159 (12 :yay) 160 (13.0 :oops)) 161 :yay) 162 163 (deftest multiple-value-prog2.1 164 (multiple-value-prog2 165 (values 1 1 1) 166 (values 2 20 200) 167 (values 3 3 3)) 168 2 20 200) 169 170 (deftest nth-value-or.1 171 (multiple-value-bind (a b c) 172 (nth-value-or 1 173 (values 1 nil 1) 174 (values 2 2 2)) 175 (= a b c 2)) 176 t) 177 178 (deftest whichever.1 179 (let ((x (whichever 1 2 3))) 180 (and (member x '(1 2 3)) t)) 181 t) 182 183 (deftest whichever.2 184 (let* ((a 1) 185 (b 2) 186 (c 3) 187 (x (whichever a b c))) 188 (and (member x '(1 2 3)) t)) 189 t) 190 191 (deftest xor.1 192 (xor nil nil 1 nil) 193 1 194 t) 195 196 (deftest xor.2 197 (xor nil nil 1 2) 198 nil 199 nil) 200 201 (deftest xor.3 202 (xor nil nil nil) 203 nil 204 t) 205 206 ;;;; Definitions 207 208 (deftest define-constant.1 209 (let ((name (gensym))) 210 (eval `(define-constant ,name "FOO" :test 'equal)) 211 (eval `(define-constant ,name "FOO" :test 'equal)) 212 (values (equal "FOO" (symbol-value name)) 213 (constantp name))) 214 t 215 t) 216 217 (deftest define-constant.2 218 (let ((name (gensym))) 219 (eval `(define-constant ,name 13)) 220 (eval `(define-constant ,name 13)) 221 (values (eql 13 (symbol-value name)) 222 (constantp name))) 223 t 224 t) 225 226 ;;;; Errors 227 228 ;;; TYPEP is specified to return a generalized boolean and, for 229 ;;; example, ECL exploits this by returning the superclasses of ERROR 230 ;;; in this case. 231 (defun errorp (x) 232 (not (null (typep x 'error)))) 233 234 (deftest required-argument.1 235 (multiple-value-bind (res err) 236 (ignore-errors (required-argument)) 237 (errorp err)) 238 t) 239 240 ;;;; Hash tables 241 242 (deftest ensure-gethash.1 243 (let ((table (make-hash-table)) 244 (x (list 1))) 245 (multiple-value-bind (value already-there) 246 (ensure-gethash x table 42) 247 (and (= value 42) 248 (not already-there) 249 (= 42 (gethash x table)) 250 (multiple-value-bind (value2 already-there2) 251 (ensure-gethash x table 13) 252 (and (= value2 42) 253 already-there2 254 (= 42 (gethash x table))))))) 255 t) 256 257 (deftest ensure-gethash.2 258 (let ((table (make-hash-table)) 259 (count 0)) 260 (multiple-value-call #'values 261 (ensure-gethash (progn (incf count) :foo) 262 (progn (incf count) table) 263 (progn (incf count) :bar)) 264 (gethash :foo table) 265 count)) 266 :bar nil :bar t 3) 267 268 (deftest copy-hash-table.1 269 (let ((orig (make-hash-table :test 'eq :size 123)) 270 (foo "foo")) 271 (setf (gethash orig orig) t 272 (gethash foo orig) t) 273 (let ((eq-copy (copy-hash-table orig)) 274 (eql-copy (copy-hash-table orig :test 'eql)) 275 (equal-copy (copy-hash-table orig :test 'equal)) 276 (equalp-copy (copy-hash-table orig :test 'equalp))) 277 (list (eql (hash-table-size eq-copy) (hash-table-size orig)) 278 (eql (hash-table-rehash-size eq-copy) 279 (hash-table-rehash-size orig)) 280 (hash-table-count eql-copy) 281 (gethash orig eq-copy) 282 (gethash (copy-seq foo) eql-copy) 283 (gethash foo eql-copy) 284 (gethash (copy-seq foo) equal-copy) 285 (gethash "FOO" equal-copy) 286 (gethash "FOO" equalp-copy)))) 287 (t t 2 t nil t t nil t)) 288 289 (deftest copy-hash-table.2 290 (let ((ht (make-hash-table)) 291 (list (list :list (vector :A :B :C)))) 292 (setf (gethash 'list ht) list) 293 (let* ((shallow-copy (copy-hash-table ht)) 294 (deep1-copy (copy-hash-table ht :key 'copy-list)) 295 (list (gethash 'list ht)) 296 (shallow-list (gethash 'list shallow-copy)) 297 (deep1-list (gethash 'list deep1-copy))) 298 (list (eq ht shallow-copy) 299 (eq ht deep1-copy) 300 (eq list shallow-list) 301 (eq list deep1-list) ; outer list was copied. 302 (eq (second list) (second shallow-list)) 303 (eq (second list) (second deep1-list)) ; inner vector wasn't copied. 304 ))) 305 (nil nil t nil t t)) 306 307 (deftest maphash-keys.1 308 (let ((keys nil) 309 (table (make-hash-table))) 310 (declare (notinline maphash-keys)) 311 (dotimes (i 10) 312 (setf (gethash i table) t)) 313 (maphash-keys (lambda (k) (push k keys)) table) 314 (set-equal keys '(0 1 2 3 4 5 6 7 8 9))) 315 t) 316 317 (deftest maphash-values.1 318 (let ((vals nil) 319 (table (make-hash-table))) 320 (declare (notinline maphash-values)) 321 (dotimes (i 10) 322 (setf (gethash i table) (- i))) 323 (maphash-values (lambda (v) (push v vals)) table) 324 (set-equal vals '(0 -1 -2 -3 -4 -5 -6 -7 -8 -9))) 325 t) 326 327 (deftest hash-table-keys.1 328 (let ((table (make-hash-table))) 329 (dotimes (i 10) 330 (setf (gethash i table) t)) 331 (set-equal (hash-table-keys table) '(0 1 2 3 4 5 6 7 8 9))) 332 t) 333 334 (deftest hash-table-values.1 335 (let ((table (make-hash-table))) 336 (dotimes (i 10) 337 (setf (gethash (gensym) table) i)) 338 (set-equal (hash-table-values table) '(0 1 2 3 4 5 6 7 8 9))) 339 t) 340 341 (deftest hash-table-alist.1 342 (let ((table (make-hash-table))) 343 (dotimes (i 10) 344 (setf (gethash i table) (- i))) 345 (let ((alist (hash-table-alist table))) 346 (list (length alist) 347 (assoc 0 alist) 348 (assoc 3 alist) 349 (assoc 9 alist) 350 (assoc nil alist)))) 351 (10 (0 . 0) (3 . -3) (9 . -9) nil)) 352 353 (deftest hash-table-plist.1 354 (let ((table (make-hash-table))) 355 (dotimes (i 10) 356 (setf (gethash i table) (- i))) 357 (let ((plist (hash-table-plist table))) 358 (list (length plist) 359 (getf plist 0) 360 (getf plist 2) 361 (getf plist 7) 362 (getf plist nil)))) 363 (20 0 -2 -7 nil)) 364 365 (deftest alist-hash-table.1 366 (let* ((alist '((0 a) (1 b) (2 c))) 367 (table (alist-hash-table alist))) 368 (list (hash-table-count table) 369 (gethash 0 table) 370 (gethash 1 table) 371 (gethash 2 table) 372 (eq (hash-table-test-name 'eql) 373 (hash-table-test table)))) 374 (3 (a) (b) (c) t)) 375 376 (deftest alist-hash-table.duplicate-keys 377 (let* ((alist '((0 a) (1 b) (0 c) (1 d) (2 e))) 378 (table (alist-hash-table alist))) 379 (list (hash-table-count table) 380 (gethash 0 table) 381 (gethash 1 table) 382 (gethash 2 table))) 383 (3 (a) (b) (e))) 384 385 (deftest plist-hash-table.1 386 (let* ((plist '(:a 1 :b 2 :c 3)) 387 (table (plist-hash-table plist :test 'eq))) 388 (list (hash-table-count table) 389 (gethash :a table) 390 (gethash :b table) 391 (gethash :c table) 392 (gethash 2 table) 393 (gethash nil table) 394 (eq (hash-table-test-name 'eq) 395 (hash-table-test table)))) 396 (3 1 2 3 nil nil t)) 397 398 (deftest plist-hash-table.duplicate-keys 399 (let* ((plist '(:a 1 :b 2 :a 3 :b 4 :c 5)) 400 (table (plist-hash-table plist))) 401 (list (hash-table-count table) 402 (gethash :a table) 403 (gethash :b table) 404 (gethash :c table))) 405 (3 1 2 5)) 406 407 ;;;; Functions 408 409 (deftest disjoin.1 410 (let ((disjunction (disjoin (lambda (x) 411 (and (consp x) :cons)) 412 (lambda (x) 413 (and (stringp x) :string))))) 414 (list (funcall disjunction 'zot) 415 (funcall disjunction '(foo bar)) 416 (funcall disjunction "test"))) 417 (nil :cons :string)) 418 419 (deftest disjoin.2 420 (let ((disjunction (disjoin #'zerop))) 421 (list (funcall disjunction 0) 422 (funcall disjunction 1))) 423 (t nil)) 424 425 (deftest conjoin.1 426 (let ((conjunction (conjoin #'consp 427 (lambda (x) 428 (stringp (car x))) 429 (lambda (x) 430 (char (car x) 0))))) 431 (list (funcall conjunction 'zot) 432 (funcall conjunction '(foo)) 433 (funcall conjunction '("foo")))) 434 (nil nil #\f)) 435 436 (deftest conjoin.2 437 (let ((conjunction (conjoin #'zerop))) 438 (list (funcall conjunction 0) 439 (funcall conjunction 1))) 440 (t nil)) 441 442 (deftest compose.1 443 (let ((composite (compose '1+ 444 (lambda (x) 445 (* x 2)) 446 #'read-from-string))) 447 (funcall composite "1")) 448 3) 449 450 (deftest compose.2 451 (let ((composite 452 (locally (declare (notinline compose)) 453 (compose '1+ 454 (lambda (x) 455 (* x 2)) 456 #'read-from-string)))) 457 (funcall composite "2")) 458 5) 459 460 (deftest compose.3 461 (let ((compose-form (funcall (compiler-macro-function 'compose) 462 '(compose '1+ 463 (lambda (x) 464 (* x 2)) 465 #'read-from-string) 466 nil))) 467 (let ((fun (funcall (compile nil `(lambda () ,compose-form))))) 468 (funcall fun "3"))) 469 7) 470 471 (deftest compose.4 472 (let ((composite (compose #'zerop))) 473 (list (funcall composite 0) 474 (funcall composite 1))) 475 (t nil)) 476 477 (deftest multiple-value-compose.1 478 (let ((composite (multiple-value-compose 479 #'truncate 480 (lambda (x y) 481 (values y x)) 482 (lambda (x) 483 (with-input-from-string (s x) 484 (values (read s) (read s))))))) 485 (multiple-value-list (funcall composite "2 7"))) 486 (3 1)) 487 488 (deftest multiple-value-compose.2 489 (let ((composite (locally (declare (notinline multiple-value-compose)) 490 (multiple-value-compose 491 #'truncate 492 (lambda (x y) 493 (values y x)) 494 (lambda (x) 495 (with-input-from-string (s x) 496 (values (read s) (read s)))))))) 497 (multiple-value-list (funcall composite "2 11"))) 498 (5 1)) 499 500 (deftest multiple-value-compose.3 501 (let ((compose-form (funcall (compiler-macro-function 'multiple-value-compose) 502 '(multiple-value-compose 503 #'truncate 504 (lambda (x y) 505 (values y x)) 506 (lambda (x) 507 (with-input-from-string (s x) 508 (values (read s) (read s))))) 509 nil))) 510 (let ((fun (funcall (compile nil `(lambda () ,compose-form))))) 511 (multiple-value-list (funcall fun "2 9")))) 512 (4 1)) 513 514 (deftest multiple-value-compose.4 515 (let ((composite (multiple-value-compose #'truncate))) 516 (multiple-value-list (funcall composite 9 2))) 517 (4 1)) 518 519 (deftest curry.1 520 (let ((curried (curry '+ 3))) 521 (funcall curried 1 5)) 522 9) 523 524 (deftest curry.2 525 (let ((curried (locally (declare (notinline curry)) 526 (curry '* 2 3)))) 527 (funcall curried 7)) 528 42) 529 530 (deftest curry.3 531 (let ((curried-form (funcall (compiler-macro-function 'curry) 532 '(curry '/ 8) 533 nil))) 534 (let ((fun (funcall (compile nil `(lambda () ,curried-form))))) 535 (funcall fun 2))) 536 4) 537 538 (deftest curry.4 539 (let* ((x 1) 540 (curried (curry (progn 541 (incf x) 542 (lambda (y z) (* x y z))) 543 3))) 544 (list (funcall curried 7) 545 (funcall curried 7) 546 x)) 547 (42 42 2)) 548 549 (deftest rcurry.1 550 (let ((r (rcurry '/ 2))) 551 (funcall r 8)) 552 4) 553 554 (deftest rcurry.2 555 (let* ((x 1) 556 (curried (rcurry (progn 557 (incf x) 558 (lambda (y z) (* x y z))) 559 3))) 560 (list (funcall curried 7) 561 (funcall curried 7) 562 x)) 563 (42 42 2)) 564 565 (deftest named-lambda.1 566 (let ((fac (named-lambda fac (x) 567 (if (> x 1) 568 (* x (fac (- x 1))) 569 x)))) 570 (funcall fac 5)) 571 120) 572 573 (deftest named-lambda.2 574 (let ((fac (named-lambda fac (&key x) 575 (if (> x 1) 576 (* x (fac :x (- x 1))) 577 x)))) 578 (funcall fac :x 5)) 579 120) 580 581 ;;;; Lists 582 583 (deftest alist-plist.1 584 (alist-plist '((a . 1) (b . 2) (c . 3))) 585 (a 1 b 2 c 3)) 586 587 (deftest plist-alist.1 588 (plist-alist '(a 1 b 2 c 3)) 589 ((a . 1) (b . 2) (c . 3))) 590 591 (deftest unionf.1 592 (let* ((list (list 1 2 3)) 593 (orig list)) 594 (unionf list (list 1 2 4)) 595 (values (equal orig (list 1 2 3)) 596 (eql (length list) 4) 597 (set-difference list (list 1 2 3 4)) 598 (set-difference (list 1 2 3 4) list))) 599 t 600 t 601 nil 602 nil) 603 604 (deftest nunionf.1 605 (let ((list (list 1 2 3))) 606 (nunionf list (list 1 2 4)) 607 (values (eql (length list) 4) 608 (set-difference (list 1 2 3 4) list) 609 (set-difference list (list 1 2 3 4)))) 610 t 611 nil 612 nil) 613 614 (deftest appendf.1 615 (let* ((list (list 1 2 3)) 616 (orig list)) 617 (appendf list '(4 5 6) '(7 8)) 618 (list list (eq list orig))) 619 ((1 2 3 4 5 6 7 8) nil)) 620 621 (deftest nconcf.1 622 (let ((list1 (list 1 2 3)) 623 (list2 (list 4 5 6))) 624 (nconcf list1 list2 (list 7 8 9)) 625 list1) 626 (1 2 3 4 5 6 7 8 9)) 627 628 (deftest circular-list.1 629 (let ((circle (circular-list 1 2 3))) 630 (list (first circle) 631 (second circle) 632 (third circle) 633 (fourth circle) 634 (eq circle (nthcdr 3 circle)))) 635 (1 2 3 1 t)) 636 637 (deftest circular-list-p.1 638 (let* ((circle (circular-list 1 2 3 4)) 639 (tree (list circle circle)) 640 (dotted (cons circle t)) 641 (proper (list 1 2 3 circle)) 642 (tailcirc (list* 1 2 3 circle))) 643 (list (circular-list-p circle) 644 (circular-list-p tree) 645 (circular-list-p dotted) 646 (circular-list-p proper) 647 (circular-list-p tailcirc))) 648 (t nil nil nil t)) 649 650 (deftest circular-list-p.2 651 (circular-list-p 'foo) 652 nil) 653 654 (deftest circular-tree-p.1 655 (let* ((circle (circular-list 1 2 3 4)) 656 (tree1 (list circle circle)) 657 (tree2 (let* ((level2 (list 1 nil 2)) 658 (level1 (list level2))) 659 (setf (second level2) level1) 660 level1)) 661 (dotted (cons circle t)) 662 (proper (list 1 2 3 circle)) 663 (tailcirc (list* 1 2 3 circle)) 664 (quite-proper (list 1 2 3)) 665 (quite-dotted (list 1 (cons 2 3)))) 666 (list (circular-tree-p circle) 667 (circular-tree-p tree1) 668 (circular-tree-p tree2) 669 (circular-tree-p dotted) 670 (circular-tree-p proper) 671 (circular-tree-p tailcirc) 672 (circular-tree-p quite-proper) 673 (circular-tree-p quite-dotted))) 674 (t t t t t t nil nil)) 675 676 (deftest circular-tree-p.2 677 (alexandria:circular-tree-p '#1=(#1#)) 678 t) 679 680 (deftest proper-list-p.1 681 (let ((l1 (list 1)) 682 (l2 (list 1 2)) 683 (l3 (cons 1 2)) 684 (l4 (list (cons 1 2) 3)) 685 (l5 (circular-list 1 2))) 686 (list (proper-list-p l1) 687 (proper-list-p l2) 688 (proper-list-p l3) 689 (proper-list-p l4) 690 (proper-list-p l5))) 691 (t t nil t nil)) 692 693 (deftest proper-list-p.2 694 (proper-list-p '(1 2 . 3)) 695 nil) 696 697 (deftest proper-list.type.1 698 (let ((l1 (list 1)) 699 (l2 (list 1 2)) 700 (l3 (cons 1 2)) 701 (l4 (list (cons 1 2) 3)) 702 (l5 (circular-list 1 2))) 703 (list (typep l1 'proper-list) 704 (typep l2 'proper-list) 705 (typep l3 'proper-list) 706 (typep l4 'proper-list) 707 (typep l5 'proper-list))) 708 (t t nil t nil)) 709 710 (deftest proper-list-length.1 711 (values 712 (proper-list-length nil) 713 (proper-list-length (list 1)) 714 (proper-list-length (list 2 2)) 715 (proper-list-length (list 3 3 3)) 716 (proper-list-length (list 4 4 4 4)) 717 (proper-list-length (list 5 5 5 5 5)) 718 (proper-list-length (list 6 6 6 6 6 6)) 719 (proper-list-length (list 7 7 7 7 7 7 7)) 720 (proper-list-length (list 8 8 8 8 8 8 8 8)) 721 (proper-list-length (list 9 9 9 9 9 9 9 9 9))) 722 0 1 2 3 4 5 6 7 8 9) 723 724 (deftest proper-list-length.2 725 (flet ((plength (x) 726 (handler-case 727 (proper-list-length x) 728 (type-error () 729 :ok)))) 730 (values 731 (plength (list* 1)) 732 (plength (list* 2 2)) 733 (plength (list* 3 3 3)) 734 (plength (list* 4 4 4 4)) 735 (plength (list* 5 5 5 5 5)) 736 (plength (list* 6 6 6 6 6 6)) 737 (plength (list* 7 7 7 7 7 7 7)) 738 (plength (list* 8 8 8 8 8 8 8 8)) 739 (plength (list* 9 9 9 9 9 9 9 9 9)))) 740 :ok :ok :ok 741 :ok :ok :ok 742 :ok :ok :ok) 743 744 (deftest lastcar.1 745 (let ((l1 (list 1)) 746 (l2 (list 1 2))) 747 (list (lastcar l1) 748 (lastcar l2))) 749 (1 2)) 750 751 (deftest lastcar.error.2 752 (handler-case 753 (progn 754 (lastcar (circular-list 1 2 3)) 755 nil) 756 (error () 757 t)) 758 t) 759 760 (deftest setf-lastcar.1 761 (let ((l (list 1 2 3 4))) 762 (values (lastcar l) 763 (progn 764 (setf (lastcar l) 42) 765 (lastcar l)))) 766 4 767 42) 768 769 (deftest setf-lastcar.2 770 (let ((l (circular-list 1 2 3))) 771 (multiple-value-bind (res err) 772 (ignore-errors (setf (lastcar l) 4)) 773 (typep err 'type-error))) 774 t) 775 776 (deftest make-circular-list.1 777 (let ((l (make-circular-list 3 :initial-element :x))) 778 (setf (car l) :y) 779 (list (eq l (nthcdr 3 l)) 780 (first l) 781 (second l) 782 (third l) 783 (fourth l))) 784 (t :y :x :x :y)) 785 786 (deftest circular-list.type.1 787 (let* ((l1 (list 1 2 3)) 788 (l2 (circular-list 1 2 3)) 789 (l3 (list* 1 2 3 l2))) 790 (list (typep l1 'circular-list) 791 (typep l2 'circular-list) 792 (typep l3 'circular-list))) 793 (nil t t)) 794 795 (deftest ensure-list.1 796 (let ((x (list 1)) 797 (y 2)) 798 (list (ensure-list x) 799 (ensure-list y))) 800 ((1) (2))) 801 802 (deftest ensure-cons.1 803 (let ((x (cons 1 2)) 804 (y nil) 805 (z "foo")) 806 (values (ensure-cons x) 807 (ensure-cons y) 808 (ensure-cons z))) 809 (1 . 2) 810 (nil) 811 ("foo")) 812 813 (deftest setp.1 814 (setp '(1)) 815 t) 816 817 (deftest setp.2 818 (setp nil) 819 t) 820 821 (deftest setp.3 822 (setp "foo") 823 nil) 824 825 (deftest setp.4 826 (setp '(1 2 3 1)) 827 nil) 828 829 (deftest setp.5 830 (setp '(1 2 3)) 831 t) 832 833 (deftest setp.6 834 (setp '(a :a)) 835 t) 836 837 (deftest setp.7 838 (setp '(a :a) :key 'character) 839 nil) 840 841 (deftest setp.8 842 (setp '(a :a) :key 'character :test (constantly nil)) 843 t) 844 845 (deftest set-equal.1 846 (set-equal '(1 2 3) '(3 1 2)) 847 t) 848 849 (deftest set-equal.2 850 (set-equal '("Xa") '("Xb") 851 :test (lambda (a b) (eql (char a 0) (char b 0)))) 852 t) 853 854 (deftest set-equal.3 855 (set-equal '(1 2) '(4 2)) 856 nil) 857 858 (deftest set-equal.4 859 (set-equal '(a b c) '(:a :b :c) :key 'string :test 'equal) 860 t) 861 862 (deftest set-equal.5 863 (set-equal '(a d c) '(:a :b :c) :key 'string :test 'equal) 864 nil) 865 866 (deftest set-equal.6 867 (set-equal '(a b c) '(a b c d)) 868 nil) 869 870 (deftest map-product.1 871 (map-product 'cons '(2 3) '(1 4)) 872 ((2 . 1) (2 . 4) (3 . 1) (3 . 4))) 873 874 (deftest map-product.2 875 (map-product #'cons '(2 3) '(1 4)) 876 ((2 . 1) (2 . 4) (3 . 1) (3 . 4))) 877 878 (deftest flatten.1 879 (flatten '((1) 2 (((3 4))) ((((5)) 6)) 7)) 880 (1 2 3 4 5 6 7)) 881 882 (deftest remove-from-plist.1 883 (let ((orig '(a 1 b 2 c 3 d 4))) 884 (list (remove-from-plist orig 'a 'c) 885 (remove-from-plist orig 'b 'd) 886 (remove-from-plist orig 'b) 887 (remove-from-plist orig 'a) 888 (remove-from-plist orig 'd 42 "zot") 889 (remove-from-plist orig 'a 'b 'c 'd) 890 (remove-from-plist orig 'a 'b 'c 'd 'x) 891 (equal orig '(a 1 b 2 c 3 d 4)))) 892 ((b 2 d 4) 893 (a 1 c 3) 894 (a 1 c 3 d 4) 895 (b 2 c 3 d 4) 896 (a 1 b 2 c 3) 897 nil 898 nil 899 t)) 900 901 (deftest delete-from-plist.1 902 (let ((orig '(a 1 b 2 c 3 d 4 d 5))) 903 (list (delete-from-plist (copy-list orig) 'a 'c) 904 (delete-from-plist (copy-list orig) 'b 'd) 905 (delete-from-plist (copy-list orig) 'b) 906 (delete-from-plist (copy-list orig) 'a) 907 (delete-from-plist (copy-list orig) 'd 42 "zot") 908 (delete-from-plist (copy-list orig) 'a 'b 'c 'd) 909 (delete-from-plist (copy-list orig) 'a 'b 'c 'd 'x) 910 (equal orig (delete-from-plist orig)) 911 (eq orig (delete-from-plist orig)))) 912 ((b 2 d 4 d 5) 913 (a 1 c 3) 914 (a 1 c 3 d 4 d 5) 915 (b 2 c 3 d 4 d 5) 916 (a 1 b 2 c 3) 917 nil 918 nil 919 t 920 t)) 921 922 (deftest mappend.1 923 (mappend (compose 'list '*) '(1 2 3) '(1 2 3)) 924 (1 4 9)) 925 926 (deftest assoc-value.1 927 (let ((key1 '(complex key)) 928 (key2 'simple-key) 929 (alist '()) 930 (result '())) 931 (push 1 (assoc-value alist key1 :test #'equal)) 932 (push 2 (assoc-value alist key1 :test 'equal)) 933 (push 42 (assoc-value alist key2)) 934 (push 43 (assoc-value alist key2 :test 'eq)) 935 (push (assoc-value alist key1 :test #'equal) result) 936 (push (assoc-value alist key2) result) 937 938 (push 'very (rassoc-value alist (list 2 1) :test #'equal)) 939 (push (cdr (assoc '(very complex key) alist :test #'equal)) result) 940 result) 941 ((2 1) (43 42) (2 1))) 942 943 ;;;; Numbers 944 945 (deftest clamp.1 946 (list (clamp 1.5 1 2) 947 (clamp 2.0 1 2) 948 (clamp 1.0 1 2) 949 (clamp 3 1 2) 950 (clamp 0 1 2)) 951 (1.5 2.0 1.0 2 1)) 952 953 (deftest gaussian-random.1 954 (let ((min -0.2) 955 (max +0.2)) 956 (multiple-value-bind (g1 g2) 957 (gaussian-random min max) 958 (values (<= min g1 max) 959 (<= min g2 max) 960 (/= g1 g2) ;uh 961 ))) 962 t 963 t 964 t) 965 966 #+sbcl 967 (deftest gaussian-random.2 968 (handler-case 969 (sb-ext:with-timeout 2 970 (progn 971 (loop 972 :repeat 10000 973 :do (gaussian-random 0 nil)) 974 'done)) 975 (sb-ext:timeout () 976 'timed-out)) 977 done) 978 979 (deftest iota.1 980 (iota 3) 981 (0 1 2)) 982 983 (deftest iota.2 984 (iota 3 :start 0.0d0) 985 (0.0d0 1.0d0 2.0d0)) 986 987 (deftest iota.3 988 (iota 3 :start 2 :step 3.0) 989 (2.0 5.0 8.0)) 990 991 (deftest map-iota.1 992 (let (all) 993 (declare (notinline map-iota)) 994 (values (map-iota (lambda (x) (push x all)) 995 3 996 :start 2 997 :step 1.1d0) 998 all)) 999 3 1000 (4.2d0 3.1d0 2.0d0)) 1001 1002 (deftest lerp.1 1003 (lerp 0.5 1 2) 1004 1.5) 1005 1006 (deftest lerp.2 1007 (lerp 0.1 1 2) 1008 1.1) 1009 1010 (deftest lerp.3 1011 (lerp 0.1 4 25) 1012 6.1) 1013 1014 (deftest mean.1 1015 (mean '(1 2 3)) 1016 2) 1017 1018 (deftest mean.2 1019 (mean '(1 2 3 4)) 1020 5/2) 1021 1022 (deftest mean.3 1023 (mean '(1 2 10)) 1024 13/3) 1025 1026 (deftest median.1 1027 (median '(100 0 99 1 98 2 97)) 1028 97) 1029 1030 (deftest median.2 1031 (median '(100 0 99 1 98 2 97 96)) 1032 193/2) 1033 1034 (deftest variance.1 1035 (variance (list 1 2 3)) 1036 2/3) 1037 1038 (deftest standard-deviation.1 1039 (< 0 (standard-deviation (list 1 2 3)) 1) 1040 t) 1041 1042 (deftest maxf.1 1043 (let ((x 1)) 1044 (maxf x 2) 1045 x) 1046 2) 1047 1048 (deftest maxf.2 1049 (let ((x 1)) 1050 (maxf x 0) 1051 x) 1052 1) 1053 1054 (deftest maxf.3 1055 (let ((x 1) 1056 (c 0)) 1057 (maxf x (incf c)) 1058 (list x c)) 1059 (1 1)) 1060 1061 (deftest maxf.4 1062 (let ((xv (vector 0 0 0)) 1063 (p 0)) 1064 (maxf (svref xv (incf p)) (incf p)) 1065 (list p xv)) 1066 (2 #(0 2 0))) 1067 1068 (deftest minf.1 1069 (let ((y 1)) 1070 (minf y 0) 1071 y) 1072 0) 1073 1074 (deftest minf.2 1075 (let ((xv (vector 10 10 10)) 1076 (p 0)) 1077 (minf (svref xv (incf p)) (incf p)) 1078 (list p xv)) 1079 (2 #(10 2 10))) 1080 1081 (deftest subfactorial.1 1082 (mapcar #'subfactorial (iota 22)) 1083 (1 1084 0 1085 1 1086 2 1087 9 1088 44 1089 265 1090 1854 1091 14833 1092 133496 1093 1334961 1094 14684570 1095 176214841 1096 2290792932 1097 32071101049 1098 481066515734 1099 7697064251745 1100 130850092279664 1101 2355301661033953 1102 44750731559645106 1103 895014631192902121 1104 18795307255050944540)) 1105 1106 ;;;; Arrays 1107 1108 #+nil 1109 (deftest array-index.type) 1110 1111 #+nil 1112 (deftest copy-array) 1113 1114 ;;;; Sequences 1115 1116 (deftest rotate.1 1117 (list (rotate (list 1 2 3) 0) 1118 (rotate (list 1 2 3) 1) 1119 (rotate (list 1 2 3) 2) 1120 (rotate (list 1 2 3) 3) 1121 (rotate (list 1 2 3) 4)) 1122 ((1 2 3) 1123 (3 1 2) 1124 (2 3 1) 1125 (1 2 3) 1126 (3 1 2))) 1127 1128 (deftest rotate.2 1129 (list (rotate (vector 1 2 3 4) 0) 1130 (rotate (vector 1 2 3 4)) 1131 (rotate (vector 1 2 3 4) 2) 1132 (rotate (vector 1 2 3 4) 3) 1133 (rotate (vector 1 2 3 4) 4) 1134 (rotate (vector 1 2 3 4) 5)) 1135 (#(1 2 3 4) 1136 #(4 1 2 3) 1137 #(3 4 1 2) 1138 #(2 3 4 1) 1139 #(1 2 3 4) 1140 #(4 1 2 3))) 1141 1142 (deftest rotate.3 1143 (list (rotate (list 1 2 3) 0) 1144 (rotate (list 1 2 3) -1) 1145 (rotate (list 1 2 3) -2) 1146 (rotate (list 1 2 3) -3) 1147 (rotate (list 1 2 3) -4)) 1148 ((1 2 3) 1149 (2 3 1) 1150 (3 1 2) 1151 (1 2 3) 1152 (2 3 1))) 1153 1154 (deftest rotate.4 1155 (list (rotate (vector 1 2 3 4) 0) 1156 (rotate (vector 1 2 3 4) -1) 1157 (rotate (vector 1 2 3 4) -2) 1158 (rotate (vector 1 2 3 4) -3) 1159 (rotate (vector 1 2 3 4) -4) 1160 (rotate (vector 1 2 3 4) -5)) 1161 (#(1 2 3 4) 1162 #(2 3 4 1) 1163 #(3 4 1 2) 1164 #(4 1 2 3) 1165 #(1 2 3 4) 1166 #(2 3 4 1))) 1167 1168 (deftest rotate.5 1169 (values (rotate (list 1) 17) 1170 (rotate (list 1) -5)) 1171 (1) 1172 (1)) 1173 1174 (deftest shuffle.1 1175 (let ((s (shuffle (iota 100)))) 1176 (list (equal s (iota 100)) 1177 (every (lambda (x) 1178 (member x s)) 1179 (iota 100)) 1180 (every (lambda (x) 1181 (typep x '(integer 0 99))) 1182 s))) 1183 (nil t t)) 1184 1185 (deftest shuffle.2 1186 (let ((s (shuffle (coerce (iota 100) 'vector)))) 1187 (list (equal s (coerce (iota 100) 'vector)) 1188 (every (lambda (x) 1189 (find x s)) 1190 (iota 100)) 1191 (every (lambda (x) 1192 (typep x '(integer 0 99))) 1193 s))) 1194 (nil t t)) 1195 1196 (deftest shuffle.3 1197 (let* ((orig (coerce (iota 21) 'vector)) 1198 (copy (copy-seq orig))) 1199 (shuffle copy :start 10 :end 15) 1200 (list (every #'eql (subseq copy 0 10) (subseq orig 0 10)) 1201 (every #'eql (subseq copy 15) (subseq orig 15)))) 1202 (t t)) 1203 1204 (deftest random-elt.1 1205 (let ((s1 #(1 2 3 4)) 1206 (s2 '(1 2 3 4))) 1207 (list (dotimes (i 1000 nil) 1208 (unless (member (random-elt s1) s2) 1209 (return nil)) 1210 (when (/= (random-elt s1) (random-elt s1)) 1211 (return t))) 1212 (dotimes (i 1000 nil) 1213 (unless (member (random-elt s2) s2) 1214 (return nil)) 1215 (when (/= (random-elt s2) (random-elt s2)) 1216 (return t))))) 1217 (t t)) 1218 1219 (deftest removef.1 1220 (let* ((x '(1 2 3)) 1221 (x* x) 1222 (y #(1 2 3)) 1223 (y* y)) 1224 (removef x 1) 1225 (removef y 3) 1226 (list x x* y y*)) 1227 ((2 3) 1228 (1 2 3) 1229 #(1 2) 1230 #(1 2 3))) 1231 1232 (deftest deletef.1 1233 (let* ((x (list 1 2 3)) 1234 (x* x) 1235 (y (vector 1 2 3))) 1236 (deletef x 2) 1237 (deletef y 1) 1238 (list x x* y)) 1239 ((1 3) 1240 (1 3) 1241 #(2 3))) 1242 1243 (deftest map-permutations.1 1244 (let ((seq (list 1 2 3)) 1245 (seen nil) 1246 (ok t)) 1247 (map-permutations (lambda (s) 1248 (unless (set-equal s seq) 1249 (setf ok nil)) 1250 (when (member s seen :test 'equal) 1251 (setf ok nil)) 1252 (push s seen)) 1253 seq 1254 :copy t) 1255 (values ok (length seen))) 1256 t 1257 6) 1258 1259 (deftest proper-sequence.type.1 1260 (mapcar (lambda (x) 1261 (typep x 'proper-sequence)) 1262 (list (list 1 2 3) 1263 (vector 1 2 3) 1264 #2a((1 2) (3 4)) 1265 (circular-list 1 2 3 4))) 1266 (t t nil nil)) 1267 1268 (deftest emptyp.1 1269 (mapcar #'emptyp 1270 (list (list 1) 1271 (circular-list 1) 1272 nil 1273 (vector) 1274 (vector 1))) 1275 (nil nil t t nil)) 1276 1277 (deftest sequence-of-length-p.1 1278 (mapcar #'sequence-of-length-p 1279 (list nil 1280 #() 1281 (list 1) 1282 (vector 1) 1283 (list 1 2) 1284 (vector 1 2) 1285 (list 1 2) 1286 (vector 1 2) 1287 (list 1 2) 1288 (vector 1 2)) 1289 (list 0 1290 0 1291 1 1292 1 1293 2 1294 2 1295 1 1296 1 1297 4 1298 4)) 1299 (t t t t t t nil nil nil nil)) 1300 1301 (deftest length=.1 1302 (mapcar #'length= 1303 (list nil 1304 #() 1305 (list 1) 1306 (vector 1) 1307 (list 1 2) 1308 (vector 1 2) 1309 (list 1 2) 1310 (vector 1 2) 1311 (list 1 2) 1312 (vector 1 2)) 1313 (list 0 1314 0 1315 1 1316 1 1317 2 1318 2 1319 1 1320 1 1321 4 1322 4)) 1323 (t t t t t t nil nil nil nil)) 1324 1325 (deftest length=.2 1326 ;; test the compiler macro 1327 (macrolet ((x (&rest args) 1328 (funcall 1329 (compile nil 1330 `(lambda () 1331 (length= ,@args)))))) 1332 (list (x 2 '(1 2)) 1333 (x '(1 2) '(3 4)) 1334 (x '(1 2) 2) 1335 (x '(1 2) 2 '(3 4)) 1336 (x 1 2 3))) 1337 (t t t t nil)) 1338 1339 (deftest copy-sequence.1 1340 (let ((l (list 1 2 3)) 1341 (v (vector #\a #\b #\c))) 1342 (declare (notinline copy-sequence)) 1343 (let ((l.list (copy-sequence 'list l)) 1344 (l.vector (copy-sequence 'vector l)) 1345 (l.spec-v (copy-sequence '(vector fixnum) l)) 1346 (v.vector (copy-sequence 'vector v)) 1347 (v.list (copy-sequence 'list v)) 1348 (v.string (copy-sequence 'string v))) 1349 (list (member l (list l.list l.vector l.spec-v)) 1350 (member v (list v.vector v.list v.string)) 1351 (equal l.list l) 1352 (equalp l.vector #(1 2 3)) 1353 (type= (upgraded-array-element-type 'fixnum) 1354 (array-element-type l.spec-v)) 1355 (equalp v.vector v) 1356 (equal v.list '(#\a #\b #\c)) 1357 (equal "abc" v.string)))) 1358 (nil nil t t t t t t)) 1359 1360 (deftest first-elt.1 1361 (mapcar #'first-elt 1362 (list (list 1 2 3) 1363 "abc" 1364 (vector :a :b :c))) 1365 (1 #\a :a)) 1366 1367 (deftest first-elt.error.1 1368 (mapcar (lambda (x) 1369 (handler-case 1370 (first-elt x) 1371 (type-error () 1372 :type-error))) 1373 (list nil 1374 #() 1375 12 1376 :zot)) 1377 (:type-error 1378 :type-error 1379 :type-error 1380 :type-error)) 1381 1382 (deftest setf-first-elt.1 1383 (let ((l (list 1 2 3)) 1384 (s (copy-seq "foobar")) 1385 (v (vector :a :b :c))) 1386 (setf (first-elt l) -1 1387 (first-elt s) #\x 1388 (first-elt v) 'zot) 1389 (values l s v)) 1390 (-1 2 3) 1391 "xoobar" 1392 #(zot :b :c)) 1393 1394 (deftest setf-first-elt.error.1 1395 (let ((l 'foo)) 1396 (multiple-value-bind (res err) 1397 (ignore-errors (setf (first-elt l) 4)) 1398 (typep err 'type-error))) 1399 t) 1400 1401 (deftest last-elt.1 1402 (mapcar #'last-elt 1403 (list (list 1 2 3) 1404 (vector :a :b :c) 1405 "FOOBAR" 1406 #*001 1407 #*010)) 1408 (3 :c #\R 1 0)) 1409 1410 (deftest last-elt.error.1 1411 (mapcar (lambda (x) 1412 (handler-case 1413 (last-elt x) 1414 (type-error () 1415 :type-error))) 1416 (list nil 1417 #() 1418 12 1419 :zot 1420 (circular-list 1 2 3) 1421 (list* 1 2 3 (circular-list 4 5)))) 1422 (:type-error 1423 :type-error 1424 :type-error 1425 :type-error 1426 :type-error 1427 :type-error)) 1428 1429 (deftest setf-last-elt.1 1430 (let ((l (list 1 2 3)) 1431 (s (copy-seq "foobar")) 1432 (b (copy-seq #*010101001))) 1433 (setf (last-elt l) '??? 1434 (last-elt s) #\? 1435 (last-elt b) 0) 1436 (values l s b)) 1437 (1 2 ???) 1438 "fooba?" 1439 #*010101000) 1440 1441 (deftest setf-last-elt.error.1 1442 (handler-case 1443 (setf (last-elt 'foo) 13) 1444 (type-error () 1445 :type-error)) 1446 :type-error) 1447 1448 (deftest starts-with.1 1449 (list (starts-with 1 '(1 2 3)) 1450 (starts-with 1 #(1 2 3)) 1451 (starts-with #\x "xyz") 1452 (starts-with 2 '(1 2 3)) 1453 (starts-with 3 #(1 2 3)) 1454 (starts-with 1 1) 1455 (starts-with nil nil)) 1456 (t t t nil nil nil nil)) 1457 1458 (deftest starts-with.2 1459 (values (starts-with 1 '(-1 2 3) :key '-) 1460 (starts-with "foo" '("foo" "bar") :test 'equal) 1461 (starts-with "f" '(#\f) :key 'string :test 'equal) 1462 (starts-with -1 '(0 1 2) :key #'1+) 1463 (starts-with "zot" '("ZOT") :test 'equal)) 1464 t 1465 t 1466 t 1467 nil 1468 nil) 1469 1470 (deftest ends-with.1 1471 (list (ends-with 3 '(1 2 3)) 1472 (ends-with 3 #(1 2 3)) 1473 (ends-with #\z "xyz") 1474 (ends-with 2 '(1 2 3)) 1475 (ends-with 1 #(1 2 3)) 1476 (ends-with 1 1) 1477 (ends-with nil nil)) 1478 (t t t nil nil nil nil)) 1479 1480 (deftest ends-with.2 1481 (values (ends-with 2 '(0 13 1) :key '1+) 1482 (ends-with "foo" (vector "bar" "foo") :test 'equal) 1483 (ends-with "X" (vector 1 2 #\X) :key 'string :test 'equal) 1484 (ends-with "foo" "foo" :test 'equal)) 1485 t 1486 t 1487 t 1488 nil) 1489 1490 (deftest ends-with.error.1 1491 (handler-case 1492 (ends-with 3 (circular-list 3 3 3 1 3 3)) 1493 (type-error () 1494 :type-error)) 1495 :type-error) 1496 1497 (deftest sequences.passing-improper-lists 1498 (macrolet ((signals-error-p (form) 1499 `(handler-case 1500 (progn ,form nil) 1501 (type-error (e) 1502 t))) 1503 (cut (fn &rest args) 1504 (with-gensyms (arg) 1505 (print`(lambda (,arg) 1506 (apply ,fn (list ,@(substitute arg '_ args)))))))) 1507 (let ((circular-list (make-circular-list 5 :initial-element :foo)) 1508 (dotted-list (list* 'a 'b 'c 'd))) 1509 (loop for nth from 0 1510 for fn in (list 1511 (cut #'lastcar _) 1512 (cut #'rotate _ 3) 1513 (cut #'rotate _ -3) 1514 (cut #'shuffle _) 1515 (cut #'random-elt _) 1516 (cut #'last-elt _) 1517 (cut #'ends-with :foo _)) 1518 nconcing 1519 (let ((on-circular-p (signals-error-p (funcall fn circular-list))) 1520 (on-dotted-p (signals-error-p (funcall fn dotted-list)))) 1521 (when (or (not on-circular-p) (not on-dotted-p)) 1522 (append 1523 (unless on-circular-p 1524 (let ((*print-circle* t)) 1525 (list 1526 (format nil 1527 "No appropriate error signalled when passing ~S to ~Ath entry." 1528 circular-list nth)))) 1529 (unless on-dotted-p 1530 (list 1531 (format nil 1532 "No appropriate error signalled when passing ~S to ~Ath entry." 1533 dotted-list nth))))))))) 1534 nil) 1535 1536 ;;;; IO 1537 1538 (deftest read-stream-content-into-string.1 1539 (values (with-input-from-string (stream "foo bar") 1540 (read-stream-content-into-string stream)) 1541 (with-input-from-string (stream "foo bar") 1542 (read-stream-content-into-string stream :buffer-size 1)) 1543 (with-input-from-string (stream "foo bar") 1544 (read-stream-content-into-string stream :buffer-size 6)) 1545 (with-input-from-string (stream "foo bar") 1546 (read-stream-content-into-string stream :buffer-size 7))) 1547 "foo bar" 1548 "foo bar" 1549 "foo bar" 1550 "foo bar") 1551 1552 (deftest read-stream-content-into-string.2 1553 (handler-case 1554 (let ((stream (make-broadcast-stream))) 1555 (read-stream-content-into-string stream :buffer-size 0)) 1556 (type-error () 1557 :type-error)) 1558 :type-error) 1559 1560 #+(or) 1561 (defvar *octets* 1562 (map '(simple-array (unsigned-byte 8) (7)) #'char-code "foo bar")) 1563 1564 #+(or) 1565 (deftest read-stream-content-into-byte-vector.1 1566 (values (with-input-from-byte-vector (stream *octets*) 1567 (read-stream-content-into-byte-vector stream)) 1568 (with-input-from-byte-vector (stream *octets*) 1569 (read-stream-content-into-byte-vector stream :initial-size 1)) 1570 (with-input-from-byte-vector (stream *octets*) 1571 (read-stream-content-into-byte-vector stream 'alexandria::%length 6)) 1572 (with-input-from-byte-vector (stream *octets*) 1573 (read-stream-content-into-byte-vector stream 'alexandria::%length 3))) 1574 *octets* 1575 *octets* 1576 *octets* 1577 (subseq *octets* 0 3)) 1578 1579 (deftest read-stream-content-into-byte-vector.2 1580 (handler-case 1581 (let ((stream (make-broadcast-stream))) 1582 (read-stream-content-into-byte-vector stream :initial-size 0)) 1583 (type-error () 1584 :type-error)) 1585 :type-error) 1586 1587 ;;;; Macros 1588 1589 (deftest with-unique-names.1 1590 (let ((*gensym-counter* 0)) 1591 (let ((syms (with-unique-names (foo bar quux) 1592 (list foo bar quux)))) 1593 (list (find-if #'symbol-package syms) 1594 (equal '("FOO0" "BAR1" "QUUX2") 1595 (mapcar #'symbol-name syms))))) 1596 (nil t)) 1597 1598 (deftest with-unique-names.2 1599 (let ((*gensym-counter* 0)) 1600 (let ((syms (with-unique-names ((foo "_foo_") (bar -bar-) (quux #\q)) 1601 (list foo bar quux)))) 1602 (list (find-if #'symbol-package syms) 1603 (equal '("_foo_0" "-BAR-1" "q2") 1604 (mapcar #'symbol-name syms))))) 1605 (nil t)) 1606 1607 (deftest with-unique-names.3 1608 (let ((*gensym-counter* 0)) 1609 (multiple-value-bind (res err) 1610 (ignore-errors 1611 (eval 1612 '(let ((syms 1613 (with-unique-names ((foo "_foo_") (bar -bar-) (quux 42)) 1614 (list foo bar quux)))) 1615 (list (find-if #'symbol-package syms) 1616 (equal '("_foo_0" "-BAR-1" "q2") 1617 (mapcar #'symbol-name syms)))))) 1618 (errorp err))) 1619 t) 1620 1621 (deftest once-only.1 1622 (macrolet ((cons1.good (x) 1623 (once-only (x) 1624 `(cons ,x ,x))) 1625 (cons1.bad (x) 1626 `(cons ,x ,x))) 1627 (let ((y 0)) 1628 (list (cons1.good (incf y)) 1629 y 1630 (cons1.bad (incf y)) 1631 y))) 1632 ((1 . 1) 1 (2 . 3) 3)) 1633 1634 (deftest once-only.2 1635 (macrolet ((cons1 (x) 1636 (once-only ((y x)) 1637 `(cons ,y ,y)))) 1638 (let ((z 0)) 1639 (list (cons1 (incf z)) 1640 z 1641 (cons1 (incf z))))) 1642 ((1 . 1) 1 (2 . 2))) 1643 1644 (deftest parse-body.1 1645 (parse-body '("doc" "body") :documentation t) 1646 ("body") 1647 nil 1648 "doc") 1649 1650 (deftest parse-body.2 1651 (parse-body '("body") :documentation t) 1652 ("body") 1653 nil 1654 nil) 1655 1656 (deftest parse-body.3 1657 (parse-body '("doc" "body")) 1658 ("doc" "body") 1659 nil 1660 nil) 1661 1662 (deftest parse-body.4 1663 (parse-body '((declare (foo)) "doc" (declare (bar)) body) :documentation t) 1664 (body) 1665 ((declare (foo)) (declare (bar))) 1666 "doc") 1667 1668 (deftest parse-body.5 1669 (parse-body '((declare (foo)) "doc" (declare (bar)) body)) 1670 ("doc" (declare (bar)) body) 1671 ((declare (foo))) 1672 nil) 1673 1674 (deftest parse-body.6 1675 (multiple-value-bind (res err) 1676 (ignore-errors 1677 (parse-body '("foo" "bar" "quux") 1678 :documentation t)) 1679 (errorp err)) 1680 t) 1681 1682 ;;;; Symbols 1683 1684 (deftest ensure-symbol.1 1685 (ensure-symbol :cons :cl) 1686 cons 1687 :external) 1688 1689 (deftest ensure-symbol.2 1690 (ensure-symbol "CONS" :alexandria) 1691 cons 1692 :inherited) 1693 1694 (deftest ensure-symbol.3 1695 (ensure-symbol 'foo :keyword) 1696 :foo 1697 :external) 1698 1699 (deftest ensure-symbol.4 1700 (ensure-symbol #\* :alexandria) 1701 * 1702 :inherited) 1703 1704 (deftest format-symbol.1 1705 (let ((s (format-symbol nil '#:x-~d 13))) 1706 (list (symbol-package s) 1707 (string= (string '#:x-13) (symbol-name s)))) 1708 (nil t)) 1709 1710 (deftest format-symbol.2 1711 (format-symbol :keyword '#:sym-~a (string :bolic)) 1712 :sym-bolic) 1713 1714 (deftest format-symbol.3 1715 (let ((*package* (find-package :cl))) 1716 (format-symbol t '#:find-~a (string 'package))) 1717 find-package) 1718 1719 (deftest make-keyword.1 1720 (list (make-keyword 'zot) 1721 (make-keyword "FOO") 1722 (make-keyword #\Q)) 1723 (:zot :foo :q)) 1724 1725 (deftest make-gensym-list.1 1726 (let ((*gensym-counter* 0)) 1727 (let ((syms (make-gensym-list 3 "FOO"))) 1728 (list (find-if 'symbol-package syms) 1729 (equal '("FOO0" "FOO1" "FOO2") 1730 (mapcar 'symbol-name syms))))) 1731 (nil t)) 1732 1733 (deftest make-gensym-list.2 1734 (let ((*gensym-counter* 0)) 1735 (let ((syms (make-gensym-list 3))) 1736 (list (find-if 'symbol-package syms) 1737 (equal '("G0" "G1" "G2") 1738 (mapcar 'symbol-name syms))))) 1739 (nil t)) 1740 1741 ;;;; Type-system 1742 1743 (deftest of-type.1 1744 (locally 1745 (declare (notinline of-type)) 1746 (let ((f (of-type 'string))) 1747 (list (funcall f "foo") 1748 (funcall f 'bar)))) 1749 (t nil)) 1750 1751 (deftest type=.1 1752 (type= 'string 'string) 1753 t 1754 t) 1755 1756 (deftest type=.2 1757 (type= 'list '(or null cons)) 1758 t 1759 t) 1760 1761 (deftest type=.3 1762 (type= 'null '(and symbol list)) 1763 t 1764 t) 1765 1766 (deftest type=.4 1767 (type= 'string '(satisfies emptyp)) 1768 nil 1769 nil) 1770 1771 (deftest type=.5 1772 (type= 'string 'list) 1773 nil 1774 t) 1775 1776 (macrolet 1777 ((test (type numbers) 1778 `(deftest ,(format-symbol t '#:cdr5.~a (string type)) 1779 (let ((numbers ,numbers)) 1780 (values (mapcar (of-type ',(format-symbol t '#:negative-~a (string type))) numbers) 1781 (mapcar (of-type ',(format-symbol t '#:non-positive-~a (string type))) numbers) 1782 (mapcar (of-type ',(format-symbol t '#:non-negative-~a (string type))) numbers) 1783 (mapcar (of-type ',(format-symbol t '#:positive-~a (string type))) numbers))) 1784 (t t t nil nil nil nil) 1785 (t t t t nil nil nil) 1786 (nil nil nil t t t t) 1787 (nil nil nil nil t t t)))) 1788 (test fixnum (list most-negative-fixnum -42 -1 0 1 42 most-positive-fixnum)) 1789 (test integer (list (1- most-negative-fixnum) -42 -1 0 1 42 (1+ most-positive-fixnum))) 1790 (test rational (list (1- most-negative-fixnum) -42/13 -1 0 1 42/13 (1+ most-positive-fixnum))) 1791 (test real (list most-negative-long-float -42/13 -1 0 1 42/13 most-positive-long-float)) 1792 (test float (list most-negative-short-float -42.02 -1.0 0.0 1.0 42.02 most-positive-short-float)) 1793 (test short-float (list most-negative-short-float -42.02s0 -1.0s0 0.0s0 1.0s0 42.02s0 most-positive-short-float)) 1794 (test single-float (list most-negative-single-float -42.02f0 -1.0f0 0.0f0 1.0f0 42.02f0 most-positive-single-float)) 1795 (test double-float (list most-negative-double-float -42.02d0 -1.0d0 0.0d0 1.0d0 42.02d0 most-positive-double-float)) 1796 (test long-float (list most-negative-long-float -42.02l0 -1.0l0 0.0l0 1.0l0 42.02l0 most-positive-long-float))) 1797 1798 ;;;; Bindings 1799 1800 (declaim (notinline opaque)) 1801 (defun opaque (x) 1802 x) 1803 1804 (deftest if-let.1 1805 (if-let (x (opaque :ok)) 1806 x 1807 :bad) 1808 :ok) 1809 1810 (deftest if-let.2 1811 (if-let (x (opaque nil)) 1812 :bad 1813 (and (not x) :ok)) 1814 :ok) 1815 1816 (deftest if-let.3 1817 (let ((x 1)) 1818 (if-let ((x 2) 1819 (y x)) 1820 (+ x y) 1821 :oops)) 1822 3) 1823 1824 (deftest if-let.4 1825 (if-let ((x 1) 1826 (y nil)) 1827 :oops 1828 (and (not y) x)) 1829 1) 1830 1831 (deftest if-let.5 1832 (if-let (x) 1833 :oops 1834 (not x)) 1835 t) 1836 1837 (deftest if-let.error.1 1838 (handler-case 1839 (eval '(if-let x 1840 :oops 1841 :oops)) 1842 (type-error () 1843 :type-error)) 1844 :type-error) 1845 1846 (deftest when-let.1 1847 (when-let (x (opaque :ok)) 1848 (setf x (cons x x)) 1849 x) 1850 (:ok . :ok)) 1851 1852 (deftest when-let.2 1853 (when-let ((x 1) 1854 (y nil) 1855 (z 3)) 1856 :oops) 1857 nil) 1858 1859 (deftest when-let.3 1860 (let ((x 1)) 1861 (when-let ((x 2) 1862 (y x)) 1863 (+ x y))) 1864 3) 1865 1866 (deftest when-let.error.1 1867 (handler-case 1868 (eval '(when-let x :oops)) 1869 (type-error () 1870 :type-error)) 1871 :type-error) 1872 1873 (deftest when-let*.1 1874 (let ((x 1)) 1875 (when-let* ((x 2) 1876 (y x)) 1877 (+ x y))) 1878 4) 1879 1880 (deftest when-let*.2 1881 (let ((y 1)) 1882 (when-let* (x y) 1883 (1+ x))) 1884 2) 1885 1886 (deftest when-let*.3 1887 (when-let* ((x t) 1888 (y (consp x)) 1889 (z (error "OOPS"))) 1890 t) 1891 nil) 1892 1893 (deftest when-let*.error.1 1894 (handler-case 1895 (eval '(when-let* x :oops)) 1896 (type-error () 1897 :type-error)) 1898 :type-error) 1899 1900 (deftest doplist.1 1901 (let (keys values) 1902 (doplist (k v '(a 1 b 2 c 3) (values t (reverse keys) (reverse values) k v)) 1903 (push k keys) 1904 (push v values))) 1905 t 1906 (a b c) 1907 (1 2 3) 1908 nil 1909 nil) 1910 1911 (deftest count-permutations.1 1912 (values (count-permutations 31 7) 1913 (count-permutations 1 1) 1914 (count-permutations 2 1) 1915 (count-permutations 2 2) 1916 (count-permutations 3 2) 1917 (count-permutations 3 1)) 1918 13253058000 1919 1 1920 2 1921 2 1922 6 1923 3) 1924 1925 (deftest binomial-coefficient.1 1926 (alexandria:binomial-coefficient 1239 139) 1927 28794902202288970200771694600561826718847179309929858835480006683522184441358211423695124921058123706380656375919763349913245306834194782172712255592710204598527867804110129489943080460154) 1928 1929 ;; Exercise bignum case (at least on x86). 1930 (deftest binomial-coefficient.2 1931 (alexandria:binomial-coefficient 2000000000000 20) 1932 430998041177272843950422879590338454856322722740402365741730748431530623813012487773080486408378680853987520854296499536311275320016878730999689934464711239072435565454954447356845336730100919970769793030177499999999900000000000) 1933 1934 (deftest copy-stream.1 1935 (let ((data "sdkfjhsakfh weior763495ewofhsdfk sdfadlkfjhsadf woif sdlkjfhslkdfh sdklfjh")) 1936 (values (equal data 1937 (with-input-from-string (in data) 1938 (with-output-to-string (out) 1939 (alexandria:copy-stream in out)))) 1940 (equal (subseq data 10 20) 1941 (with-input-from-string (in data) 1942 (with-output-to-string (out) 1943 (alexandria:copy-stream in out :start 10 :end 20)))) 1944 (equal (subseq data 10) 1945 (with-input-from-string (in data) 1946 (with-output-to-string (out) 1947 (alexandria:copy-stream in out :start 10)))) 1948 (equal (subseq data 0 20) 1949 (with-input-from-string (in data) 1950 (with-output-to-string (out) 1951 (alexandria:copy-stream in out :end 20)))))) 1952 t 1953 t 1954 t 1955 t) 1956 1957 (deftest extremum.1 1958 (let ((n 0)) 1959 (dotimes (i 10) 1960 (let ((data (shuffle (coerce (iota 10000 :start i) 'vector))) 1961 (ok t)) 1962 (unless (eql i (extremum data #'<)) 1963 (setf ok nil)) 1964 (unless (eql i (extremum (coerce data 'list) #'<)) 1965 (setf ok nil)) 1966 (unless (eql (+ 9999 i) (extremum data #'>)) 1967 (setf ok nil)) 1968 (unless (eql (+ 9999 i) (extremum (coerce data 'list) #'>)) 1969 (setf ok nil)) 1970 (when ok 1971 (incf n)))) 1972 (when (eql 10 (extremum #(100 1 10 1000) #'> :start 1 :end 3)) 1973 (incf n)) 1974 (when (eql -1000 (extremum #(100 1 10 -1000) #'> :key 'abs)) 1975 (incf n)) 1976 (when (eq nil (extremum "" (lambda (a b) (error "wtf? ~S, ~S" a b)))) 1977 (incf n)) 1978 n) 1979 13) 1980 1981 (deftest starts-with-subseq.string 1982 (starts-with-subseq "f" "foo" :return-suffix t) 1983 t 1984 "oo") 1985 1986 (deftest starts-with-subseq.vector 1987 (starts-with-subseq #(1) #(1 2 3) :return-suffix t) 1988 t 1989 #(2 3)) 1990 1991 (deftest starts-with-subseq.list 1992 (starts-with-subseq '(1) '(1 2 3) :return-suffix t) 1993 t 1994 (2 3)) 1995 1996 (deftest starts-with-subseq.start1 1997 (starts-with-subseq "foo" "oop" :start1 1) 1998 t 1999 nil) 2000 2001 (deftest starts-with-subseq.start2 2002 (starts-with-subseq "foo" "xfoop" :start2 1) 2003 t 2004 nil) 2005 2006 (deftest format-symbol.print-case-bound 2007 (let ((upper (intern "FOO-BAR")) 2008 (lower (intern "foo-bar")) 2009 (*print-escape* nil)) 2010 (values 2011 (let ((*print-case* :downcase)) 2012 (and (eq upper (format-symbol t "~A" upper)) 2013 (eq lower (format-symbol t "~A" lower)))) 2014 (let ((*print-case* :upcase)) 2015 (and (eq upper (format-symbol t "~A" upper)) 2016 (eq lower (format-symbol t "~A" lower)))) 2017 (let ((*print-case* :capitalize)) 2018 (and (eq upper (format-symbol t "~A" upper)) 2019 (eq lower (format-symbol t "~A" lower)))))) 2020 t 2021 t 2022 t) 2023 2024 (deftest iota.fp-start-and-complex-integer-step 2025 (equal '(#C(0.0 0.0) #C(0.0 2.0) #C(0.0 4.0)) 2026 (iota 3 :start 0.0 :step #C(0 2))) 2027 t) 2028 2029 (deftest parse-ordinary-lambda-list.1 2030 (multiple-value-bind (req opt rest keys allowp aux keyp) 2031 (parse-ordinary-lambda-list '(a b c 2032 &optional o1 (o2 42) (o3 42 o3-supplied?) 2033 &key (k1) ((:key k2)) (k3 42 k3-supplied?)) 2034 :normalize t) 2035 (and (equal '(a b c) req) 2036 (equal '((o1 nil nil) 2037 (o2 42 nil) 2038 (o3 42 o3-supplied?)) 2039 opt) 2040 (equal '(((:k1 k1) nil nil) 2041 ((:key k2) nil nil) 2042 ((:k3 k3) 42 k3-supplied?)) 2043 keys) 2044 (not allowp) 2045 (not aux) 2046 (eq t keyp))) 2047 t)