tests.lisp

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