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