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