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