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 nconcf.1
 384     (let ((list1 (list 1 2 3))
 385           (list2 (list 4 5 6)))
 386       (nconcf list1 list2 (list 7 8 9))
 387       list1)
 388   (1 2 3 4 5 6 7 8 9))
 389
 390 (deftest circular-list.1
 391     (let ((circle (circular-list 1 2 3)))
 392       (list (first circle)
 393             (second circle)
 394             (third circle)
 395             (fourth circle)
 396             (eq circle (nthcdr 3 circle))))
 397   (1 2 3 1 t))
 398
 399 (deftest circular-list-p.1
 400     (let* ((circle (circular-list 1 2 3 4))
 401            (tree (list circle circle))
 402            (dotted (cons circle t))
 403            (proper (list 1 2 3 circle))
 404            (tailcirc (list* 1 2 3 circle)))
 405       (list (circular-list-p circle)
 406             (circular-list-p tree)
 407             (circular-list-p dotted)
 408             (circular-list-p proper)
 409             (circular-list-p tailcirc)))
 410   (t nil nil nil t))
 411
 412 (deftest circular-list-p.2
 413     (circular-list-p 'foo)
 414   nil)
 415
 416 (deftest circular-tree-p.1
 417     (let* ((circle (circular-list 1 2 3 4))
 418            (tree1 (list circle circle))
 419            (tree2 (let* ((level2 (list 1 nil 2))
 420                          (level1 (list level2)))
 421                     (setf (second level2) level1)
 422                     level1))
 423            (dotted (cons circle t))
 424            (proper (list 1 2 3 circle))
 425            (tailcirc (list* 1 2 3 circle))
 426            (quite-proper (list 1 2 3))
 427            (quite-dotted (list 1 (cons 2 3))))
 428       (list (circular-tree-p circle)
 429             (circular-tree-p tree1)
 430             (circular-tree-p tree2)
 431             (circular-tree-p dotted)
 432             (circular-tree-p proper)
 433             (circular-tree-p tailcirc)
 434             (circular-tree-p quite-proper)
 435             (circular-tree-p quite-dotted)))
 436   (t t t t t t nil nil))
 437
 438 (deftest proper-list-p.1
 439     (let ((l1 (list 1))
 440           (l2 (list 1 2))
 441           (l3 (cons 1 2))
 442           (l4 (list (cons 1 2) 3))
 443           (l5 (circular-list 1 2)))
 444       (list (proper-list-p l1)
 445             (proper-list-p l2)
 446             (proper-list-p l3)
 447             (proper-list-p l4)
 448             (proper-list-p l5)))
 449   (t t nil t nil))
 450
 451 (deftest proper-list-p.2
 452     (proper-list-p '(1 2 . 3))
 453   nil)
 454
 455 (deftest proper-list.type.1
 456     (let ((l1 (list 1))
 457           (l2 (list 1 2))
 458           (l3 (cons 1 2))
 459           (l4 (list (cons 1 2) 3))
 460           (l5 (circular-list 1 2)))
 461       (list (typep l1 'proper-list)
 462             (typep l2 'proper-list)
 463             (typep l3 'proper-list)
 464             (typep l4 'proper-list)
 465             (typep l5 'proper-list)))
 466   (t t nil t nil))
 467
 468 (deftest lastcar.1
 469     (let ((l1 (list 1))
 470           (l2 (list 1 2)))
 471       (list (lastcar l1)
 472             (lastcar l2)))
 473   (1 2))
 474
 475 (deftest lastcar.error.2
 476     (handler-case
 477         (progn
 478           (lastcar (circular-list 1 2 3))
 479           nil)
 480       (error ()
 481         t))
 482   t)
 483
 484 (deftest setf-lastcar.1
 485     (let ((l (list 1 2 3 4)))
 486       (values (lastcar l)
 487               (progn
 488                 (setf (lastcar l) 42)
 489                 (lastcar l))))
 490   4
 491   42)
 492
 493 (deftest setf-lastcar.2
 494     (let ((l (circular-list 1 2 3)))
 495       (multiple-value-bind (res err)
 496           (ignore-errors (setf (lastcar l) 4))
 497         (typep err 'type-error)))
 498   t)
 499
 500 (deftest make-circular-list.1
 501     (let ((l (make-circular-list 3 :initial-element :x)))
 502       (setf (car l) :y)
 503       (list (eq l (nthcdr 3 l))
 504             (first l)
 505             (second l)
 506             (third l)
 507             (fourth l)))
 508   (t :y :x :x :y))
 509
 510 (deftest circular-list.type.1
 511     (let* ((l1 (list 1 2 3))
 512            (l2 (circular-list 1 2 3))
 513            (l3 (list* 1 2 3 l2)))
 514       (list (typep l1 'circular-list)
 515             (typep l2 'circular-list)
 516             (typep l3 'circular-list)))
 517   (nil t t))
 518
 519 (deftest ensure-list.1
 520     (let ((x (list 1))
 521           (y 2))
 522       (list (ensure-list x)
 523             (ensure-list y)))
 524   ((1) (2)))
 525
 526 (deftest ensure-cons.1
 527     (let ((x (cons 1 2))
 528           (y nil)
 529           (z "foo"))
 530       (values (ensure-cons x)
 531               (ensure-cons y)
 532               (ensure-cons z)))
 533   (1 . 2)
 534   (nil)
 535   ("foo"))
 536
 537 (deftest setp.1
 538     (setp '(1))
 539   t)
 540
 541 (deftest setp.2
 542     (setp nil)
 543   t)
 544
 545 (deftest setp.3
 546     (setp "foo")
 547   nil)
 548
 549 (deftest setp.4
 550     (setp '(1 2 3 1))
 551   nil)
 552
 553 (deftest setp.5
 554     (setp '(1 2 3))
 555   t)
 556
 557 (deftest setp.6
 558     (setp '(a :a))
 559   t)
 560
 561 (deftest setp.7
 562     (setp '(a :a) :key 'character)
 563   nil)
 564
 565 (deftest setp.8
 566     (setp '(a :a) :key 'character :test (constantly nil))
 567   t)
 568
 569 (deftest set-equal.1
 570     (set-equal '(1 2 3) '(3 1 2))
 571   t)
 572
 573 (deftest set-equal.2
 574     (set-equal '("Xa") '("Xb")
 575                :test (lambda (a b) (eql (char a 0) (char b 0))))
 576   t)
 577
 578 (deftest set-equal.3
 579     (set-equal '(1 2) '(4 2))
 580   nil)
 581
 582 (deftest set-equal.4
 583     (set-equal '(a b c) '(:a :b :c) :key 'string :test 'equal)
 584   t)
 585
 586 (deftest set-equal.5
 587     (set-equal '(a d c) '(:a :b :c) :key 'string :test 'equal)
 588   nil)
 589
 590 (deftest set-equal.6
 591     (set-equal '(a b c) '(a b c d))
 592   nil)
 593
 594 (deftest map-product.1
 595     (map-product 'cons '(2 3) '(1 4))
 596   ((2 . 1) (2 . 4) (3 . 1) (3 . 4)))
 597
 598 (deftest map-product.2
 599     (map-product #'cons '(2 3) '(1 4))
 600   ((2 . 1) (2 . 4) (3 . 1) (3 . 4)))
 601
 602 (deftest flatten.1
 603     (flatten '((1) 2 (((3 4))) ((((5)) 6)) 7))
 604   (1 2 3 4 5 6 7))
 605
 606 (deftest sans.1
 607     (let ((orig '(a 1 b 2 c 3 d 4)))
 608       (list (sans orig 'a 'c)
 609             (sans orig 'b 'd)
 610             (sans orig 'b)
 611             (sans orig 'a)
 612             (sans orig 'd 42 "zot")
 613             (sans orig 'a 'b 'c 'd)
 614             (sans orig 'a 'b 'c 'd 'x)
 615             (equal orig '(a 1 b 2 c 3 d 4))))
 616   ((b 2 d 4)
 617    (a 1 c 3)
 618    (a 1 c 3 d 4)
 619    (b 2 c 3 d 4)
 620    (a 1 b 2 c 3)
 621    nil
 622    nil
 623    t))
 624
 625 (deftest mappend.1
 626     (mappend (compose 'list '*) '(1 2 3) '(1 2 3))
 627   (1 4 9))
 628
 629 ;;;; Numbers
 630
 631 (deftest clamp.1
 632     (list (clamp 1.5 1 2)
 633           (clamp 2.0 1 2)
 634           (clamp 1.0 1 2)
 635           (clamp 3 1 2)
 636           (clamp 0 1 2))
 637   (1.5 2.0 1.0 2 1))
 638
 639 (deftest gaussian-random.1
 640     (let ((min -0.2)
 641           (max +0.2))
 642       (multiple-value-bind (g1 g2)
 643           (gaussian-random min max)
 644         (values (<= min g1 max)
 645                 (<= min g2 max)
 646                 (/= g1 g2) ;uh
 647                 )))
 648   t
 649   t
 650   t)
 651
 652 (deftest iota.1
 653     (iota 3)
 654   (0 1 2))
 655
 656 (deftest iota.2
 657     (iota 3 :start 0.0d0)
 658   (0.0d0 1.0d0 2.0d0))
 659
 660 (deftest iota.3
 661     (iota 3 :start 2 :step 3.0)
 662   (2.0 5.0 8.0))
 663
 664 (deftest map-iota.1
 665     (let (all)
 666       (declare (notinline map-iota))
 667       (values (map-iota (lambda (x) (push x all))
 668                         3
 669                         :start 2
 670                         :step 1.1d0)
 671               all))
 672   3
 673   (4.2d0 3.1d0 2.0d0))
 674
 675 (deftest lerp.1
 676     (lerp 0.5 1 2)
 677   1.5)
 678
 679 (deftest lerp.2
 680     (lerp 0.1 1 2)
 681   1.1)
 682
 683 (deftest mean.1
 684     (mean '(1 2 3))
 685   2)
 686
 687 (deftest mean.2
 688     (mean '(1 2 3 4))
 689   5/2)
 690
 691 (deftest mean.3
 692     (mean '(1 2 10))
 693   13/3)
 694
 695 (deftest median.1
 696     (median '(100 0 99 1 98 2 97))
 697   97)
 698
 699 (deftest median.2
 700     (median '(100 0 99 1 98 2 97 96))
 701   195/2)
 702
 703 (deftest variance.1
 704     (variance (list 1 2 3))
 705   2/3)
 706
 707 (deftest standard-deviation.1
 708     (< 0 (standard-deviation (list 1 2 3)) 1)
 709   t)
 710
 711 (deftest maxf.1
 712     (let ((x 1))
 713       (maxf x 2)
 714       x)
 715   2)
 716
 717 (deftest maxf.2
 718     (let ((x 1))
 719       (maxf x 0)
 720       x)
 721   1)
 722
 723 (deftest maxf.3
 724     (let ((x 1)
 725           (c 0))
 726       (maxf x (incf c))
 727       (list x c))
 728   (1 1))
 729
 730 (deftest maxf.4
 731     (let ((xv (vector 0 0 0))
 732           (p 0))
 733       (maxf (svref xv (incf p)) (incf p))
 734       (list p xv))
 735   (2 #(0 2 0)))
 736
 737 (deftest minf.1
 738     (let ((y 1))
 739       (minf y 0)
 740       y)
 741   0)
 742
 743 (deftest minf.2
 744     (let ((xv (vector 10 10 10))
 745           (p 0))
 746       (minf (svref xv (incf p)) (incf p))
 747       (list p xv))
 748   (2 #(10 2 10)))
 749
 750 ;;;; Arrays
 751
 752 #+nil
 753 (deftest array-index.type)
 754
 755 #+nil
 756 (deftest copy-array)
 757
 758 ;;;; Sequences
 759
 760 (deftest rotate.1
 761     (list (rotate (list 1 2 3) 0)
 762           (rotate (list 1 2 3) 1)
 763           (rotate (list 1 2 3) 2)
 764           (rotate (list 1 2 3) 3)
 765           (rotate (list 1 2 3) 4))
 766   ((1 2 3)
 767    (3 1 2)
 768    (2 3 1)
 769    (1 2 3)
 770    (3 1 2)))
 771
 772 (deftest rotate.2
 773     (list (rotate (vector 1 2 3 4) 0)
 774           (rotate (vector 1 2 3 4))
 775           (rotate (vector 1 2 3 4) 2)
 776           (rotate (vector 1 2 3 4) 3)
 777           (rotate (vector 1 2 3 4) 4)
 778           (rotate (vector 1 2 3 4) 5))
 779   (#(1 2 3 4)
 780     #(4 1 2 3)
 781     #(3 4 1 2)
 782     #(2 3 4 1)
 783     #(1 2 3 4)
 784     #(4 1 2 3)))
 785
 786 (deftest rotate.3
 787     (list (rotate (list 1 2 3) 0)
 788           (rotate (list 1 2 3) -1)
 789           (rotate (list 1 2 3) -2)
 790           (rotate (list 1 2 3) -3)
 791           (rotate (list 1 2 3) -4))
 792   ((1 2 3)
 793    (2 3 1)
 794    (3 1 2)
 795    (1 2 3)
 796    (2 3 1)))
 797
 798 (deftest rotate.4
 799     (list (rotate (vector 1 2 3 4) 0)
 800           (rotate (vector 1 2 3 4) -1)
 801           (rotate (vector 1 2 3 4) -2)
 802           (rotate (vector 1 2 3 4) -3)
 803           (rotate (vector 1 2 3 4) -4)
 804           (rotate (vector 1 2 3 4) -5))
 805   (#(1 2 3 4)
 806    #(2 3 4 1)
 807    #(3 4 1 2)
 808    #(4 1 2 3)
 809    #(1 2 3 4)
 810    #(2 3 4 1)))
 811
 812 (deftest rotate.5
 813     (values (rotate (list 1) 17)
 814             (rotate (list 1) -5))
 815   (1)
 816   (1))
 817
 818 (deftest shuffle.1
 819     (let ((s (shuffle (iota 100))))
 820       (list (equal s (iota 100))
 821             (every (lambda (x)
 822                      (member x s))
 823                    (iota 100))
 824             (every (lambda (x)
 825                      (typep x '(integer 0 99)))
 826                    s)))
 827   (nil t t))
 828
 829 (deftest shuffle.2
 830     (let ((s (shuffle (coerce (iota 100) 'vector))))
 831       (list (equal s (coerce (iota 100) 'vector))
 832             (every (lambda (x)
 833                      (find x s))
 834                    (iota 100))
 835             (every (lambda (x)
 836                      (typep x '(integer 0 99)))
 837                    s)))
 838   (nil t t))
 839
 840 (deftest random-elt.1
 841     (let ((s1 #(1 2 3 4))
 842           (s2 '(1 2 3 4)))
 843       (list (dotimes (i 1000 nil)
 844               (unless (member (random-elt s1) s2)
 845                 (return nil))
 846               (when (/= (random-elt s1) (random-elt s1))
 847                 (return t)))
 848             (dotimes (i 1000 nil)
 849               (unless (member (random-elt s2) s2)
 850                 (return nil))
 851               (when (/= (random-elt s2) (random-elt s2))
 852                 (return t)))))
 853   (t t))
 854
 855 (deftest removef.1
 856     (let* ((x '(1 2 3))
 857            (x* x)
 858            (y #(1 2 3))
 859            (y* y))
 860       (removef x 1)
 861       (removef y 3)
 862       (list x x* y y*))
 863   ((2 3)
 864    (1 2 3)
 865    #(1 2)
 866    #(1 2 3)))
 867
 868 (deftest deletef.1
 869     (let* ((x '(1 2 3))
 870            (x* x)
 871            (y (vector 1 2 3)))
 872       (deletef x 2)
 873       (deletef y 1)
 874       (list x x* y))
 875   ((1 3)
 876    (1 3)
 877    #(2 3)))
 878
 879 (deftest proper-sequence.type.1
 880     (mapcar (lambda (x)
 881               (typep x 'proper-sequence))
 882             (list (list 1 2 3)
 883                   (vector 1 2 3)
 884                   #2a((1 2) (3 4))
 885                   (circular-list 1 2 3 4)))
 886   (t t nil nil))
 887
 888 (deftest emptyp.1
 889     (mapcar #'emptyp
 890             (list (list 1)
 891                   (circular-list 1)
 892                   nil
 893                   (vector)
 894                   (vector 1)))
 895   (nil nil t t nil))
 896
 897 (deftest sequence-of-length-p.1
 898     (mapcar #'sequence-of-length-p
 899             (list nil
 900                   #()
 901                   (list 1)
 902                   (vector 1)
 903                   (list 1 2)
 904                   (vector 1 2)
 905                   (list 1 2)
 906                   (vector 1 2)
 907                   (list 1 2)
 908                   (vector 1 2))
 909             (list 0
 910                   0
 911                   1
 912                   1
 913                   2
 914                   2
 915                   1
 916                   1
 917                   4
 918                   4))
 919   (t t t t t t nil nil nil nil))
 920
 921 (deftest copy-sequence.1
 922     (let ((l (list 1 2 3))
 923           (v (vector #\a #\b #\c)))
 924       (declare (notinline copy-sequence))
 925       (let ((l.list (copy-sequence 'list l))
 926             (l.vector (copy-sequence 'vector l))
 927             (l.spec-v (copy-sequence '(vector fixnum) l))
 928             (v.vector (copy-sequence 'vector v))
 929             (v.list (copy-sequence 'list v))
 930             (v.string (copy-sequence 'string v)))
 931         (list (member l (list l.list l.vector l.spec-v))
 932               (member v (list v.vector v.list v.string))
 933               (equal l.list l)
 934               (equalp l.vector #(1 2 3))
 935               (eq 'fixnum (array-element-type l.spec-v))
 936               (equalp v.vector v)
 937               (equal v.list '(#\a #\b #\c))
 938               (equal "abc" v.string))))
 939   (nil nil t t t t t t))
 940
 941 (deftest first-elt.1
 942     (mapcar #'first-elt
 943             (list (list 1 2 3)
 944                   "abc"
 945                   (vector :a :b :c)))
 946   (1 #\a :a))
 947
 948 (deftest first-elt.error.1
 949     (mapcar (lambda (x)
 950               (handler-case
 951                   (first-elt x)
 952                 (type-error ()
 953                   :type-error)))
 954             (list nil
 955                   #()
 956                   12
 957                   :zot))
 958   (:type-error
 959    :type-error
 960    :type-error
 961    :type-error))
 962
 963 (deftest setf-first-elt.1
 964     (let ((l (list 1 2 3))
 965           (s (copy-seq "foobar"))
 966           (v (vector :a :b :c)))
 967       (setf (first-elt l) -1
 968             (first-elt s) #\x
 969             (first-elt v) 'zot)
 970       (values l s v))
 971   (-1 2 3)
 972   "xoobar"
 973   #(zot :b :c))
 974
 975 (deftest setf-first-elt.error.1
 976     (let ((l 'foo))
 977       (multiple-value-bind (res err)
 978           (ignore-errors (setf (first-elt l) 4))
 979         (typep err 'type-error)))
 980   t)
 981
 982 (deftest last-elt.1
 983     (mapcar #'last-elt
 984             (list (list 1 2 3)
 985                   (vector :a :b :c)
 986                   "FOOBAR"
 987                   #*001
 988                   #*010))
 989   (3 :c #\R 1 0))
 990
 991 (deftest last-elt.error.1
 992     (mapcar (lambda (x)
 993               (handler-case
 994                   (last-elt x)
 995                 (type-error ()
 996                   :type-error)))
 997             (list nil
 998                   #()
 999                   12
1000                   :zot
1001                   (circular-list 1 2 3)
1002                   (list* 1 2 3 (circular-list 4 5))))
1003   (:type-error
1004    :type-error
1005    :type-error
1006    :type-error
1007    :type-error
1008    :type-error))
1009
1010 (deftest setf-last-elt.1
1011     (let ((l (list 1 2 3))
1012           (s (copy-seq "foobar"))
1013           (b (copy-seq #*010101001)))
1014       (setf (last-elt l) '???
1015             (last-elt s) #\?
1016             (last-elt b) 0)
1017       (values l s b))
1018   (1 2 ???)
1019   "fooba?"
1020   #*010101000)
1021
1022 (deftest setf-last-elt.error.1
1023     (handler-case
1024         (setf (last-elt 'foo) 13)
1025       (type-error ()
1026         :type-error))
1027   :type-error)
1028
1029 (deftest starts-with.1
1030     (list (starts-with 1 '(1 2 3))
1031           (starts-with 1 #(1 2 3))
1032           (starts-with #\x "xyz")
1033           (starts-with 2 '(1 2 3))
1034           (starts-with 3 #(1 2 3))
1035           (starts-with 1 1)
1036           (starts-with nil nil))
1037   (t t t nil nil nil nil))
1038
1039 (deftest starts-with.2
1040     (values (starts-with 1 '(-1 2 3) :key '-)
1041             (starts-with "foo" '("foo" "bar") :test 'equal)
1042             (starts-with "f" '(#\f) :key 'string :test 'equal)
1043             (starts-with -1 '(0 1 2) :key #'1+)
1044             (starts-with "zot" '("ZOT") :test 'equal))
1045   t
1046   t
1047   t
1048   nil
1049   nil)
1050
1051 (deftest ends-with.1
1052     (list (ends-with 3 '(1 2 3))
1053           (ends-with 3 #(1 2 3))
1054           (ends-with #\z "xyz")
1055           (ends-with 2 '(1 2 3))
1056           (ends-with 1 #(1 2 3))
1057           (ends-with 1 1)
1058           (ends-with nil nil))
1059   (t t t nil nil nil nil))
1060
1061 (deftest ends-with.2
1062     (values (ends-with 2 '(0 13 1) :key '1+)
1063             (ends-with "foo" (vector "bar" "foo") :test 'equal)
1064             (ends-with "X" (vector 1 2 #\X) :key 'string :test 'equal)
1065             (ends-with "foo" "foo" :test 'equal))
1066   t
1067   t
1068   t
1069   nil)
1070
1071 (deftest ends-with.error.1
1072     (handler-case
1073         (ends-with 3 (circular-list 3 3 3 1 3 3))
1074       (type-error ()
1075         :type-error))
1076   :type-error)
1077
1078 (deftest with-unique-names.1
1079     (let ((*gensym-counter* 0))
1080       (let ((syms (with-unique-names (foo bar quux)
1081                     (list foo bar quux))))
1082         (list (find-if #'symbol-package syms)
1083               (equal '("FOO0" "BAR1" "QUUX2")
1084                      (mapcar #'symbol-name syms)))))
1085   (nil t))
1086
1087 (deftest with-unique-names.2
1088     (let ((*gensym-counter* 0))
1089       (let ((syms (with-unique-names ((foo "_foo_") (bar -bar-) (quux #\q))
1090                     (list foo bar quux))))
1091         (list (find-if #'symbol-package syms)
1092               (equal '("_foo_0" "-BAR-1" "q2")
1093                      (mapcar #'symbol-name syms)))))
1094   (nil t))
1095
1096 (deftest with-unique-names.3
1097     (let ((*gensym-counter* 0))
1098       (multiple-value-bind (res err)
1099           (ignore-errors
1100             (eval
1101              '(let ((syms
1102                      (with-unique-names ((foo "_foo_") (bar -bar-) (quux 42))
1103                        (list foo bar quux))))
1104                (list (find-if #'symbol-package syms)
1105                 (equal '("_foo_0" "-BAR-1" "q2")
1106                  (mapcar #'symbol-name syms))))))
1107         (typep err 'error)))
1108   t)
1109
1110 (deftest once-only.1
1111     (macrolet ((cons1.good (x)
1112                  (once-only (x)
1113                    `(cons ,x ,x)))
1114                (cons1.bad (x)
1115                  `(cons ,x ,x)))
1116       (let ((y 0))
1117         (list (cons1.good (incf y))
1118               y
1119               (cons1.bad (incf y))
1120               y)))
1121   ((1 . 1) 1 (2 . 3) 3))
1122
1123 (deftest parse-body.1
1124     (parse-body '("doc" "body") :documentation t)
1125   ("body")
1126   nil
1127   "doc")
1128
1129 (deftest parse-body.2
1130     (parse-body '("body") :documentation t)
1131   ("body")
1132   nil
1133   nil)
1134
1135 (deftest parse-body.3
1136     (parse-body '("doc" "body"))
1137   ("doc" "body")
1138   nil
1139   nil)
1140
1141 (deftest parse-body.4
1142     (parse-body '((declare (foo)) "doc" (declare (bar)) body) :documentation t)
1143   (body)
1144   ((declare (foo)) (declare (bar)))
1145   "doc")
1146
1147 (deftest parse-body.5
1148     (parse-body '((declare (foo)) "doc" (declare (bar)) body))
1149   ("doc" (declare (bar)) body)
1150   ((declare (foo)))
1151   nil)
1152
1153 (deftest parse-body.6
1154     (multiple-value-bind (res err)
1155         (ignore-errors
1156           (parse-body '("foo" "bar" "quux")
1157                       :documentation t))
1158       (typep err 'error))
1159   t)
1160
1161 ;;;; Symbols
1162
1163 (deftest ensure-symbol.1
1164     (ensure-symbol :cons :cl)
1165   cons
1166   :external)
1167
1168 (deftest ensure-symbol.2
1169     (ensure-symbol "CONS" :alexandria)
1170   cons
1171   :inherited)
1172
1173 (deftest ensure-symbol.3
1174     (ensure-symbol 'foo :keyword)
1175   :foo
1176   :external)
1177
1178 (deftest ensure-symbol.4
1179     (ensure-symbol #\* :alexandria)
1180   *
1181   :inherited)
1182
1183 (deftest format-symbol.1
1184     (let ((s (format-symbol nil "X-~D" 13)))
1185       (list (symbol-package s)
1186             (symbol-name s)))
1187   (nil "X-13"))
1188
1189 (deftest format-symbol.2
1190     (format-symbol :keyword "SYM-~A" :bolic)
1191   :sym-bolic)
1192
1193 (deftest format-symbol.3
1194     (let ((*package* (find-package :cl)))
1195       (format-symbol t "FIND-~A" 'package))
1196   find-package)
1197
1198 (deftest make-keyword.1
1199     (list (make-keyword 'zot)
1200           (make-keyword "FOO")
1201           (make-keyword #\Q))
1202   (:zot :foo :q))
1203
1204 (deftest make-gensym-list.1
1205     (let ((*gensym-counter* 0))
1206       (let ((syms (make-gensym-list 3 "FOO")))
1207         (list (find-if 'symbol-package syms)
1208               (equal '("FOO0" "FOO1" "FOO2")
1209                      (mapcar 'symbol-name syms)))))
1210   (nil t))
1211
1212 ;;;; Type-system
1213
1214 (deftest of-type.1
1215     (locally
1216         (declare (notinline of-type))
1217     (let ((f (of-type 'string)))
1218       (list (funcall f "foo")
1219             (funcall f 'bar))))
1220   (t nil))
1221
1222 (deftest type=.1
1223     (type= 'string 'string)
1224   t
1225   t)
1226
1227 (deftest type=.2
1228     (type= 'list '(or null cons))
1229   t
1230   t)
1231
1232 (deftest type=.3
1233     (type= 'null '(and symbol list))
1234   t
1235   t)
1236
1237 (deftest type=.4
1238     (type= 'string '(satisfies emptyp))
1239   nil
1240   nil)
1241
1242 (deftest type=.5
1243     (type= 'string 'list)
1244   nil
1245   t)
1246
1247 ;;;; Bindings
1248
1249 (declaim (notinline opaque))
1250 (defun opaque (x)
1251   x)
1252
1253 (deftest if-let.1
1254     (if-let (x (opaque :ok))
1255             x
1256             :bad)
1257   :ok)
1258
1259 (deftest if-let.2
1260     (if-let (x (opaque nil))
1261             :bad
1262             (and (not x) :ok))
1263   :ok)
1264
1265 (deftest if-let.3
1266     (let ((x 1))
1267       (if-let ((x 2)
1268                (y x))
1269               (+ x y)
1270               :oops))
1271   3)
1272
1273 (deftest if-let.4
1274     (if-let ((x 1)
1275              (y nil))
1276             :oops
1277             (and (not y) x))
1278   1)
1279
1280 (deftest if-let.5
1281     (if-let (x)
1282             :oops
1283             (not x))
1284   t)
1285
1286 (deftest if-let.error.1
1287     (handler-case
1288         (eval '(if-let x
1289                 :oops
1290                 :oops))
1291       (type-error ()
1292         :type-error))
1293   :type-error)
1294
1295 (deftest if-let*.1
1296     (let ((x 1))
1297       (if-let* ((x 2)
1298                 (y x))
1299                (+ x y)
1300                :oops))
1301   4)
1302
1303 (deftest if-let*.2
1304     (if-let* ((x 2)
1305               (y (prog1 x (setf x nil))))
1306              :oops
1307              (and (not x) y))
1308   2)
1309
1310 (deftest if-let*.3
1311     (if-let* (x 1)
1312              x
1313              :oops)
1314   1)
1315
1316 (deftest if-let*.error.1
1317     (handler-case
1318         (eval '(if-let* x :oops :oops))
1319       (type-error ()
1320         :type-error))
1321   :type-error)
1322
1323 (deftest when-let.1
1324     (when-let (x (opaque :ok))
1325       (setf x (cons x x))
1326       x)
1327   (:ok . :ok))
1328
1329 (deftest when-let.2
1330     (when-let ((x 1)
1331                (y nil)
1332                (z 3))
1333       :oops)
1334   nil)
1335
1336 (deftest when-let.3
1337     (let ((x 1))
1338       (when-let ((x 2)
1339                  (y x))
1340         (+ x y)))
1341   3)
1342
1343 (deftest when-let.error.1
1344     (handler-case
1345         (eval '(when-let x :oops))
1346       (type-error ()
1347         :type-error))
1348   :type-error)
1349
1350 (deftest when-let*.1
1351     (let ((x 1))
1352       (when-let* ((x 2)
1353                   (y x))
1354         (+ x y)))
1355   4)
1356
1357 (deftest when-let*.2
1358     (let ((y 1))
1359       (when-let* (x y)
1360         (1+ x)))
1361   2)
1362
1363 (deftest when-let*.error.1
1364     (handler-case
1365         (eval '(when-let* x :oops))
1366       (type-error ()
1367         :type-error))
1368   :type-error)