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 #+sbcl
 917 (deftest gaussian-random.2
 918     (handler-case
 919         (sb-ext:with-timeout 2
 920           (progn
 921             (loop
 922               :repeat 10000
 923               :do (gaussian-random 0 nil))
 924             'done))
 925       (sb-ext:timeout ()
 926         'timed-out))
 927   'done)
 928
 929 (deftest iota.1
 930     (iota 3)
 931   (0 1 2))
 932
 933 (deftest iota.2
 934     (iota 3 :start 0.0d0)
 935   (0.0d0 1.0d0 2.0d0))
 936
 937 (deftest iota.3
 938     (iota 3 :start 2 :step 3.0)
 939   (2.0 5.0 8.0))
 940
 941 (deftest map-iota.1
 942     (let (all)
 943       (declare (notinline map-iota))
 944       (values (map-iota (lambda (x) (push x all))
 945                         3
 946                         :start 2
 947                         :step 1.1d0)
 948               all))
 949   3
 950   (4.2d0 3.1d0 2.0d0))
 951
 952 (deftest lerp.1
 953     (lerp 0.5 1 2)
 954   1.5)
 955
 956 (deftest lerp.2
 957     (lerp 0.1 1 2)
 958   1.1)
 959
 960 (deftest mean.1
 961     (mean '(1 2 3))
 962   2)
 963
 964 (deftest mean.2
 965     (mean '(1 2 3 4))
 966   5/2)
 967
 968 (deftest mean.3
 969     (mean '(1 2 10))
 970   13/3)
 971
 972 (deftest median.1
 973     (median '(100 0 99 1 98 2 97))
 974   97)
 975
 976 (deftest median.2
 977     (median '(100 0 99 1 98 2 97 96))
 978   193/2)
 979
 980 (deftest variance.1
 981     (variance (list 1 2 3))
 982   2/3)
 983
 984 (deftest standard-deviation.1
 985     (< 0 (standard-deviation (list 1 2 3)) 1)
 986   t)
 987
 988 (deftest maxf.1
 989     (let ((x 1))
 990       (maxf x 2)
 991       x)
 992   2)
 993
 994 (deftest maxf.2
 995     (let ((x 1))
 996       (maxf x 0)
 997       x)
 998   1)
 999
1000 (deftest maxf.3
1001     (let ((x 1)
1002           (c 0))
1003       (maxf x (incf c))
1004       (list x c))
1005   (1 1))
1006
1007 (deftest maxf.4
1008     (let ((xv (vector 0 0 0))
1009           (p 0))
1010       (maxf (svref xv (incf p)) (incf p))
1011       (list p xv))
1012   (2 #(0 2 0)))
1013
1014 (deftest minf.1
1015     (let ((y 1))
1016       (minf y 0)
1017       y)
1018   0)
1019
1020 (deftest minf.2
1021     (let ((xv (vector 10 10 10))
1022           (p 0))
1023       (minf (svref xv (incf p)) (incf p))
1024       (list p xv))
1025   (2 #(10 2 10)))
1026
1027 (deftest subfactorial.1
1028     (mapcar #'subfactorial (iota 22))
1029   (1
1030    0
1031    1
1032    2
1033    9
1034    44
1035    265
1036    1854
1037    14833
1038    133496
1039    1334961
1040    14684570
1041    176214841
1042    2290792932
1043    32071101049
1044    481066515734
1045    7697064251745
1046    130850092279664
1047    2355301661033953
1048    44750731559645106
1049    895014631192902121
1050    18795307255050944540))
1051
1052 ;;;; Arrays
1053
1054 #+nil
1055 (deftest array-index.type)
1056
1057 #+nil
1058 (deftest copy-array)
1059
1060 ;;;; Sequences
1061
1062 (deftest rotate.1
1063     (list (rotate (list 1 2 3) 0)
1064           (rotate (list 1 2 3) 1)
1065           (rotate (list 1 2 3) 2)
1066           (rotate (list 1 2 3) 3)
1067           (rotate (list 1 2 3) 4))
1068   ((1 2 3)
1069    (3 1 2)
1070    (2 3 1)
1071    (1 2 3)
1072    (3 1 2)))
1073
1074 (deftest rotate.2
1075     (list (rotate (vector 1 2 3 4) 0)
1076           (rotate (vector 1 2 3 4))
1077           (rotate (vector 1 2 3 4) 2)
1078           (rotate (vector 1 2 3 4) 3)
1079           (rotate (vector 1 2 3 4) 4)
1080           (rotate (vector 1 2 3 4) 5))
1081   (#(1 2 3 4)
1082     #(4 1 2 3)
1083     #(3 4 1 2)
1084     #(2 3 4 1)
1085     #(1 2 3 4)
1086     #(4 1 2 3)))
1087
1088 (deftest rotate.3
1089     (list (rotate (list 1 2 3) 0)
1090           (rotate (list 1 2 3) -1)
1091           (rotate (list 1 2 3) -2)
1092           (rotate (list 1 2 3) -3)
1093           (rotate (list 1 2 3) -4))
1094   ((1 2 3)
1095    (2 3 1)
1096    (3 1 2)
1097    (1 2 3)
1098    (2 3 1)))
1099
1100 (deftest rotate.4
1101     (list (rotate (vector 1 2 3 4) 0)
1102           (rotate (vector 1 2 3 4) -1)
1103           (rotate (vector 1 2 3 4) -2)
1104           (rotate (vector 1 2 3 4) -3)
1105           (rotate (vector 1 2 3 4) -4)
1106           (rotate (vector 1 2 3 4) -5))
1107   (#(1 2 3 4)
1108    #(2 3 4 1)
1109    #(3 4 1 2)
1110    #(4 1 2 3)
1111    #(1 2 3 4)
1112    #(2 3 4 1)))
1113
1114 (deftest rotate.5
1115     (values (rotate (list 1) 17)
1116             (rotate (list 1) -5))
1117   (1)
1118   (1))
1119
1120 (deftest shuffle.1
1121     (let ((s (shuffle (iota 100))))
1122       (list (equal s (iota 100))
1123             (every (lambda (x)
1124                      (member x s))
1125                    (iota 100))
1126             (every (lambda (x)
1127                      (typep x '(integer 0 99)))
1128                    s)))
1129   (nil t t))
1130
1131 (deftest shuffle.2
1132     (let ((s (shuffle (coerce (iota 100) 'vector))))
1133       (list (equal s (coerce (iota 100) 'vector))
1134             (every (lambda (x)
1135                      (find x s))
1136                    (iota 100))
1137             (every (lambda (x)
1138                      (typep x '(integer 0 99)))
1139                    s)))
1140   (nil t t))
1141
1142 (deftest shuffle.3
1143     (let* ((orig (coerce (iota 21) 'vector))
1144            (copy (copy-seq orig)))
1145       (shuffle copy :start 10 :end 15)
1146       (list (every #'eql (subseq copy 0 10) (subseq orig 0 10))
1147             (every #'eql (subseq copy 15) (subseq orig 15))))
1148   (t t))
1149
1150 (deftest random-elt.1
1151     (let ((s1 #(1 2 3 4))
1152           (s2 '(1 2 3 4)))
1153       (list (dotimes (i 1000 nil)
1154               (unless (member (random-elt s1) s2)
1155                 (return nil))
1156               (when (/= (random-elt s1) (random-elt s1))
1157                 (return t)))
1158             (dotimes (i 1000 nil)
1159               (unless (member (random-elt s2) s2)
1160                 (return nil))
1161               (when (/= (random-elt s2) (random-elt s2))
1162                 (return t)))))
1163   (t t))
1164
1165 (deftest removef.1
1166     (let* ((x '(1 2 3))
1167            (x* x)
1168            (y #(1 2 3))
1169            (y* y))
1170       (removef x 1)
1171       (removef y 3)
1172       (list x x* y y*))
1173   ((2 3)
1174    (1 2 3)
1175    #(1 2)
1176    #(1 2 3)))
1177
1178 (deftest deletef.1
1179     (let* ((x (list 1 2 3))
1180            (x* x)
1181            (y (vector 1 2 3)))
1182       (deletef x 2)
1183       (deletef y 1)
1184       (list x x* y))
1185   ((1 3)
1186    (1 3)
1187    #(2 3)))
1188
1189 (deftest map-permutations.1
1190     (let ((seq (list 1 2 3))
1191           (seen nil)
1192           (ok t))
1193       (map-permutations (lambda (s)
1194                           (unless (set-equal s seq)
1195                             (setf ok nil))
1196                           (when (member s seen :test 'equal)
1197                             (setf ok nil))
1198                           (push s seen))
1199                         seq
1200                         :copy t)
1201       (values ok (length seen)))
1202   t
1203   6)
1204
1205 (deftest proper-sequence.type.1
1206     (mapcar (lambda (x)
1207               (typep x 'proper-sequence))
1208             (list (list 1 2 3)
1209                   (vector 1 2 3)
1210                   #2a((1 2) (3 4))
1211                   (circular-list 1 2 3 4)))
1212   (t t nil nil))
1213
1214 (deftest emptyp.1
1215     (mapcar #'emptyp
1216             (list (list 1)
1217                   (circular-list 1)
1218                   nil
1219                   (vector)
1220                   (vector 1)))
1221   (nil nil t t nil))
1222
1223 (deftest sequence-of-length-p.1
1224     (mapcar #'sequence-of-length-p
1225             (list nil
1226                   #()
1227                   (list 1)
1228                   (vector 1)
1229                   (list 1 2)
1230                   (vector 1 2)
1231                   (list 1 2)
1232                   (vector 1 2)
1233                   (list 1 2)
1234                   (vector 1 2))
1235             (list 0
1236                   0
1237                   1
1238                   1
1239                   2
1240                   2
1241                   1
1242                   1
1243                   4
1244                   4))
1245   (t t t t t t nil nil nil nil))
1246
1247 (deftest length=.1
1248     (mapcar #'length=
1249             (list nil
1250                   #()
1251                   (list 1)
1252                   (vector 1)
1253                   (list 1 2)
1254                   (vector 1 2)
1255                   (list 1 2)
1256                   (vector 1 2)
1257                   (list 1 2)
1258                   (vector 1 2))
1259             (list 0
1260                   0
1261                   1
1262                   1
1263                   2
1264                   2
1265                   1
1266                   1
1267                   4
1268                   4))
1269   (t t t t t t nil nil nil nil))
1270
1271 (deftest length=.2
1272     ;; test the compiler macro
1273     (macrolet ((x (&rest args)
1274                  (funcall
1275                   (compile nil
1276                            `(lambda ()
1277                               (length= ,@args))))))
1278       (list (x 2 '(1 2))
1279             (x '(1 2) '(3 4))
1280             (x '(1 2) 2)
1281             (x '(1 2) 2 '(3 4))
1282             (x 1 2 3)))
1283   (t t t t nil))
1284
1285 (deftest copy-sequence.1
1286     (let ((l (list 1 2 3))
1287           (v (vector #\a #\b #\c)))
1288       (declare (notinline copy-sequence))
1289       (let ((l.list (copy-sequence 'list l))
1290             (l.vector (copy-sequence 'vector l))
1291             (l.spec-v (copy-sequence '(vector fixnum) l))
1292             (v.vector (copy-sequence 'vector v))
1293             (v.list (copy-sequence 'list v))
1294             (v.string (copy-sequence 'string v)))
1295         (list (member l (list l.list l.vector l.spec-v))
1296               (member v (list v.vector v.list v.string))
1297               (equal l.list l)
1298               (equalp l.vector #(1 2 3))
1299               (type= (upgraded-array-element-type 'fixnum)
1300                      (array-element-type l.spec-v))
1301               (equalp v.vector v)
1302               (equal v.list '(#\a #\b #\c))
1303               (equal "abc" v.string))))
1304   (nil nil t t t t t t))
1305
1306 (deftest first-elt.1
1307     (mapcar #'first-elt
1308             (list (list 1 2 3)
1309                   "abc"
1310                   (vector :a :b :c)))
1311   (1 #\a :a))
1312
1313 (deftest first-elt.error.1
1314     (mapcar (lambda (x)
1315               (handler-case
1316                   (first-elt x)
1317                 (type-error ()
1318                   :type-error)))
1319             (list nil
1320                   #()
1321                   12
1322                   :zot))
1323   (:type-error
1324    :type-error
1325    :type-error
1326    :type-error))
1327
1328 (deftest setf-first-elt.1
1329     (let ((l (list 1 2 3))
1330           (s (copy-seq "foobar"))
1331           (v (vector :a :b :c)))
1332       (setf (first-elt l) -1
1333             (first-elt s) #\x
1334             (first-elt v) 'zot)
1335       (values l s v))
1336   (-1 2 3)
1337   "xoobar"
1338   #(zot :b :c))
1339
1340 (deftest setf-first-elt.error.1
1341     (let ((l 'foo))
1342       (multiple-value-bind (res err)
1343           (ignore-errors (setf (first-elt l) 4))
1344         (typep err 'type-error)))
1345   t)
1346
1347 (deftest last-elt.1
1348     (mapcar #'last-elt
1349             (list (list 1 2 3)
1350                   (vector :a :b :c)
1351                   "FOOBAR"
1352                   #*001
1353                   #*010))
1354   (3 :c #\R 1 0))
1355
1356 (deftest last-elt.error.1
1357     (mapcar (lambda (x)
1358               (handler-case
1359                   (last-elt x)
1360                 (type-error ()
1361                   :type-error)))
1362             (list nil
1363                   #()
1364                   12
1365                   :zot
1366                   (circular-list 1 2 3)
1367                   (list* 1 2 3 (circular-list 4 5))))
1368   (:type-error
1369    :type-error
1370    :type-error
1371    :type-error
1372    :type-error
1373    :type-error))
1374
1375 (deftest setf-last-elt.1
1376     (let ((l (list 1 2 3))
1377           (s (copy-seq "foobar"))
1378           (b (copy-seq #*010101001)))
1379       (setf (last-elt l) '???
1380             (last-elt s) #\?
1381             (last-elt b) 0)
1382       (values l s b))
1383   (1 2 ???)
1384   "fooba?"
1385   #*010101000)
1386
1387 (deftest setf-last-elt.error.1
1388     (handler-case
1389         (setf (last-elt 'foo) 13)
1390       (type-error ()
1391         :type-error))
1392   :type-error)
1393
1394 (deftest starts-with.1
1395     (list (starts-with 1 '(1 2 3))
1396           (starts-with 1 #(1 2 3))
1397           (starts-with #\x "xyz")
1398           (starts-with 2 '(1 2 3))
1399           (starts-with 3 #(1 2 3))
1400           (starts-with 1 1)
1401           (starts-with nil nil))
1402   (t t t nil nil nil nil))
1403
1404 (deftest starts-with.2
1405     (values (starts-with 1 '(-1 2 3) :key '-)
1406             (starts-with "foo" '("foo" "bar") :test 'equal)
1407             (starts-with "f" '(#\f) :key 'string :test 'equal)
1408             (starts-with -1 '(0 1 2) :key #'1+)
1409             (starts-with "zot" '("ZOT") :test 'equal))
1410   t
1411   t
1412   t
1413   nil
1414   nil)
1415
1416 (deftest ends-with.1
1417     (list (ends-with 3 '(1 2 3))
1418           (ends-with 3 #(1 2 3))
1419           (ends-with #\z "xyz")
1420           (ends-with 2 '(1 2 3))
1421           (ends-with 1 #(1 2 3))
1422           (ends-with 1 1)
1423           (ends-with nil nil))
1424   (t t t nil nil nil nil))
1425
1426 (deftest ends-with.2
1427     (values (ends-with 2 '(0 13 1) :key '1+)
1428             (ends-with "foo" (vector "bar" "foo") :test 'equal)
1429             (ends-with "X" (vector 1 2 #\X) :key 'string :test 'equal)
1430             (ends-with "foo" "foo" :test 'equal))
1431   t
1432   t
1433   t
1434   nil)
1435
1436 (deftest ends-with.error.1
1437     (handler-case
1438         (ends-with 3 (circular-list 3 3 3 1 3 3))
1439       (type-error ()
1440         :type-error))
1441   :type-error)
1442
1443 (deftest sequences.passing-improper-lists
1444     (macrolet ((signals-error-p (form)
1445                  `(handler-case
1446                       (progn ,form nil)
1447                     (type-error (e)
1448                       t)))
1449                (cut (fn &rest args)
1450                  (with-gensyms (arg)
1451                    (print`(lambda (,arg)
1452                        (apply ,fn (list ,@(substitute arg '_ args))))))))
1453       (let ((circular-list (make-circular-list 5 :initial-element :foo))
1454             (dotted-list (list* 'a 'b 'c 'd)))
1455         (loop for nth from 0
1456               for fn in (list
1457                          (cut #'lastcar _)
1458                          (cut #'rotate _ 3)
1459                          (cut #'rotate _ -3)
1460                          (cut #'shuffle _)
1461                          (cut #'random-elt _)
1462                          (cut #'last-elt _)
1463                          (cut #'ends-with :foo _))
1464               nconcing
1465                  (let ((on-circular-p (signals-error-p (funcall fn circular-list)))
1466                        (on-dotted-p (signals-error-p (funcall fn dotted-list))))
1467                    (when (or (not on-circular-p) (not on-dotted-p))
1468                      (append
1469                       (unless on-circular-p
1470                         (let ((*print-circle* t))
1471                           (list
1472                            (format nil
1473                                    "No appropriate error signalled when passing ~S to ~Ath entry."
1474                                    circular-list nth))))
1475                       (unless on-dotted-p
1476                         (list
1477                          (format nil
1478                                  "No appropriate error signalled when passing ~S to ~Ath entry."
1479                                  dotted-list nth)))))))))
1480   nil)
1481
1482 (deftest with-unique-names.1
1483     (let ((*gensym-counter* 0))
1484       (let ((syms (with-unique-names (foo bar quux)
1485                     (list foo bar quux))))
1486         (list (find-if #'symbol-package syms)
1487               (equal '("FOO0" "BAR1" "QUUX2")
1488                      (mapcar #'symbol-name syms)))))
1489   (nil t))
1490
1491 (deftest with-unique-names.2
1492     (let ((*gensym-counter* 0))
1493       (let ((syms (with-unique-names ((foo "_foo_") (bar -bar-) (quux #\q))
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   (nil t))
1499
1500 (deftest with-unique-names.3
1501     (let ((*gensym-counter* 0))
1502       (multiple-value-bind (res err)
1503           (ignore-errors
1504             (eval
1505              '(let ((syms
1506                      (with-unique-names ((foo "_foo_") (bar -bar-) (quux 42))
1507                        (list foo bar quux))))
1508                (list (find-if #'symbol-package syms)
1509                 (equal '("_foo_0" "-BAR-1" "q2")
1510                  (mapcar #'symbol-name syms))))))
1511         (errorp err)))
1512   t)
1513
1514 (deftest once-only.1
1515     (macrolet ((cons1.good (x)
1516                  (once-only (x)
1517                    `(cons ,x ,x)))
1518                (cons1.bad (x)
1519                  `(cons ,x ,x)))
1520       (let ((y 0))
1521         (list (cons1.good (incf y))
1522               y
1523               (cons1.bad (incf y))
1524               y)))
1525   ((1 . 1) 1 (2 . 3) 3))
1526
1527 (deftest once-only.2
1528     (macrolet ((cons1 (x)
1529                  (once-only ((y x))
1530                    `(cons ,y ,y))))
1531       (let ((z 0))
1532         (list (cons1 (incf z))
1533               z
1534               (cons1 (incf z)))))
1535   ((1 . 1) 1 (2 . 2)))
1536
1537 (deftest parse-body.1
1538     (parse-body '("doc" "body") :documentation t)
1539   ("body")
1540   nil
1541   "doc")
1542
1543 (deftest parse-body.2
1544     (parse-body '("body") :documentation t)
1545   ("body")
1546   nil
1547   nil)
1548
1549 (deftest parse-body.3
1550     (parse-body '("doc" "body"))
1551   ("doc" "body")
1552   nil
1553   nil)
1554
1555 (deftest parse-body.4
1556     (parse-body '((declare (foo)) "doc" (declare (bar)) body) :documentation t)
1557   (body)
1558   ((declare (foo)) (declare (bar)))
1559   "doc")
1560
1561 (deftest parse-body.5
1562     (parse-body '((declare (foo)) "doc" (declare (bar)) body))
1563   ("doc" (declare (bar)) body)
1564   ((declare (foo)))
1565   nil)
1566
1567 (deftest parse-body.6
1568     (multiple-value-bind (res err)
1569         (ignore-errors
1570           (parse-body '("foo" "bar" "quux")
1571                       :documentation t))
1572       (errorp err))
1573   t)
1574
1575 ;;;; Symbols
1576
1577 (deftest ensure-symbol.1
1578     (ensure-symbol :cons :cl)
1579   cons
1580   :external)
1581
1582 (deftest ensure-symbol.2
1583     (ensure-symbol "CONS" :alexandria)
1584   cons
1585   :inherited)
1586
1587 (deftest ensure-symbol.3
1588     (ensure-symbol 'foo :keyword)
1589   :foo
1590   :external)
1591
1592 (deftest ensure-symbol.4
1593     (ensure-symbol #\* :alexandria)
1594   *
1595   :inherited)
1596
1597 (deftest format-symbol.1
1598     (let ((s (format-symbol nil '#:x-~d 13)))
1599       (list (symbol-package s)
1600             (string= (string '#:x-13) (symbol-name s))))
1601   (nil t))
1602
1603 (deftest format-symbol.2
1604     (format-symbol :keyword '#:sym-~a (string :bolic))
1605   :sym-bolic)
1606
1607 (deftest format-symbol.3
1608     (let ((*package* (find-package :cl)))
1609       (format-symbol t '#:find-~a (string 'package)))
1610   find-package)
1611
1612 (deftest make-keyword.1
1613     (list (make-keyword 'zot)
1614           (make-keyword "FOO")
1615           (make-keyword #\Q))
1616   (:zot :foo :q))
1617
1618 (deftest make-gensym-list.1
1619     (let ((*gensym-counter* 0))
1620       (let ((syms (make-gensym-list 3 "FOO")))
1621         (list (find-if 'symbol-package syms)
1622               (equal '("FOO0" "FOO1" "FOO2")
1623                      (mapcar 'symbol-name syms)))))
1624   (nil t))
1625
1626 (deftest make-gensym-list.2
1627     (let ((*gensym-counter* 0))
1628       (let ((syms (make-gensym-list 3)))
1629         (list (find-if 'symbol-package syms)
1630               (equal '("G0" "G1" "G2")
1631                      (mapcar 'symbol-name syms)))))
1632   (nil t))
1633
1634 ;;;; Type-system
1635
1636 (deftest of-type.1
1637     (locally
1638         (declare (notinline of-type))
1639     (let ((f (of-type 'string)))
1640       (list (funcall f "foo")
1641             (funcall f 'bar))))
1642   (t nil))
1643
1644 (deftest type=.1
1645     (type= 'string 'string)
1646   t
1647   t)
1648
1649 (deftest type=.2
1650     (type= 'list '(or null cons))
1651   t
1652   t)
1653
1654 (deftest type=.3
1655     (type= 'null '(and symbol list))
1656   t
1657   t)
1658
1659 (deftest type=.4
1660     (type= 'string '(satisfies emptyp))
1661   nil
1662   nil)
1663
1664 (deftest type=.5
1665     (type= 'string 'list)
1666   nil
1667   t)
1668
1669 (macrolet
1670     ((test (type numbers)
1671        `(deftest ,(format-symbol t '#:cdr5.~a (string type))
1672             (let ((numbers ,numbers))
1673               (values (mapcar (of-type ',(format-symbol t '#:negative-~a (string type))) numbers)
1674                       (mapcar (of-type ',(format-symbol t '#:non-positive-~a (string type))) numbers)
1675                       (mapcar (of-type ',(format-symbol t '#:non-negative-~a (string type))) numbers)
1676                       (mapcar (of-type ',(format-symbol t '#:positive-~a (string type))) numbers)))
1677           (t t t nil nil nil nil)
1678           (t t t t nil nil nil)
1679           (nil nil nil t t t t)
1680           (nil nil nil nil t t t))))
1681   (test fixnum       (list most-negative-fixnum       -42      -1     0     1     42      most-positive-fixnum))
1682   (test integer      (list (1- most-negative-fixnum)  -42      -1     0     1     42      (1+ most-positive-fixnum)))
1683   (test rational     (list (1- most-negative-fixnum)  -42/13   -1     0     1     42/13   (1+ most-positive-fixnum)))
1684   (test real         (list most-negative-long-float   -42/13   -1     0     1     42/13   most-positive-long-float))
1685   (test float        (list most-negative-short-float  -42.02   -1.0   0.0   1.0   42.02   most-positive-short-float))
1686   (test short-float  (list most-negative-short-float  -42.02s0 -1.0s0 0.0s0 1.0s0 42.02s0 most-positive-short-float))
1687   (test single-float (list most-negative-single-float -42.02f0 -1.0f0 0.0f0 1.0f0 42.02f0 most-positive-single-float))
1688   (test double-float (list most-negative-double-float -42.02d0 -1.0d0 0.0d0 1.0d0 42.02d0 most-positive-double-float))
1689   (test long-float   (list most-negative-long-float   -42.02l0 -1.0l0 0.0l0 1.0l0 42.02l0 most-positive-long-float)))
1690
1691 ;;;; Bindings
1692
1693 (declaim (notinline opaque))
1694 (defun opaque (x)
1695   x)
1696
1697 (deftest if-let.1
1698     (if-let (x (opaque :ok))
1699             x
1700             :bad)
1701   :ok)
1702
1703 (deftest if-let.2
1704     (if-let (x (opaque nil))
1705             :bad
1706             (and (not x) :ok))
1707   :ok)
1708
1709 (deftest if-let.3
1710     (let ((x 1))
1711       (if-let ((x 2)
1712                (y x))
1713               (+ x y)
1714               :oops))
1715   3)
1716
1717 (deftest if-let.4
1718     (if-let ((x 1)
1719              (y nil))
1720             :oops
1721             (and (not y) x))
1722   1)
1723
1724 (deftest if-let.5
1725     (if-let (x)
1726             :oops
1727             (not x))
1728   t)
1729
1730 (deftest if-let.error.1
1731     (handler-case
1732         (eval '(if-let x
1733                 :oops
1734                 :oops))
1735       (type-error ()
1736         :type-error))
1737   :type-error)
1738
1739 (deftest when-let.1
1740     (when-let (x (opaque :ok))
1741       (setf x (cons x x))
1742       x)
1743   (:ok . :ok))
1744
1745 (deftest when-let.2
1746     (when-let ((x 1)
1747                (y nil)
1748                (z 3))
1749       :oops)
1750   nil)
1751
1752 (deftest when-let.3
1753     (let ((x 1))
1754       (when-let ((x 2)
1755                  (y x))
1756         (+ x y)))
1757   3)
1758
1759 (deftest when-let.error.1
1760     (handler-case
1761         (eval '(when-let x :oops))
1762       (type-error ()
1763         :type-error))
1764   :type-error)
1765
1766 (deftest when-let*.1
1767     (let ((x 1))
1768       (when-let* ((x 2)
1769                   (y x))
1770         (+ x y)))
1771   4)
1772
1773 (deftest when-let*.2
1774     (let ((y 1))
1775       (when-let* (x y)
1776         (1+ x)))
1777   2)
1778
1779 (deftest when-let*.3
1780     (when-let* ((x t)
1781                 (y (consp x))
1782                 (z (error "OOPS")))
1783       t)
1784   nil)
1785
1786 (deftest when-let*.error.1
1787     (handler-case
1788         (eval '(when-let* x :oops))
1789       (type-error ()
1790         :type-error))
1791   :type-error)
1792
1793 (deftest doplist.1
1794     (let (keys values)
1795       (doplist (k v '(a 1 b 2 c 3) (values t (reverse keys) (reverse values) k v))
1796         (push k keys)
1797         (push v values)))
1798   t
1799   (a b c)
1800   (1 2 3)
1801   nil
1802   nil)
1803
1804 (deftest count-permutations.1
1805     (values (count-permutations 31 7)
1806             (count-permutations 1 1)
1807             (count-permutations 2 1)
1808             (count-permutations 2 2)
1809             (count-permutations 3 2)
1810             (count-permutations 3 1))
1811   13253058000
1812   1
1813   2
1814   2
1815   6
1816   3)
1817
1818 (deftest binomial-coefficient.1
1819     (alexandria:binomial-coefficient 1239 139)
1820   28794902202288970200771694600561826718847179309929858835480006683522184441358211423695124921058123706380656375919763349913245306834194782172712255592710204598527867804110129489943080460154)
1821
1822 (deftest copy-stream.1
1823     (let ((data "sdkfjhsakfh weior763495ewofhsdfk sdfadlkfjhsadf woif sdlkjfhslkdfh sdklfjh"))
1824       (values (equal data
1825                      (with-input-from-string (in data)
1826                        (with-output-to-string (out)
1827                          (alexandria:copy-stream in out))))
1828               (equal (subseq data 10 20)
1829                      (with-input-from-string (in data)
1830                        (with-output-to-string (out)
1831                          (alexandria:copy-stream in out :start 10 :end 20))))
1832               (equal (subseq data 10)
1833                      (with-input-from-string (in data)
1834                        (with-output-to-string (out)
1835                          (alexandria:copy-stream in out :start 10))))
1836               (equal (subseq data 0 20)
1837                      (with-input-from-string (in data)
1838                        (with-output-to-string (out)
1839                          (alexandria:copy-stream in out :end 20))))))
1840   t
1841   t
1842   t
1843   t)
1844
1845 (deftest extremum.1
1846     (let ((n 0))
1847       (dotimes (i 10)
1848        (let ((data (shuffle (coerce (iota 10000 :start i) 'vector)))
1849              (ok t))
1850          (unless (eql i (extremum data #'<))
1851            (setf ok nil))
1852          (unless (eql i (extremum (coerce data 'list) #'<))
1853            (setf ok nil))
1854          (unless (eql (+ 9999 i) (extremum data #'>))
1855            (setf ok nil))
1856          (unless (eql (+ 9999 i) (extremum (coerce  data 'list) #'>))
1857            (setf ok nil))
1858          (when ok
1859            (incf n))))
1860       (when (eql 10 (extremum #(100 1 10 1000) #'> :start 1 :end 3))
1861         (incf n))
1862       (when (eql -1000 (extremum #(100 1 10 -1000) #'> :key 'abs))
1863         (incf n))
1864       (when (eq nil (extremum "" (lambda (a b) (error "wtf? ~S, ~S" a b))))
1865         (incf n))
1866       n)
1867   13)
1868
1869 (deftest starts-with-subseq.start1
1870     (starts-with-subseq "foo" "oop" :start1 1)
1871   t
1872   nil)
1873
1874 (deftest starts-with-subseq.start2
1875     (starts-with-subseq "foo" "xfoop" :start2 1)
1876   t
1877   nil)
1878
1879 (deftest format-symbol.print-case-bound
1880     (let ((upper (intern "FOO-BAR"))
1881           (lower (intern "foo-bar"))
1882           (*print-escape* nil))
1883       (values
1884        (let ((*print-case* :downcase))
1885          (and (eq upper (format-symbol t "~A" upper))
1886                (eq lower (format-symbol t "~A" lower))))
1887        (let ((*print-case* :upcase))
1888          (and (eq upper (format-symbol t "~A" upper))
1889                (eq lower (format-symbol t "~A" lower))))
1890        (let ((*print-case* :capitalize))
1891          (and (eq upper (format-symbol t "~A" upper))
1892               (eq lower (format-symbol t "~A" lower))))))
1893   t
1894   t
1895   t)
1896
1897 (deftest iota.fp-start-and-complex-integer-step
1898     (equal '(#C(0.0 0.0) #C(0.0 2.0) #C(0.0 4.0))
1899            (iota 3 :start 0.0 :step #C(0 2)))
1900   t)
1901
1902 (deftest parse-ordinary-lambda-list.1
1903   (multiple-value-bind (req opt rest keys allowp aux keyp)
1904       (parse-ordinary-lambda-list '(a b c &optional d &key))
1905     (and (equal '(a b c) req)
1906          (equal '((d nil nil)) opt)
1907          (equal '() keys)
1908          (not allowp)
1909          (not aux)
1910          (eq t keyp))))