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