tests.lisp

   1 (in-package :cl-user)
   2
   3 (require :sb-rt)
   4
   5 (require :alexandria)
   6
   7 (defpackage :alexandria-test
   8   (:use :cl :alexandria :sb-rt))
   9
  10 (in-package :alexandria-test)
  11
  12 ;;;; Arrays
  13
  14 (deftest copy-array.1
  15     (let* ((orig (vector 1 2 3))
  16            (copy (copy-array orig)))
  17       (values (eq orig copy) (equalp orig copy)))
  18   nil t)
  19
  20 (deftest copy-array.2
  21     (let ((orig (make-array 1024 :fill-pointer 0)))
  22       (vector-push-extend 1 orig)
  23       (vector-push-extend 2 orig)
  24       (vector-push-extend 3 orig)
  25       (let ((copy (copy-array orig)))
  26         (values (eq orig copy) (equalp orig copy)
  27                 (array-has-fill-pointer-p copy)
  28                 (eql (fill-pointer orig) (fill-pointer copy)))))
  29   nil t t t)
  30
  31 (deftest array-index.1
  32     (typep 0 'array-index)
  33   t)
  34
  35 ;;;; Control flow
  36
  37 (deftest switch.1
  38     (switch (13 :test =)
  39       (12 :oops)
  40       (13.0 :yay))
  41   :yay)
  42
  43 (deftest switch.2
  44     (switch (13 :default :yay)
  45       ((+ 12 2) :oops)
  46       ((- 13 1) :oops2))
  47   :yay)
  48
  49 (deftest eswitch.1
  50     (let ((x 13))
  51       (eswitch (x :test =)
  52         (12 :oops)
  53         (13.0 :yay)))
  54   :yay)
  55
  56 (deftest eswitch.2
  57     (let ((x 13))
  58       (eswitch (x :key 1+)
  59         (11 :oops)
  60         (14 :yay)))
  61   :yay)
  62
  63 (deftest cswitch.1
  64     (cswitch (13 :test =)
  65       (12 :oops)
  66       (13.0 :yay))
  67   :yay)
  68
  69 (deftest cswitch.2
  70     (cswitch (13 :key 1-)
  71       (12 :yay)
  72       (13.0 :oops))
  73   :yay)
  74
  75 (deftest whichever.1
  76     (let ((x (whichever 1 2 3)))
  77       (and (member x '(1 2 3)) t))
  78   t)
  79
  80 (deftest xor.1
  81     (xor nil nil 1 nil)
  82   1
  83   t)
  84
  85 ;;;; Definitions
  86
  87 (deftest define-constant.1
  88     (let ((name (gensym)))
  89       (eval `(define-constant ,name "FOO" :test equal))
  90       (eval `(define-constant ,name "FOO" :test equal))
  91       (values (equal "FOO" (symbol-value name))
  92               (constantp name)))
  93   t
  94   t)
  95
  96 (deftest define-constant.2
  97     (let ((name (gensym)))
  98       (eval `(define-constant ,name 13))
  99       (eval `(define-constant ,name 13))
 100       (values (eql 13 (symbol-value name))
 101               (constantp name)))
 102   t
 103   t)
 104
 105 ;;;; Errors
 106
 107 (deftest required-argument.1
 108     (multiple-value-bind (res err)
 109         (ignore-errors (required-argument))
 110       (typep err 'error))
 111   t)
 112
 113 ;;;; Hash tables
 114
 115 (deftest copy-hash-table.1
 116     (let ((orig (make-hash-table :test 'eq :size 123))
 117           (foo "foo"))
 118       (setf (gethash orig orig) t
 119             (gethash foo orig) t)
 120       (let ((eq-copy (copy-hash-table orig))
 121             (eql-copy (copy-hash-table orig :test 'eql))
 122             (equal-copy (copy-hash-table orig :test 'equal))
 123             (equalp-copy (copy-hash-table orig :test 'equalp)))
 124         (list (hash-table-size eq-copy)
 125               (hash-table-count eql-copy)
 126               (gethash orig eq-copy)
 127               (gethash (copy-seq foo) eql-copy)
 128               (gethash foo eql-copy)
 129               (gethash (copy-seq foo) equal-copy)
 130               (gethash "FOO" equal-copy)
 131               (gethash "FOO" equalp-copy))))
 132   (123 2 t nil t t nil t))
 133
 134 (deftest maphash-keys.1
 135     (let ((keys nil)
 136           (table (make-hash-table)))
 137       (declare (notinline maphash-keys))
 138       (dotimes (i 10)
 139         (setf (gethash i table) t))
 140       (maphash-keys (lambda (k) (push k keys)) table)
 141       (set-equal keys '(0 1 2 3 4 5 6 7 8 9)))
 142   t)
 143
 144 (deftest maphash-values.1
 145     (let ((vals nil)
 146           (table (make-hash-table)))
 147       (declare (notinline maphash-values))
 148       (dotimes (i 10)
 149         (setf (gethash i table) (- i)))
 150       (maphash-values (lambda (v) (push v vals)) table)
 151       (set-equal vals '(0 -1 -2 -3 -4 -5 -6 -7 -8 -9)))
 152   t)
 153
 154 (deftest hash-table-keys.1
 155     (let ((table (make-hash-table)))
 156       (dotimes (i 10)
 157         (setf (gethash i table) t))
 158       (set-equal (hash-table-keys table) '(0 1 2 3 4 5 6 7 8 9)))
 159   t)
 160
 161 (deftest hash-table-values.1
 162     (let ((table (make-hash-table)))
 163       (dotimes (i 10)
 164         (setf (gethash (gensym) table) i))
 165       (set-equal (hash-table-values table) '(0 1 2 3 4 5 6 7 8 9)))
 166   t)
 167
 168 (deftest hash-table-alist.1
 169     (let ((table (make-hash-table)))
 170       (dotimes (i 10)
 171         (setf (gethash i table) (- i)))
 172       (let ((alist (hash-table-alist table)))
 173         (list (length alist)
 174               (assoc 0 alist)
 175               (assoc 3 alist)
 176               (assoc 9 alist)
 177               (assoc nil alist))))
 178   (10 (0 . 0) (3 . -3) (9 . -9) nil))
 179
 180 (deftest hash-table-plist.1
 181     (let ((table (make-hash-table)))
 182       (dotimes (i 10)
 183         (setf (gethash i table) (- i)))
 184       (let ((plist (hash-table-plist table)))
 185         (list (length plist)
 186               (getf plist 0)
 187               (getf plist 2)
 188               (getf plist 7)
 189               (getf plist nil))))
 190   (20 0 -2 -7 nil))
 191
 192 (deftest alist-hash-table.1
 193     (let* ((alist '((0 a) (1 b) (2 c)))
 194            (table (alist-hash-table alist)))
 195       (list (hash-table-count table)
 196             (gethash 0 table)
 197             (gethash 1 table)
 198             (gethash 2 table)
 199             (hash-table-test table)))
 200   (3 (a) (b) (c) eql))
 201
 202 (deftest plist-hash-table.1
 203     (let* ((plist '(:a 1 :b 2 :c 3))
 204            (table (plist-hash-table plist :test 'eq)))
 205       (list (hash-table-count table)
 206             (gethash :a table)
 207             (gethash :b table)
 208             (gethash :c table)
 209             (gethash 2 table)
 210             (gethash nil table)
 211             (hash-table-test table)))
 212   (3 1 2 3 nil nil eq))
 213
 214 ;;;; Functions
 215
 216 (deftest disjoin.1
 217     (let ((disjunction (disjoin (lambda (x)
 218                                   (and (consp x) :cons))
 219                                 (lambda (x)
 220                                   (and (stringp x) :string)))))
 221       (list (funcall disjunction 'zot)
 222             (funcall disjunction '(foo bar))
 223             (funcall disjunction "test")))
 224   (nil :cons :string))
 225
 226 (deftest conjoin.1
 227     (let ((conjunction (conjoin #'consp
 228                                 (lambda (x)
 229                                   (stringp (car x)))
 230                                 (lambda (x)
 231                                   (char (car x) 0)))))
 232       (list (funcall conjunction 'zot)
 233             (funcall conjunction '(foo))
 234             (funcall conjunction '("foo"))))
 235   (nil nil #\f))
 236
 237 (deftest compose.1
 238     (let ((composite (compose '1+
 239                               (lambda (x)
 240                                 (* x 2))
 241                               #'read-from-string)))
 242       (funcall composite "1"))
 243   3)
 244
 245 (deftest compose.2
 246     (let ((composite
 247            (locally (declare (notinline compose))
 248              (compose '1+
 249                       (lambda (x)
 250                         (* x 2))
 251                       #'read-from-string))))
 252       (funcall composite "2"))
 253   5)
 254
 255 (deftest compose.3
 256     (let ((compose-form (funcall (compiler-macro-function 'compose)
 257                                  '(compose '1+
 258                                    (lambda (x)
 259                                      (* x 2))
 260                                    #'read-from-string)
 261                                  nil)))
 262       (let ((fun (funcall (compile nil `(lambda () ,compose-form)))))
 263         (funcall fun "3")))
 264   7)
 265
 266 (deftest multiple-value-compose.1
 267     (let ((composite (multiple-value-compose
 268                       #'truncate
 269                       (lambda (x y)
 270                         (values y x))
 271                       (lambda (x)
 272                         (with-input-from-string (s x)
 273                           (values (read s) (read s)))))))
 274       (multiple-value-list (funcall composite "2 7")))
 275   (3 1))
 276
 277 (deftest multiple-value-compose.2
 278     (let ((composite (locally (declare (notinline multiple-value-compose))
 279                        (multiple-value-compose
 280                         #'truncate
 281                         (lambda (x y)
 282                           (values y x))
 283                        (lambda (x)
 284                          (with-input-from-string (s x)
 285                            (values (read s) (read s))))))))
 286       (multiple-value-list (funcall composite "2 11")))
 287   (5 1))
 288
 289 (deftest multiple-value-compose.3
 290     (let ((compose-form (funcall (compiler-macro-function 'multiple-value-compose)
 291                                  '(multiple-value-compose
 292                                    #'truncate
 293                                    (lambda (x y)
 294                                      (values y x))
 295                                    (lambda (x)
 296                                      (with-input-from-string (s x)
 297                                        (values (read s) (read s)))))
 298                                  nil)))
 299       (let ((fun (funcall (compile nil `(lambda () ,compose-form)))))
 300         (multiple-value-list (funcall fun "2 9"))))
 301   (4 1))
 302
 303 (deftest curry.1
 304     (let ((curried (curry '+ 3)))
 305       (funcall curried 1 5))
 306   9)
 307
 308 (deftest curry.2
 309     (let ((curried (locally (declare (notinline curry))
 310                      (curry '* 2 3))))
 311       (funcall curried 7))
 312   42)
 313
 314 (deftest curry.3
 315     (let ((curried-form (funcall (compiler-macro-function 'curry)
 316                                  '(curry '/ 8)
 317                                  nil)))
 318       (let ((fun (funcall (compile nil `(lambda () ,curried-form)))))
 319         (funcall fun 2)))
 320   4)
 321
 322 (deftest rcurry.1
 323     (let ((r (rcurry '/ 2)))
 324       (funcall r 8))
 325   4)
 326
 327 (deftest named-lambda.1
 328     (let ((fac (named-lambda fac (x)
 329                  (if (> x 1)
 330                      (* x (fac (- x 1)))
 331                      x))))
 332       (funcall fac 5))
 333   120)
 334
 335 (deftest named-lambda.2
 336     (let ((fac (named-lambda fac (&key x)
 337                  (if (> x 1)
 338                      (* x (fac :x (- x 1)))
 339                      x))))
 340       (funcall fac :x 5))
 341   120)
 342
 343 ;;;; Lists
 344
 345 (deftest alist-plist.1
 346     (alist-plist '((a . 1) (b . 2) (c . 3)))
 347   (a 1 b 2 c 3))
 348
 349 (deftest plist-alist.1
 350     (plist-alist '(a 1 b 2 c 3))
 351   ((a . 1) (b . 2) (c . 3)))
 352
 353 (deftest unionf.1
 354     (let* ((list '(1 2 3))
 355            (orig list))
 356       (unionf list '(1 2 4))
 357       (values (equal orig (list 1 2 3))
 358               (eql (length list) 4)
 359               (set-difference list (list 1 2 3 4))
 360               (set-difference (list 1 2 3 4) list)))
 361   t
 362   t
 363   nil
 364   nil)
 365
 366 (deftest nunionf.1
 367     (let ((list '(1 2 3)))
 368       (nunionf list '(1 2 4))
 369       (values (eql (length list) 4)
 370               (set-difference (list 1 2 3 4) list)
 371               (set-difference list (list 1 2 3 4))))
 372   t
 373   nil
 374   nil)
 375
 376 (deftest appendf.1
 377     (let* ((list '(1 2 3))
 378            (orig list))
 379       (appendf list '(4 5 6) '(7 8))
 380       (list list (eq list orig)))
 381   ((1 2 3 4 5 6 7 8) nil))
 382
 383 (deftest circular-list.1
 384     (let ((circle (circular-list 1 2 3)))
 385       (list (first circle)
 386             (second circle)
 387             (third circle)
 388             (fourth circle)
 389             (eq circle (nthcdr 3 circle))))
 390   (1 2 3 1 t))
 391
 392 (deftest circular-list-p.1
 393     (let* ((circle (circular-list 1 2 3 4))
 394            (tree (list circle circle))
 395            (dotted (cons circle t))
 396            (proper (list 1 2 3 circle))
 397            (tailcirc (list* 1 2 3 circle)))
 398       (list (circular-list-p circle)
 399             (circular-list-p tree)
 400             (circular-list-p dotted)
 401             (circular-list-p proper)
 402             (circular-list-p tailcirc)))
 403   (t nil nil nil t))
 404
 405 (deftest circular-list-p.2
 406     (circular-list-p 'foo)
 407   nil)
 408
 409 (deftest circular-tree-p.1
 410     (let* ((circle (circular-list 1 2 3 4))
 411            (tree1 (list circle circle))
 412            (tree2 (let* ((level2 (list 1 nil 2))
 413                          (level1 (list level2)))
 414                     (setf (second level2) level1)
 415                     level1))
 416            (dotted (cons circle t))
 417            (proper (list 1 2 3 circle))
 418            (tailcirc (list* 1 2 3 circle))
 419            (quite-proper (list 1 2 3))
 420            (quite-dotted (list 1 (cons 2 3))))
 421       (list (circular-tree-p circle)
 422             (circular-tree-p tree1)
 423             (circular-tree-p tree2)
 424             (circular-tree-p dotted)
 425             (circular-tree-p proper)
 426             (circular-tree-p tailcirc)
 427             (circular-tree-p quite-proper)
 428             (circular-tree-p quite-dotted)))
 429   (t t t t t t nil nil))
 430
 431 (deftest proper-list-p.1
 432     (let ((l1 (list 1))
 433           (l2 (list 1 2))
 434           (l3 (cons 1 2))
 435           (l4 (list (cons 1 2) 3))
 436           (l5 (circular-list 1 2)))
 437       (list (proper-list-p l1)
 438             (proper-list-p l2)
 439             (proper-list-p l3)
 440             (proper-list-p l4)
 441             (proper-list-p l5)))
 442   (t t nil t nil))
 443
 444 (deftest proper-list-p.2
 445     (proper-list-p '(1 2 . 3))
 446   nil)
 447
 448 (deftest proper-list.type.1
 449     (let ((l1 (list 1))
 450           (l2 (list 1 2))
 451           (l3 (cons 1 2))
 452           (l4 (list (cons 1 2) 3))
 453           (l5 (circular-list 1 2)))
 454       (list (typep l1 'proper-list)
 455             (typep l2 'proper-list)
 456             (typep l3 'proper-list)
 457             (typep l4 'proper-list)
 458             (typep l5 'proper-list)))
 459   (t t nil t nil))
 460
 461 (deftest lastcar.1
 462     (let ((l1 (list 1))
 463           (l2 (list 1 2)))
 464       (list (lastcar l1)
 465             (lastcar l2)))
 466   (1 2))
 467
 468 (deftest lastcar.error.2
 469     (handler-case
 470         (progn
 471           (lastcar (circular-list 1 2 3))
 472           nil)
 473       (error ()
 474         t))
 475   t)
 476
 477 (deftest setf-lastcar.1
 478     (let ((l (list 1 2 3 4)))
 479       (values (lastcar l)
 480               (progn
 481                 (setf (lastcar l) 42)
 482                 (lastcar l))))
 483   4
 484   42)
 485
 486 (deftest setf-lastcar.2
 487     (let ((l (circular-list 1 2 3)))
 488       (multiple-value-bind (res err)
 489           (ignore-errors (setf (lastcar l) 4))
 490         (typep err 'type-error)))
 491   t)
 492
 493 (deftest make-circular-list.1
 494     (let ((l (make-circular-list 3 :initial-element :x)))
 495       (setf (car l) :y)
 496       (list (eq l (nthcdr 3 l))
 497             (first l)
 498             (second l)
 499             (third l)
 500             (fourth l)))
 501   (t :y :x :x :y))
 502
 503 (deftest circular-list.type.1
 504     (let* ((l1 (list 1 2 3))
 505            (l2 (circular-list 1 2 3))
 506            (l3 (list* 1 2 3 l2)))
 507       (list (typep l1 'circular-list)
 508             (typep l2 'circular-list)
 509             (typep l3 'circular-list)))
 510   (nil t t))
 511
 512 (deftest ensure-list.1
 513     (let ((x (list 1))
 514           (y 2))
 515       (list (ensure-list x)
 516             (ensure-list y)))
 517   ((1) (2)))
 518
 519 (deftest ensure-cons.1
 520     (let ((x (cons 1 2))
 521           (y nil)
 522           (z "foo"))
 523       (values (ensure-cons x)
 524               (ensure-cons y)
 525               (ensure-cons z)))
 526   (1 . 2)
 527   (nil)
 528   ("foo"))
 529
 530 (deftest setp.1
 531     (setp '(1))
 532   t)
 533
 534 (deftest setp.2
 535     (setp nil)
 536   t)
 537
 538 (deftest setp.3
 539     (setp "foo")
 540   nil)
 541
 542 (deftest setp.4
 543     (setp '(1 2 3 1))
 544   nil)
 545
 546 (deftest setp.5
 547     (setp '(1 2 3))
 548   t)
 549
 550 (deftest setp.6
 551     (setp '(a :a))
 552   t)
 553
 554 (deftest setp.7
 555     (setp '(a :a) :key 'character)
 556   nil)
 557
 558 (deftest setp.8
 559     (setp '(a :a) :key 'character :test (constantly nil))
 560   t)
 561
 562 (deftest set-equal.1
 563     (set-equal '(1 2 3) '(3 1 2))
 564   t)
 565
 566 (deftest set-equal.2
 567     (set-equal '("Xa") '("Xb")
 568                :test (lambda (a b) (eql (char a 0) (char b 0))))
 569   t)
 570
 571 (deftest set-equal.3
 572     (set-equal '(1 2) '(4 2))
 573   nil)
 574
 575 (deftest set-equal.4
 576     (set-equal '(a b c) '(:a :b :c) :key 'string :test 'equal)
 577   t)
 578
 579 (deftest set-equal.5
 580     (set-equal '(a d c) '(:a :b :c) :key 'string :test 'equal)
 581   nil)
 582
 583 (deftest set-equal.6
 584     (set-equal '(a b c) '(a b c d))
 585   nil)
 586
 587 (deftest map-product.1
 588     (map-product 'cons '(2 3) '(1 4))
 589   ((2 . 1) (2 . 4) (3 . 1) (3 . 4)))
 590
 591 (deftest map-product.2
 592     (map-product #'cons '(2 3) '(1 4))
 593   ((2 . 1) (2 . 4) (3 . 1) (3 . 4)))
 594
 595 (deftest flatten.1
 596     (flatten '((1) 2 (((3 4))) ((((5)) 6)) 7))
 597   (1 2 3 4 5 6 7))
 598
 599 (deftest sans.1
 600     (let ((orig '(a 1 b 2 c 3 d 4)))
 601       (list (sans orig 'a 'c)
 602             (sans orig 'b 'd)
 603             (sans orig 'b)
 604             (sans orig 'a)
 605             (sans orig 'd 42 "zot")
 606             (sans orig 'a 'b 'c 'd)
 607             (sans orig 'a 'b 'c 'd 'x)
 608             (equal orig '(a 1 b 2 c 3 d 4))))
 609   ((b 2 d 4)
 610    (a 1 c 3)
 611    (a 1 c 3 d 4)
 612    (b 2 c 3 d 4)
 613    (a 1 b 2 c 3)
 614    nil
 615    nil
 616    t))
 617
 618 (deftest mappend.1
 619     (mappend (compose 'list '*) '(1 2 3) '(1 2 3))
 620   (1 4 9))
 621
 622 ;;;; Numbers
 623
 624 (deftest clamp.1
 625     (list (clamp 1.5 1 2)
 626           (clamp 2.0 1 2)
 627           (clamp 1.0 1 2)
 628           (clamp 3 1 2)
 629           (clamp 0 1 2))
 630   (1.5 2.0 1.0 2 1))
 631
 632 (deftest gaussian-random.1
 633     (let ((min -0.2)
 634           (max +0.2))
 635       (multiple-value-bind (g1 g2)
 636           (gaussian-random min max)
 637         (values (<= min g1 max)
 638                 (<= min g2 max)
 639                 (/= g1 g2) ;uh
 640                 )))
 641   t
 642   t
 643   t)
 644
 645 (deftest iota.1
 646     (iota 3)
 647   (0 1 2))
 648
 649 (deftest iota.2
 650     (iota 3 :start 0.0d0)
 651   (0.0d0 1.0d0 2.0d0))
 652
 653 (deftest iota.3
 654     (iota 3 :start 2 :step 3.0)
 655   (2.0 5.0 8.0))
 656
 657 (deftest map-iota.1
 658     (let (all)
 659       (declare (notinline map-iota))
 660       (values (map-iota (lambda (x) (push x all))
 661                         3
 662                         :start 2
 663                         :step 1.1d0)
 664               all))
 665   3
 666   (4.2d0 3.1d0 2.0d0))
 667
 668 (deftest lerp.1
 669     (lerp 0.5 1 2)
 670   1.5)
 671
 672 (deftest lerp.2
 673     (lerp 0.1 1 2)
 674   1.1)
 675
 676 (deftest mean.1
 677     (mean '(1 2 3))
 678   2)
 679
 680 (deftest mean.2
 681     (mean '(1 2 3 4))
 682   5/2)
 683
 684 (deftest mean.3
 685     (mean '(1 2 10))
 686   13/3)
 687
 688 (deftest median.1
 689     (median '(100 0 99 1 98 2 97))
 690   97)
 691
 692 (deftest median.2
 693     (median '(100 0 99 1 98 2 97 96))
 694   195/2)
 695
 696 (deftest variance.1
 697     (variance (list 1 2 3))
 698   2/3)
 699
 700 (deftest standard-deviation.1
 701     (< 0 (standard-deviation (list 1 2 3)) 1)
 702   t)
 703
 704 (deftest maxf.1
 705     (let ((x 1))
 706       (maxf x 2)
 707       x)
 708   2)
 709
 710 (deftest maxf.2
 711     (let ((x 1))
 712       (maxf x 0)
 713       x)
 714   1)
 715
 716 (deftest maxf.3
 717     (let ((x 1)
 718           (c 0))
 719       (maxf x (incf c))
 720       (list x c))
 721   (1 1))
 722
 723 (deftest maxf.4
 724     (let ((xv (vector 0 0 0))
 725           (p 0))
 726       (maxf (svref xv (incf p)) (incf p))
 727       (list p xv))
 728   (2 #(0 2 0)))
 729
 730 (deftest minf.1
 731     (let ((y 1))
 732       (minf y 0)
 733       y)
 734   0)
 735
 736 (deftest minf.2
 737     (let ((xv (vector 10 10 10))
 738           (p 0))
 739       (minf (svref xv (incf p)) (incf p))
 740       (list p xv))
 741   (2 #(10 2 10)))
 742
 743 ;;;; Arrays
 744
 745 #+nil
 746 (deftest array-index.type)
 747
 748 #+nil
 749 (deftest copy-array)
 750
 751 ;;;; Sequences
 752
 753 (deftest rotate.1
 754     (list (rotate (list 1 2 3) 0)
 755           (rotate (list 1 2 3) 1)
 756           (rotate (list 1 2 3) 2)
 757           (rotate (list 1 2 3) 3)
 758           (rotate (list 1 2 3) 4))
 759   ((1 2 3)
 760    (3 1 2)
 761    (2 3 1)
 762    (1 2 3)
 763    (3 1 2)))
 764
 765 (deftest rotate.2
 766     (list (rotate (vector 1 2 3 4) 0)
 767           (rotate (vector 1 2 3 4))
 768           (rotate (vector 1 2 3 4) 2)
 769           (rotate (vector 1 2 3 4) 3)
 770           (rotate (vector 1 2 3 4) 4)
 771           (rotate (vector 1 2 3 4) 5))
 772   (#(1 2 3 4)
 773     #(4 1 2 3)
 774     #(3 4 1 2)
 775     #(2 3 4 1)
 776     #(1 2 3 4)
 777     #(4 1 2 3)))
 778
 779 (deftest rotate.3
 780     (list (rotate (list 1 2 3) 0)
 781           (rotate (list 1 2 3) -1)
 782           (rotate (list 1 2 3) -2)
 783           (rotate (list 1 2 3) -3)
 784           (rotate (list 1 2 3) -4))
 785   ((1 2 3)
 786    (2 3 1)
 787    (3 1 2)
 788    (1 2 3)
 789    (2 3 1)))
 790
 791 (deftest rotate.4
 792     (list (rotate (vector 1 2 3 4) 0)
 793           (rotate (vector 1 2 3 4) -1)
 794           (rotate (vector 1 2 3 4) -2)
 795           (rotate (vector 1 2 3 4) -3)
 796           (rotate (vector 1 2 3 4) -4)
 797           (rotate (vector 1 2 3 4) -5))
 798   (#(1 2 3 4)
 799    #(2 3 4 1)
 800    #(3 4 1 2)
 801    #(4 1 2 3)
 802    #(1 2 3 4)
 803    #(2 3 4 1)))
 804
 805 (deftest rotate.5
 806     (values (rotate (list 1) 17)
 807             (rotate (list 1) -5))
 808   (1)
 809   (1))
 810
 811 (deftest shuffle.1
 812     (let ((s (shuffle (iota 100))))
 813       (list (equal s (iota 100))
 814             (every (lambda (x)
 815                      (member x s))
 816                    (iota 100))
 817             (every (lambda (x)
 818                      (typep x '(integer 0 99)))
 819                    s)))
 820   (nil t t))
 821
 822 (deftest shuffle.2
 823     (let ((s (shuffle (coerce (iota 100) 'vector))))
 824       (list (equal s (coerce (iota 100) 'vector))
 825             (every (lambda (x)
 826                      (find x s))
 827                    (iota 100))
 828             (every (lambda (x)
 829                      (typep x '(integer 0 99)))
 830                    s)))
 831   (nil t t))
 832
 833 (deftest random-elt.1
 834     (let ((s1 #(1 2 3 4))
 835           (s2 '(1 2 3 4)))
 836       (list (dotimes (i 1000 nil)
 837               (unless (member (random-elt s1) s2)
 838                 (return nil))
 839               (when (/= (random-elt s1) (random-elt s1))
 840                 (return t)))
 841             (dotimes (i 1000 nil)
 842               (unless (member (random-elt s2) s2)
 843                 (return nil))
 844               (when (/= (random-elt s2) (random-elt s2))
 845                 (return t)))))
 846   (t t))
 847
 848 (deftest removef.1
 849     (let* ((x '(1 2 3))
 850            (x* x)
 851            (y #(1 2 3))
 852            (y* y))
 853       (removef x 1)
 854       (removef y 3)
 855       (list x x* y y*))
 856   ((2 3)
 857    (1 2 3)
 858    #(1 2)
 859    #(1 2 3)))
 860
 861 (deftest deletef.1
 862     (let* ((x '(1 2 3))
 863            (x* x)
 864            (y (vector 1 2 3)))
 865       (deletef x 2)
 866       (deletef y 1)
 867       (list x x* y))
 868   ((1 3)
 869    (1 3)
 870    #(2 3)))
 871
 872 (deftest proper-sequence.type.1
 873     (mapcar (lambda (x)
 874               (typep x 'proper-sequence))
 875             (list (list 1 2 3)
 876                   (vector 1 2 3)
 877                   #2a((1 2) (3 4))
 878                   (circular-list 1 2 3 4)))
 879   (t t nil nil))
 880
 881 (deftest emptyp.1
 882     (mapcar #'emptyp
 883             (list (list 1)
 884                   (circular-list 1)
 885                   nil
 886                   (vector)
 887                   (vector 1)))
 888   (nil nil t t nil))
 889
 890 (deftest sequence-of-length-p.1
 891     (mapcar #'sequence-of-length-p
 892             (list nil
 893                   #()
 894                   (list 1)
 895                   (vector 1)
 896                   (list 1 2)
 897                   (vector 1 2)
 898                   (list 1 2)
 899                   (vector 1 2)
 900                   (list 1 2)
 901                   (vector 1 2))
 902             (list 0
 903                   0
 904                   1
 905                   1
 906                   2
 907                   2
 908                   1
 909                   1
 910                   4
 911                   4))
 912   (t t t t t t nil nil nil nil))
 913
 914 (deftest copy-sequence.1
 915     (let ((l (list 1 2 3))
 916           (v (vector #\a #\b #\c)))
 917       (declare (notinline copy-sequence))
 918       (let ((l.list (copy-sequence 'list l))
 919             (l.vector (copy-sequence 'vector l))
 920             (l.spec-v (copy-sequence '(vector fixnum) l))
 921             (v.vector (copy-sequence 'vector v))
 922             (v.list (copy-sequence 'list v))
 923             (v.string (copy-sequence 'string v)))
 924         (list (member l (list l.list l.vector l.spec-v))
 925               (member v (list v.vector v.list v.string))
 926               (equal l.list l)
 927               (equalp l.vector #(1 2 3))
 928               (eq 'fixnum (array-element-type l.spec-v))
 929               (equalp v.vector v)
 930               (equal v.list '(#\a #\b #\c))
 931               (equal "abc" v.string))))
 932   (nil nil t t t t t t))
 933
 934 (deftest first-elt.1
 935     (mapcar #'first-elt
 936             (list (list 1 2 3)
 937                   "abc"
 938                   (vector :a :b :c)))
 939   (1 #\a :a))
 940
 941 (deftest first-elt.error.1
 942     (mapcar (lambda (x)
 943               (handler-case
 944                   (first-elt x)
 945                 (type-error ()
 946                   :type-error)))
 947             (list nil
 948                   #()
 949                   12
 950                   :zot))
 951   (:type-error
 952    :type-error
 953    :type-error
 954    :type-error))
 955
 956 (deftest setf-first-elt.1
 957     (let ((l (list 1 2 3))
 958           (s (copy-seq "foobar"))
 959           (v (vector :a :b :c)))
 960       (setf (first-elt l) -1
 961             (first-elt s) #\x
 962             (first-elt v) 'zot)
 963       (values l s v))
 964   (-1 2 3)
 965   "xoobar"
 966   #(zot :b :c))
 967
 968 (deftest setf-first-elt.error.1
 969     (let ((l 'foo))
 970       (multiple-value-bind (res err)
 971           (ignore-errors (setf (first-elt l) 4))
 972         (typep err 'type-error)))
 973   t)
 974
 975 (deftest last-elt.1
 976     (mapcar #'last-elt
 977             (list (list 1 2 3)
 978                   (vector :a :b :c)
 979                   "FOOBAR"
 980                   #*001
 981                   #*010))
 982   (3 :c #\R 1 0))
 983
 984 (deftest last-elt.error.1
 985     (mapcar (lambda (x)
 986               (handler-case
 987                   (last-elt x)
 988                 (type-error ()
 989                   :type-error)))
 990             (list nil
 991                   #()
 992                   12
 993                   :zot
 994                   (circular-list 1 2 3)
 995                   (list* 1 2 3 (circular-list 4 5))))
 996   (:type-error
 997    :type-error
 998    :type-error
 999    :type-error
1000    :type-error
1001    :type-error))
1002
1003 (deftest setf-last-elt.1
1004     (let ((l (list 1 2 3))
1005           (s (copy-seq "foobar"))
1006           (b (copy-seq #*010101001)))
1007       (setf (last-elt l) '???
1008             (last-elt s) #\?
1009             (last-elt b) 0)
1010       (values l s b))
1011   (1 2 ???)
1012   "fooba?"
1013   #*010101000)
1014
1015 (deftest setf-last-elt.error.1
1016     (handler-case
1017         (setf (last-elt 'foo) 13)
1018       (type-error ()
1019         :type-error))
1020   :type-error)
1021
1022 (deftest starts-with.1
1023     (list (starts-with 1 '(1 2 3))
1024           (starts-with 1 #(1 2 3))
1025           (starts-with #\x "xyz")
1026           (starts-with 2 '(1 2 3))
1027           (starts-with 3 #(1 2 3))
1028           (starts-with 1 1)
1029           (starts-with nil nil))
1030   (t t t nil nil nil nil))
1031
1032 (deftest starts-with.2
1033     (values (starts-with 1 '(-1 2 3) :key '-)
1034             (starts-with "foo" '("foo" "bar") :test 'equal)
1035             (starts-with "f" '(#\f) :key 'string :test 'equal)
1036             (starts-with -1 '(0 1 2) :key #'1+)
1037             (starts-with "zot" '("ZOT") :test 'equal))
1038   t
1039   t
1040   t
1041   nil
1042   nil)
1043
1044 (deftest ends-with.1
1045     (list (ends-with 3 '(1 2 3))
1046           (ends-with 3 #(1 2 3))
1047           (ends-with #\z "xyz")
1048           (ends-with 2 '(1 2 3))
1049           (ends-with 1 #(1 2 3))
1050           (ends-with 1 1)
1051           (ends-with nil nil))
1052   (t t t nil nil nil nil))
1053
1054 (deftest ends-with.2
1055     (values (ends-with 2 '(0 13 1) :key '1+)
1056             (ends-with "foo" (vector "bar" "foo") :test 'equal)
1057             (ends-with "X" (vector 1 2 #\X) :key 'string :test 'equal)
1058             (ends-with "foo" "foo" :test 'equal))
1059   t
1060   t
1061   t
1062   nil)
1063
1064 (deftest ends-with.error.1
1065     (handler-case
1066         (ends-with 3 (circular-list 3 3 3 1 3 3))
1067       (type-error ()
1068         :type-error))
1069   :type-error)
1070
1071 (deftest with-unique-names.1
1072     (let ((*gensym-counter* 0))
1073       (let ((syms (with-unique-names (foo bar quux)
1074                     (list foo bar quux))))
1075         (list (find-if #'symbol-package syms)
1076               (equal '("FOO0" "BAR1" "QUUX2")
1077                      (mapcar #'symbol-name syms)))))
1078   (nil t))
1079
1080 (deftest with-unique-names.2
1081     (let ((*gensym-counter* 0))
1082       (let ((syms (with-unique-names ((foo "_foo_") (bar -bar-) (quux #\q))
1083                     (list foo bar quux))))
1084         (list (find-if #'symbol-package syms)
1085               (equal '("_foo_0" "-BAR-1" "q2")
1086                      (mapcar #'symbol-name syms)))))
1087   (nil t))
1088
1089 (deftest with-unique-names.3
1090     (let ((*gensym-counter* 0))
1091       (multiple-value-bind (res err)
1092           (ignore-errors
1093             (eval
1094              '(let ((syms
1095                      (with-unique-names ((foo "_foo_") (bar -bar-) (quux 42))
1096                        (list foo bar quux))))
1097                (list (find-if #'symbol-package syms)
1098                 (equal '("_foo_0" "-BAR-1" "q2")
1099                  (mapcar #'symbol-name syms))))))
1100         (typep err 'error)))
1101   t)
1102
1103 (deftest once-only.1
1104     (macrolet ((cons1.good (x)
1105                  (once-only (x)
1106                    `(cons ,x ,x)))
1107                (cons1.bad (x)
1108                  `(cons ,x ,x)))
1109       (let ((y 0))
1110         (list (cons1.good (incf y))
1111               y
1112               (cons1.bad (incf y))
1113               y)))
1114   ((1 . 1) 1 (2 . 3) 3))
1115
1116 (deftest parse-body.1
1117     (parse-body '("doc" "body") :documentation t)
1118   ("body")
1119   nil
1120   "doc")
1121
1122 (deftest parse-body.2
1123     (parse-body '("body") :documentation t)
1124   ("body")
1125   nil
1126   nil)
1127
1128 (deftest parse-body.3
1129     (parse-body '("doc" "body"))
1130   ("doc" "body")
1131   nil
1132   nil)
1133
1134 (deftest parse-body.4
1135     (parse-body '((declare (foo)) "doc" (declare (bar)) body) :documentation t)
1136   (body)
1137   ((declare (foo)) (declare (bar)))
1138   "doc")
1139
1140 (deftest parse-body.5
1141     (parse-body '((declare (foo)) "doc" (declare (bar)) body))
1142   ("doc" (declare (bar)) body)
1143   ((declare (foo)))
1144   nil)
1145
1146 (deftest parse-body.6
1147     (multiple-value-bind (res err)
1148         (ignore-errors
1149           (parse-body '("foo" "bar" "quux")
1150                       :documentation t))
1151       (typep err 'error))
1152   t)
1153
1154 ;;;; Symbols
1155
1156 (deftest ensure-symbol.1
1157     (ensure-symbol :cons :cl)
1158   cons
1159   :external)
1160
1161 (deftest ensure-symbol.2
1162     (ensure-symbol "CONS" :alexandria)
1163   cons
1164   :inherited)
1165
1166 (deftest ensure-symbol.3
1167     (ensure-symbol 'foo :keyword)
1168   :foo
1169   :external)
1170
1171 (deftest ensure-symbol.4
1172     (ensure-symbol #\* :alexandria)
1173   *
1174   :inherited)
1175
1176 (deftest format-symbol.1
1177     (let ((s (format-symbol nil "X-~D" 13)))
1178       (list (symbol-package s)
1179             (symbol-name s)))
1180   (nil "X-13"))
1181
1182 (deftest format-symbol.2
1183     (format-symbol :keyword "SYM-~A" :bolic)
1184   :sym-bolic)
1185
1186 (deftest format-symbol.3
1187     (let ((*package* (find-package :cl)))
1188       (format-symbol t "FIND-~A" 'package))
1189   find-package)
1190
1191 (deftest make-keyword.1
1192     (list (make-keyword 'zot)
1193           (make-keyword "FOO")
1194           (make-keyword #\Q))
1195   (:zot :foo :q))
1196
1197 (deftest make-gensym-list.1
1198     (let ((*gensym-counter* 0))
1199       (let ((syms (make-gensym-list 3 "FOO")))
1200         (list (find-if 'symbol-package syms)
1201               (equal '("FOO0" "FOO1" "FOO2")
1202                      (mapcar 'symbol-name syms)))))
1203   (nil t))
1204
1205 ;;;; Type-system
1206
1207 (deftest of-type.1
1208     (locally
1209         (declare (notinline of-type))
1210     (let ((f (of-type 'string)))
1211       (list (funcall f "foo")
1212             (funcall f 'bar))))
1213   (t nil))
1214
1215 (deftest type=.1
1216     (type= 'string 'string)
1217   t
1218   t)
1219
1220 (deftest type=.2
1221     (type= 'list '(or null cons))
1222   t
1223   t)
1224
1225 (deftest type=.3
1226     (type= 'null '(and symbol list))
1227   t
1228   t)
1229
1230 (deftest type=.4
1231     (type= 'string '(satisfies emptyp))
1232   nil
1233   nil)
1234
1235 (deftest type=.5
1236     (type= 'string 'list)
1237   nil
1238   t)
1239
1240 ;;;; Bindings
1241
1242 (declaim (notinline opaque))
1243 (defun opaque (x)
1244   x)
1245
1246 (deftest if-let.1
1247     (if-let (x (opaque :ok))
1248             x
1249             :bad)
1250   :ok)
1251
1252 (deftest if-let.2
1253     (if-let (x (opaque nil))
1254             :bad
1255             (and (not x) :ok))
1256   :ok)
1257
1258 (deftest if-let.3
1259     (let ((x 1))
1260       (if-let ((x 2)
1261                (y x))
1262               (+ x y)
1263               :oops))
1264   3)
1265
1266 (deftest if-let.4
1267     (if-let ((x 1)
1268              (y nil))
1269             :oops
1270             (and (not y) x))
1271   1)
1272
1273 (deftest if-let.5
1274     (if-let (x)
1275             :oops
1276             (not x))
1277   t)
1278
1279 (deftest if-let.error.1
1280     (handler-case
1281         (eval '(if-let x
1282                 :oops
1283                 :oops))
1284       (type-error ()
1285         :type-error))
1286   :type-error)
1287
1288 (deftest if-let*.1
1289     (let ((x 1))
1290       (if-let* ((x 2)
1291                 (y x))
1292                (+ x y)
1293                :oops))
1294   4)
1295
1296 (deftest if-let*.2
1297     (if-let* ((x 2)
1298               (y (prog1 x (setf x nil))))
1299              :oops
1300              (and (not x) y))
1301   2)
1302
1303 (deftest if-let*.3
1304     (if-let* (x 1)
1305              x
1306              :oops)
1307   1)
1308
1309 (deftest if-let*.error.1
1310     (handler-case
1311         (eval '(if-let* x :oops :oops))
1312       (type-error ()
1313         :type-error))
1314   :type-error)
1315
1316 (deftest when-let.1
1317     (when-let (x (opaque :ok))
1318       (setf x (cons x x))
1319       x)
1320   (:ok . :ok))
1321
1322 (deftest when-let.2
1323     (when-let ((x 1)
1324                (y nil)
1325                (z 3))
1326       :oops)
1327   nil)
1328
1329 (deftest when-let.3
1330     (let ((x 1))
1331       (when-let ((x 2)
1332                  (y x))
1333         (+ x y)))
1334   3)
1335
1336 (deftest when-let.error.1
1337     (handler-case
1338         (eval '(when-let x :oops))
1339       (type-error ()
1340         :type-error))
1341   :type-error)
1342
1343 (deftest when-let*.1
1344     (let ((x 1))
1345       (when-let* ((x 2)
1346                   (y x))
1347         (+ x y)))
1348   4)
1349
1350 (deftest when-let*.2
1351     (let ((y 1))
1352       (when-let* (x y)
1353         (1+ x)))
1354   2)
1355
1356 (deftest when-let*.error.1
1357     (handler-case
1358         (eval '(when-let* x :oops))
1359       (type-error ()
1360         :type-error))
1361   :type-error)