tests.lisp

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