2047 lines
53 KiB
Common Lisp
2047 lines
53 KiB
Common Lisp
(in-package :cl-user)
|
|
|
|
(defpackage :alexandria-tests
|
|
(:use :cl :alexandria #+sbcl :sb-rt #-sbcl :rtest)
|
|
(:import-from #+sbcl :sb-rt #-sbcl :rtest
|
|
#:*compile-tests* #:*expected-failures*))
|
|
|
|
(in-package :alexandria-tests)
|
|
|
|
(defun run-tests (&key ((:compiled *compile-tests*)))
|
|
(do-tests))
|
|
|
|
(defun hash-table-test-name (name)
|
|
;; Workaround for Clisp calling EQL in a hash-table FASTHASH-EQL.
|
|
(hash-table-test (make-hash-table :test name)))
|
|
|
|
;;;; Arrays
|
|
|
|
(deftest copy-array.1
|
|
(let* ((orig (vector 1 2 3))
|
|
(copy (copy-array orig)))
|
|
(values (eq orig copy) (equalp orig copy)))
|
|
nil t)
|
|
|
|
(deftest copy-array.2
|
|
(let ((orig (make-array 1024 :fill-pointer 0)))
|
|
(vector-push-extend 1 orig)
|
|
(vector-push-extend 2 orig)
|
|
(vector-push-extend 3 orig)
|
|
(let ((copy (copy-array orig)))
|
|
(values (eq orig copy) (equalp orig copy)
|
|
(array-has-fill-pointer-p copy)
|
|
(eql (fill-pointer orig) (fill-pointer copy)))))
|
|
nil t t t)
|
|
|
|
(deftest copy-array.3
|
|
(let* ((orig (vector 1 2 3))
|
|
(copy (copy-array orig)))
|
|
(typep copy 'simple-array))
|
|
t)
|
|
|
|
(deftest copy-array.4
|
|
(let ((orig (make-array 21
|
|
:adjustable t
|
|
:fill-pointer 0)))
|
|
(dotimes (n 42)
|
|
(vector-push-extend n orig))
|
|
(let ((copy (copy-array orig
|
|
:adjustable nil
|
|
:fill-pointer nil)))
|
|
(typep copy 'simple-array)))
|
|
t)
|
|
|
|
(deftest array-index.1
|
|
(typep 0 'array-index)
|
|
t)
|
|
|
|
;;;; Conditions
|
|
|
|
(deftest unwind-protect-case.1
|
|
(let (result)
|
|
(unwind-protect-case ()
|
|
(random 10)
|
|
(:normal (push :normal result))
|
|
(:abort (push :abort result))
|
|
(:always (push :always result)))
|
|
result)
|
|
(:always :normal))
|
|
|
|
(deftest unwind-protect-case.2
|
|
(let (result)
|
|
(unwind-protect-case ()
|
|
(random 10)
|
|
(:always (push :always result))
|
|
(:normal (push :normal result))
|
|
(:abort (push :abort result)))
|
|
result)
|
|
(:normal :always))
|
|
|
|
(deftest unwind-protect-case.3
|
|
(let (result1 result2 result3)
|
|
(ignore-errors
|
|
(unwind-protect-case ()
|
|
(error "FOOF!")
|
|
(:normal (push :normal result1))
|
|
(:abort (push :abort result1))
|
|
(:always (push :always result1))))
|
|
(catch 'foof
|
|
(unwind-protect-case ()
|
|
(throw 'foof 42)
|
|
(:normal (push :normal result2))
|
|
(:abort (push :abort result2))
|
|
(:always (push :always result2))))
|
|
(block foof
|
|
(unwind-protect-case ()
|
|
(return-from foof 42)
|
|
(:normal (push :normal result3))
|
|
(:abort (push :abort result3))
|
|
(:always (push :always result3))))
|
|
(values result1 result2 result3))
|
|
(:always :abort)
|
|
(:always :abort)
|
|
(:always :abort))
|
|
|
|
(deftest unwind-protect-case.4
|
|
(let (result)
|
|
(unwind-protect-case (aborted-p)
|
|
(random 42)
|
|
(:always (setq result aborted-p)))
|
|
result)
|
|
nil)
|
|
|
|
(deftest unwind-protect-case.5
|
|
(let (result)
|
|
(block foof
|
|
(unwind-protect-case (aborted-p)
|
|
(return-from foof)
|
|
(:always (setq result aborted-p))))
|
|
result)
|
|
t)
|
|
|
|
;;;; Control flow
|
|
|
|
(deftest switch.1
|
|
(switch (13 :test =)
|
|
(12 :oops)
|
|
(13.0 :yay))
|
|
:yay)
|
|
|
|
(deftest switch.2
|
|
(switch (13)
|
|
((+ 12 2) :oops)
|
|
((- 13 1) :oops2)
|
|
(t :yay))
|
|
:yay)
|
|
|
|
(deftest eswitch.1
|
|
(let ((x 13))
|
|
(eswitch (x :test =)
|
|
(12 :oops)
|
|
(13.0 :yay)))
|
|
:yay)
|
|
|
|
(deftest eswitch.2
|
|
(let ((x 13))
|
|
(eswitch (x :key 1+)
|
|
(11 :oops)
|
|
(14 :yay)))
|
|
:yay)
|
|
|
|
(deftest cswitch.1
|
|
(cswitch (13 :test =)
|
|
(12 :oops)
|
|
(13.0 :yay))
|
|
:yay)
|
|
|
|
(deftest cswitch.2
|
|
(cswitch (13 :key 1-)
|
|
(12 :yay)
|
|
(13.0 :oops))
|
|
:yay)
|
|
|
|
(deftest multiple-value-prog2.1
|
|
(multiple-value-prog2
|
|
(values 1 1 1)
|
|
(values 2 20 200)
|
|
(values 3 3 3))
|
|
2 20 200)
|
|
|
|
(deftest nth-value-or.1
|
|
(multiple-value-bind (a b c)
|
|
(nth-value-or 1
|
|
(values 1 nil 1)
|
|
(values 2 2 2))
|
|
(= a b c 2))
|
|
t)
|
|
|
|
(deftest whichever.1
|
|
(let ((x (whichever 1 2 3)))
|
|
(and (member x '(1 2 3)) t))
|
|
t)
|
|
|
|
(deftest whichever.2
|
|
(let* ((a 1)
|
|
(b 2)
|
|
(c 3)
|
|
(x (whichever a b c)))
|
|
(and (member x '(1 2 3)) t))
|
|
t)
|
|
|
|
(deftest xor.1
|
|
(xor nil nil 1 nil)
|
|
1
|
|
t)
|
|
|
|
(deftest xor.2
|
|
(xor nil nil 1 2)
|
|
nil
|
|
nil)
|
|
|
|
(deftest xor.3
|
|
(xor nil nil nil)
|
|
nil
|
|
t)
|
|
|
|
;;;; Definitions
|
|
|
|
(deftest define-constant.1
|
|
(let ((name (gensym)))
|
|
(eval `(define-constant ,name "FOO" :test 'equal))
|
|
(eval `(define-constant ,name "FOO" :test 'equal))
|
|
(values (equal "FOO" (symbol-value name))
|
|
(constantp name)))
|
|
t
|
|
t)
|
|
|
|
(deftest define-constant.2
|
|
(let ((name (gensym)))
|
|
(eval `(define-constant ,name 13))
|
|
(eval `(define-constant ,name 13))
|
|
(values (eql 13 (symbol-value name))
|
|
(constantp name)))
|
|
t
|
|
t)
|
|
|
|
;;;; Errors
|
|
|
|
;;; TYPEP is specified to return a generalized boolean and, for
|
|
;;; example, ECL exploits this by returning the superclasses of ERROR
|
|
;;; in this case.
|
|
(defun errorp (x)
|
|
(not (null (typep x 'error))))
|
|
|
|
(deftest required-argument.1
|
|
(multiple-value-bind (res err)
|
|
(ignore-errors (required-argument))
|
|
(errorp err))
|
|
t)
|
|
|
|
;;;; Hash tables
|
|
|
|
(deftest ensure-gethash.1
|
|
(let ((table (make-hash-table))
|
|
(x (list 1)))
|
|
(multiple-value-bind (value already-there)
|
|
(ensure-gethash x table 42)
|
|
(and (= value 42)
|
|
(not already-there)
|
|
(= 42 (gethash x table))
|
|
(multiple-value-bind (value2 already-there2)
|
|
(ensure-gethash x table 13)
|
|
(and (= value2 42)
|
|
already-there2
|
|
(= 42 (gethash x table)))))))
|
|
t)
|
|
|
|
(deftest ensure-gethash.2
|
|
(let ((table (make-hash-table))
|
|
(count 0))
|
|
(multiple-value-call #'values
|
|
(ensure-gethash (progn (incf count) :foo)
|
|
(progn (incf count) table)
|
|
(progn (incf count) :bar))
|
|
(gethash :foo table)
|
|
count))
|
|
:bar nil :bar t 3)
|
|
|
|
(deftest copy-hash-table.1
|
|
(let ((orig (make-hash-table :test 'eq :size 123))
|
|
(foo "foo"))
|
|
(setf (gethash orig orig) t
|
|
(gethash foo orig) t)
|
|
(let ((eq-copy (copy-hash-table orig))
|
|
(eql-copy (copy-hash-table orig :test 'eql))
|
|
(equal-copy (copy-hash-table orig :test 'equal))
|
|
(equalp-copy (copy-hash-table orig :test 'equalp)))
|
|
(list (eql (hash-table-size eq-copy) (hash-table-size orig))
|
|
(eql (hash-table-rehash-size eq-copy)
|
|
(hash-table-rehash-size orig))
|
|
(hash-table-count eql-copy)
|
|
(gethash orig eq-copy)
|
|
(gethash (copy-seq foo) eql-copy)
|
|
(gethash foo eql-copy)
|
|
(gethash (copy-seq foo) equal-copy)
|
|
(gethash "FOO" equal-copy)
|
|
(gethash "FOO" equalp-copy))))
|
|
(t t 2 t nil t t nil t))
|
|
|
|
(deftest copy-hash-table.2
|
|
(let ((ht (make-hash-table))
|
|
(list (list :list (vector :A :B :C))))
|
|
(setf (gethash 'list ht) list)
|
|
(let* ((shallow-copy (copy-hash-table ht))
|
|
(deep1-copy (copy-hash-table ht :key 'copy-list))
|
|
(list (gethash 'list ht))
|
|
(shallow-list (gethash 'list shallow-copy))
|
|
(deep1-list (gethash 'list deep1-copy)))
|
|
(list (eq ht shallow-copy)
|
|
(eq ht deep1-copy)
|
|
(eq list shallow-list)
|
|
(eq list deep1-list) ; outer list was copied.
|
|
(eq (second list) (second shallow-list))
|
|
(eq (second list) (second deep1-list)) ; inner vector wasn't copied.
|
|
)))
|
|
(nil nil t nil t t))
|
|
|
|
(deftest maphash-keys.1
|
|
(let ((keys nil)
|
|
(table (make-hash-table)))
|
|
(declare (notinline maphash-keys))
|
|
(dotimes (i 10)
|
|
(setf (gethash i table) t))
|
|
(maphash-keys (lambda (k) (push k keys)) table)
|
|
(set-equal keys '(0 1 2 3 4 5 6 7 8 9)))
|
|
t)
|
|
|
|
(deftest maphash-values.1
|
|
(let ((vals nil)
|
|
(table (make-hash-table)))
|
|
(declare (notinline maphash-values))
|
|
(dotimes (i 10)
|
|
(setf (gethash i table) (- i)))
|
|
(maphash-values (lambda (v) (push v vals)) table)
|
|
(set-equal vals '(0 -1 -2 -3 -4 -5 -6 -7 -8 -9)))
|
|
t)
|
|
|
|
(deftest hash-table-keys.1
|
|
(let ((table (make-hash-table)))
|
|
(dotimes (i 10)
|
|
(setf (gethash i table) t))
|
|
(set-equal (hash-table-keys table) '(0 1 2 3 4 5 6 7 8 9)))
|
|
t)
|
|
|
|
(deftest hash-table-values.1
|
|
(let ((table (make-hash-table)))
|
|
(dotimes (i 10)
|
|
(setf (gethash (gensym) table) i))
|
|
(set-equal (hash-table-values table) '(0 1 2 3 4 5 6 7 8 9)))
|
|
t)
|
|
|
|
(deftest hash-table-alist.1
|
|
(let ((table (make-hash-table)))
|
|
(dotimes (i 10)
|
|
(setf (gethash i table) (- i)))
|
|
(let ((alist (hash-table-alist table)))
|
|
(list (length alist)
|
|
(assoc 0 alist)
|
|
(assoc 3 alist)
|
|
(assoc 9 alist)
|
|
(assoc nil alist))))
|
|
(10 (0 . 0) (3 . -3) (9 . -9) nil))
|
|
|
|
(deftest hash-table-plist.1
|
|
(let ((table (make-hash-table)))
|
|
(dotimes (i 10)
|
|
(setf (gethash i table) (- i)))
|
|
(let ((plist (hash-table-plist table)))
|
|
(list (length plist)
|
|
(getf plist 0)
|
|
(getf plist 2)
|
|
(getf plist 7)
|
|
(getf plist nil))))
|
|
(20 0 -2 -7 nil))
|
|
|
|
(deftest alist-hash-table.1
|
|
(let* ((alist '((0 a) (1 b) (2 c)))
|
|
(table (alist-hash-table alist)))
|
|
(list (hash-table-count table)
|
|
(gethash 0 table)
|
|
(gethash 1 table)
|
|
(gethash 2 table)
|
|
(eq (hash-table-test-name 'eql)
|
|
(hash-table-test table))))
|
|
(3 (a) (b) (c) t))
|
|
|
|
(deftest alist-hash-table.duplicate-keys
|
|
(let* ((alist '((0 a) (1 b) (0 c) (1 d) (2 e)))
|
|
(table (alist-hash-table alist)))
|
|
(list (hash-table-count table)
|
|
(gethash 0 table)
|
|
(gethash 1 table)
|
|
(gethash 2 table)))
|
|
(3 (a) (b) (e)))
|
|
|
|
(deftest plist-hash-table.1
|
|
(let* ((plist '(:a 1 :b 2 :c 3))
|
|
(table (plist-hash-table plist :test 'eq)))
|
|
(list (hash-table-count table)
|
|
(gethash :a table)
|
|
(gethash :b table)
|
|
(gethash :c table)
|
|
(gethash 2 table)
|
|
(gethash nil table)
|
|
(eq (hash-table-test-name 'eq)
|
|
(hash-table-test table))))
|
|
(3 1 2 3 nil nil t))
|
|
|
|
(deftest plist-hash-table.duplicate-keys
|
|
(let* ((plist '(:a 1 :b 2 :a 3 :b 4 :c 5))
|
|
(table (plist-hash-table plist)))
|
|
(list (hash-table-count table)
|
|
(gethash :a table)
|
|
(gethash :b table)
|
|
(gethash :c table)))
|
|
(3 1 2 5))
|
|
|
|
;;;; Functions
|
|
|
|
(deftest disjoin.1
|
|
(let ((disjunction (disjoin (lambda (x)
|
|
(and (consp x) :cons))
|
|
(lambda (x)
|
|
(and (stringp x) :string)))))
|
|
(list (funcall disjunction 'zot)
|
|
(funcall disjunction '(foo bar))
|
|
(funcall disjunction "test")))
|
|
(nil :cons :string))
|
|
|
|
(deftest disjoin.2
|
|
(let ((disjunction (disjoin #'zerop)))
|
|
(list (funcall disjunction 0)
|
|
(funcall disjunction 1)))
|
|
(t nil))
|
|
|
|
(deftest conjoin.1
|
|
(let ((conjunction (conjoin #'consp
|
|
(lambda (x)
|
|
(stringp (car x)))
|
|
(lambda (x)
|
|
(char (car x) 0)))))
|
|
(list (funcall conjunction 'zot)
|
|
(funcall conjunction '(foo))
|
|
(funcall conjunction '("foo"))))
|
|
(nil nil #\f))
|
|
|
|
(deftest conjoin.2
|
|
(let ((conjunction (conjoin #'zerop)))
|
|
(list (funcall conjunction 0)
|
|
(funcall conjunction 1)))
|
|
(t nil))
|
|
|
|
(deftest compose.1
|
|
(let ((composite (compose '1+
|
|
(lambda (x)
|
|
(* x 2))
|
|
#'read-from-string)))
|
|
(funcall composite "1"))
|
|
3)
|
|
|
|
(deftest compose.2
|
|
(let ((composite
|
|
(locally (declare (notinline compose))
|
|
(compose '1+
|
|
(lambda (x)
|
|
(* x 2))
|
|
#'read-from-string))))
|
|
(funcall composite "2"))
|
|
5)
|
|
|
|
(deftest compose.3
|
|
(let ((compose-form (funcall (compiler-macro-function 'compose)
|
|
'(compose '1+
|
|
(lambda (x)
|
|
(* x 2))
|
|
#'read-from-string)
|
|
nil)))
|
|
(let ((fun (funcall (compile nil `(lambda () ,compose-form)))))
|
|
(funcall fun "3")))
|
|
7)
|
|
|
|
(deftest compose.4
|
|
(let ((composite (compose #'zerop)))
|
|
(list (funcall composite 0)
|
|
(funcall composite 1)))
|
|
(t nil))
|
|
|
|
(deftest multiple-value-compose.1
|
|
(let ((composite (multiple-value-compose
|
|
#'truncate
|
|
(lambda (x y)
|
|
(values y x))
|
|
(lambda (x)
|
|
(with-input-from-string (s x)
|
|
(values (read s) (read s)))))))
|
|
(multiple-value-list (funcall composite "2 7")))
|
|
(3 1))
|
|
|
|
(deftest multiple-value-compose.2
|
|
(let ((composite (locally (declare (notinline multiple-value-compose))
|
|
(multiple-value-compose
|
|
#'truncate
|
|
(lambda (x y)
|
|
(values y x))
|
|
(lambda (x)
|
|
(with-input-from-string (s x)
|
|
(values (read s) (read s))))))))
|
|
(multiple-value-list (funcall composite "2 11")))
|
|
(5 1))
|
|
|
|
(deftest multiple-value-compose.3
|
|
(let ((compose-form (funcall (compiler-macro-function 'multiple-value-compose)
|
|
'(multiple-value-compose
|
|
#'truncate
|
|
(lambda (x y)
|
|
(values y x))
|
|
(lambda (x)
|
|
(with-input-from-string (s x)
|
|
(values (read s) (read s)))))
|
|
nil)))
|
|
(let ((fun (funcall (compile nil `(lambda () ,compose-form)))))
|
|
(multiple-value-list (funcall fun "2 9"))))
|
|
(4 1))
|
|
|
|
(deftest multiple-value-compose.4
|
|
(let ((composite (multiple-value-compose #'truncate)))
|
|
(multiple-value-list (funcall composite 9 2)))
|
|
(4 1))
|
|
|
|
(deftest curry.1
|
|
(let ((curried (curry '+ 3)))
|
|
(funcall curried 1 5))
|
|
9)
|
|
|
|
(deftest curry.2
|
|
(let ((curried (locally (declare (notinline curry))
|
|
(curry '* 2 3))))
|
|
(funcall curried 7))
|
|
42)
|
|
|
|
(deftest curry.3
|
|
(let ((curried-form (funcall (compiler-macro-function 'curry)
|
|
'(curry '/ 8)
|
|
nil)))
|
|
(let ((fun (funcall (compile nil `(lambda () ,curried-form)))))
|
|
(funcall fun 2)))
|
|
4)
|
|
|
|
(deftest curry.4
|
|
(let* ((x 1)
|
|
(curried (curry (progn
|
|
(incf x)
|
|
(lambda (y z) (* x y z)))
|
|
3)))
|
|
(list (funcall curried 7)
|
|
(funcall curried 7)
|
|
x))
|
|
(42 42 2))
|
|
|
|
(deftest rcurry.1
|
|
(let ((r (rcurry '/ 2)))
|
|
(funcall r 8))
|
|
4)
|
|
|
|
(deftest rcurry.2
|
|
(let* ((x 1)
|
|
(curried (rcurry (progn
|
|
(incf x)
|
|
(lambda (y z) (* x y z)))
|
|
3)))
|
|
(list (funcall curried 7)
|
|
(funcall curried 7)
|
|
x))
|
|
(42 42 2))
|
|
|
|
(deftest named-lambda.1
|
|
(let ((fac (named-lambda fac (x)
|
|
(if (> x 1)
|
|
(* x (fac (- x 1)))
|
|
x))))
|
|
(funcall fac 5))
|
|
120)
|
|
|
|
(deftest named-lambda.2
|
|
(let ((fac (named-lambda fac (&key x)
|
|
(if (> x 1)
|
|
(* x (fac :x (- x 1)))
|
|
x))))
|
|
(funcall fac :x 5))
|
|
120)
|
|
|
|
;;;; Lists
|
|
|
|
(deftest alist-plist.1
|
|
(alist-plist '((a . 1) (b . 2) (c . 3)))
|
|
(a 1 b 2 c 3))
|
|
|
|
(deftest plist-alist.1
|
|
(plist-alist '(a 1 b 2 c 3))
|
|
((a . 1) (b . 2) (c . 3)))
|
|
|
|
(deftest unionf.1
|
|
(let* ((list (list 1 2 3))
|
|
(orig list))
|
|
(unionf list (list 1 2 4))
|
|
(values (equal orig (list 1 2 3))
|
|
(eql (length list) 4)
|
|
(set-difference list (list 1 2 3 4))
|
|
(set-difference (list 1 2 3 4) list)))
|
|
t
|
|
t
|
|
nil
|
|
nil)
|
|
|
|
(deftest nunionf.1
|
|
(let ((list (list 1 2 3)))
|
|
(nunionf list (list 1 2 4))
|
|
(values (eql (length list) 4)
|
|
(set-difference (list 1 2 3 4) list)
|
|
(set-difference list (list 1 2 3 4))))
|
|
t
|
|
nil
|
|
nil)
|
|
|
|
(deftest appendf.1
|
|
(let* ((list (list 1 2 3))
|
|
(orig list))
|
|
(appendf list '(4 5 6) '(7 8))
|
|
(list list (eq list orig)))
|
|
((1 2 3 4 5 6 7 8) nil))
|
|
|
|
(deftest nconcf.1
|
|
(let ((list1 (list 1 2 3))
|
|
(list2 (list 4 5 6)))
|
|
(nconcf list1 list2 (list 7 8 9))
|
|
list1)
|
|
(1 2 3 4 5 6 7 8 9))
|
|
|
|
(deftest circular-list.1
|
|
(let ((circle (circular-list 1 2 3)))
|
|
(list (first circle)
|
|
(second circle)
|
|
(third circle)
|
|
(fourth circle)
|
|
(eq circle (nthcdr 3 circle))))
|
|
(1 2 3 1 t))
|
|
|
|
(deftest circular-list-p.1
|
|
(let* ((circle (circular-list 1 2 3 4))
|
|
(tree (list circle circle))
|
|
(dotted (cons circle t))
|
|
(proper (list 1 2 3 circle))
|
|
(tailcirc (list* 1 2 3 circle)))
|
|
(list (circular-list-p circle)
|
|
(circular-list-p tree)
|
|
(circular-list-p dotted)
|
|
(circular-list-p proper)
|
|
(circular-list-p tailcirc)))
|
|
(t nil nil nil t))
|
|
|
|
(deftest circular-list-p.2
|
|
(circular-list-p 'foo)
|
|
nil)
|
|
|
|
(deftest circular-tree-p.1
|
|
(let* ((circle (circular-list 1 2 3 4))
|
|
(tree1 (list circle circle))
|
|
(tree2 (let* ((level2 (list 1 nil 2))
|
|
(level1 (list level2)))
|
|
(setf (second level2) level1)
|
|
level1))
|
|
(dotted (cons circle t))
|
|
(proper (list 1 2 3 circle))
|
|
(tailcirc (list* 1 2 3 circle))
|
|
(quite-proper (list 1 2 3))
|
|
(quite-dotted (list 1 (cons 2 3))))
|
|
(list (circular-tree-p circle)
|
|
(circular-tree-p tree1)
|
|
(circular-tree-p tree2)
|
|
(circular-tree-p dotted)
|
|
(circular-tree-p proper)
|
|
(circular-tree-p tailcirc)
|
|
(circular-tree-p quite-proper)
|
|
(circular-tree-p quite-dotted)))
|
|
(t t t t t t nil nil))
|
|
|
|
(deftest circular-tree-p.2
|
|
(alexandria:circular-tree-p '#1=(#1#))
|
|
t)
|
|
|
|
(deftest proper-list-p.1
|
|
(let ((l1 (list 1))
|
|
(l2 (list 1 2))
|
|
(l3 (cons 1 2))
|
|
(l4 (list (cons 1 2) 3))
|
|
(l5 (circular-list 1 2)))
|
|
(list (proper-list-p l1)
|
|
(proper-list-p l2)
|
|
(proper-list-p l3)
|
|
(proper-list-p l4)
|
|
(proper-list-p l5)))
|
|
(t t nil t nil))
|
|
|
|
(deftest proper-list-p.2
|
|
(proper-list-p '(1 2 . 3))
|
|
nil)
|
|
|
|
(deftest proper-list.type.1
|
|
(let ((l1 (list 1))
|
|
(l2 (list 1 2))
|
|
(l3 (cons 1 2))
|
|
(l4 (list (cons 1 2) 3))
|
|
(l5 (circular-list 1 2)))
|
|
(list (typep l1 'proper-list)
|
|
(typep l2 'proper-list)
|
|
(typep l3 'proper-list)
|
|
(typep l4 'proper-list)
|
|
(typep l5 'proper-list)))
|
|
(t t nil t nil))
|
|
|
|
(deftest proper-list-length.1
|
|
(values
|
|
(proper-list-length nil)
|
|
(proper-list-length (list 1))
|
|
(proper-list-length (list 2 2))
|
|
(proper-list-length (list 3 3 3))
|
|
(proper-list-length (list 4 4 4 4))
|
|
(proper-list-length (list 5 5 5 5 5))
|
|
(proper-list-length (list 6 6 6 6 6 6))
|
|
(proper-list-length (list 7 7 7 7 7 7 7))
|
|
(proper-list-length (list 8 8 8 8 8 8 8 8))
|
|
(proper-list-length (list 9 9 9 9 9 9 9 9 9)))
|
|
0 1 2 3 4 5 6 7 8 9)
|
|
|
|
(deftest proper-list-length.2
|
|
(flet ((plength (x)
|
|
(handler-case
|
|
(proper-list-length x)
|
|
(type-error ()
|
|
:ok))))
|
|
(values
|
|
(plength (list* 1))
|
|
(plength (list* 2 2))
|
|
(plength (list* 3 3 3))
|
|
(plength (list* 4 4 4 4))
|
|
(plength (list* 5 5 5 5 5))
|
|
(plength (list* 6 6 6 6 6 6))
|
|
(plength (list* 7 7 7 7 7 7 7))
|
|
(plength (list* 8 8 8 8 8 8 8 8))
|
|
(plength (list* 9 9 9 9 9 9 9 9 9))))
|
|
:ok :ok :ok
|
|
:ok :ok :ok
|
|
:ok :ok :ok)
|
|
|
|
(deftest lastcar.1
|
|
(let ((l1 (list 1))
|
|
(l2 (list 1 2)))
|
|
(list (lastcar l1)
|
|
(lastcar l2)))
|
|
(1 2))
|
|
|
|
(deftest lastcar.error.2
|
|
(handler-case
|
|
(progn
|
|
(lastcar (circular-list 1 2 3))
|
|
nil)
|
|
(error ()
|
|
t))
|
|
t)
|
|
|
|
(deftest setf-lastcar.1
|
|
(let ((l (list 1 2 3 4)))
|
|
(values (lastcar l)
|
|
(progn
|
|
(setf (lastcar l) 42)
|
|
(lastcar l))))
|
|
4
|
|
42)
|
|
|
|
(deftest setf-lastcar.2
|
|
(let ((l (circular-list 1 2 3)))
|
|
(multiple-value-bind (res err)
|
|
(ignore-errors (setf (lastcar l) 4))
|
|
(typep err 'type-error)))
|
|
t)
|
|
|
|
(deftest make-circular-list.1
|
|
(let ((l (make-circular-list 3 :initial-element :x)))
|
|
(setf (car l) :y)
|
|
(list (eq l (nthcdr 3 l))
|
|
(first l)
|
|
(second l)
|
|
(third l)
|
|
(fourth l)))
|
|
(t :y :x :x :y))
|
|
|
|
(deftest circular-list.type.1
|
|
(let* ((l1 (list 1 2 3))
|
|
(l2 (circular-list 1 2 3))
|
|
(l3 (list* 1 2 3 l2)))
|
|
(list (typep l1 'circular-list)
|
|
(typep l2 'circular-list)
|
|
(typep l3 'circular-list)))
|
|
(nil t t))
|
|
|
|
(deftest ensure-list.1
|
|
(let ((x (list 1))
|
|
(y 2))
|
|
(list (ensure-list x)
|
|
(ensure-list y)))
|
|
((1) (2)))
|
|
|
|
(deftest ensure-cons.1
|
|
(let ((x (cons 1 2))
|
|
(y nil)
|
|
(z "foo"))
|
|
(values (ensure-cons x)
|
|
(ensure-cons y)
|
|
(ensure-cons z)))
|
|
(1 . 2)
|
|
(nil)
|
|
("foo"))
|
|
|
|
(deftest setp.1
|
|
(setp '(1))
|
|
t)
|
|
|
|
(deftest setp.2
|
|
(setp nil)
|
|
t)
|
|
|
|
(deftest setp.3
|
|
(setp "foo")
|
|
nil)
|
|
|
|
(deftest setp.4
|
|
(setp '(1 2 3 1))
|
|
nil)
|
|
|
|
(deftest setp.5
|
|
(setp '(1 2 3))
|
|
t)
|
|
|
|
(deftest setp.6
|
|
(setp '(a :a))
|
|
t)
|
|
|
|
(deftest setp.7
|
|
(setp '(a :a) :key 'character)
|
|
nil)
|
|
|
|
(deftest setp.8
|
|
(setp '(a :a) :key 'character :test (constantly nil))
|
|
t)
|
|
|
|
(deftest set-equal.1
|
|
(set-equal '(1 2 3) '(3 1 2))
|
|
t)
|
|
|
|
(deftest set-equal.2
|
|
(set-equal '("Xa") '("Xb")
|
|
:test (lambda (a b) (eql (char a 0) (char b 0))))
|
|
t)
|
|
|
|
(deftest set-equal.3
|
|
(set-equal '(1 2) '(4 2))
|
|
nil)
|
|
|
|
(deftest set-equal.4
|
|
(set-equal '(a b c) '(:a :b :c) :key 'string :test 'equal)
|
|
t)
|
|
|
|
(deftest set-equal.5
|
|
(set-equal '(a d c) '(:a :b :c) :key 'string :test 'equal)
|
|
nil)
|
|
|
|
(deftest set-equal.6
|
|
(set-equal '(a b c) '(a b c d))
|
|
nil)
|
|
|
|
(deftest map-product.1
|
|
(map-product 'cons '(2 3) '(1 4))
|
|
((2 . 1) (2 . 4) (3 . 1) (3 . 4)))
|
|
|
|
(deftest map-product.2
|
|
(map-product #'cons '(2 3) '(1 4))
|
|
((2 . 1) (2 . 4) (3 . 1) (3 . 4)))
|
|
|
|
(deftest flatten.1
|
|
(flatten '((1) 2 (((3 4))) ((((5)) 6)) 7))
|
|
(1 2 3 4 5 6 7))
|
|
|
|
(deftest remove-from-plist.1
|
|
(let ((orig '(a 1 b 2 c 3 d 4)))
|
|
(list (remove-from-plist orig 'a 'c)
|
|
(remove-from-plist orig 'b 'd)
|
|
(remove-from-plist orig 'b)
|
|
(remove-from-plist orig 'a)
|
|
(remove-from-plist orig 'd 42 "zot")
|
|
(remove-from-plist orig 'a 'b 'c 'd)
|
|
(remove-from-plist orig 'a 'b 'c 'd 'x)
|
|
(equal orig '(a 1 b 2 c 3 d 4))))
|
|
((b 2 d 4)
|
|
(a 1 c 3)
|
|
(a 1 c 3 d 4)
|
|
(b 2 c 3 d 4)
|
|
(a 1 b 2 c 3)
|
|
nil
|
|
nil
|
|
t))
|
|
|
|
(deftest delete-from-plist.1
|
|
(let ((orig '(a 1 b 2 c 3 d 4 d 5)))
|
|
(list (delete-from-plist (copy-list orig) 'a 'c)
|
|
(delete-from-plist (copy-list orig) 'b 'd)
|
|
(delete-from-plist (copy-list orig) 'b)
|
|
(delete-from-plist (copy-list orig) 'a)
|
|
(delete-from-plist (copy-list orig) 'd 42 "zot")
|
|
(delete-from-plist (copy-list orig) 'a 'b 'c 'd)
|
|
(delete-from-plist (copy-list orig) 'a 'b 'c 'd 'x)
|
|
(equal orig (delete-from-plist orig))
|
|
(eq orig (delete-from-plist orig))))
|
|
((b 2 d 4 d 5)
|
|
(a 1 c 3)
|
|
(a 1 c 3 d 4 d 5)
|
|
(b 2 c 3 d 4 d 5)
|
|
(a 1 b 2 c 3)
|
|
nil
|
|
nil
|
|
t
|
|
t))
|
|
|
|
(deftest mappend.1
|
|
(mappend (compose 'list '*) '(1 2 3) '(1 2 3))
|
|
(1 4 9))
|
|
|
|
(deftest assoc-value.1
|
|
(let ((key1 '(complex key))
|
|
(key2 'simple-key)
|
|
(alist '())
|
|
(result '()))
|
|
(push 1 (assoc-value alist key1 :test #'equal))
|
|
(push 2 (assoc-value alist key1 :test 'equal))
|
|
(push 42 (assoc-value alist key2))
|
|
(push 43 (assoc-value alist key2 :test 'eq))
|
|
(push (assoc-value alist key1 :test #'equal) result)
|
|
(push (assoc-value alist key2) result)
|
|
|
|
(push 'very (rassoc-value alist (list 2 1) :test #'equal))
|
|
(push (cdr (assoc '(very complex key) alist :test #'equal)) result)
|
|
result)
|
|
((2 1) (43 42) (2 1)))
|
|
|
|
;;;; Numbers
|
|
|
|
(deftest clamp.1
|
|
(list (clamp 1.5 1 2)
|
|
(clamp 2.0 1 2)
|
|
(clamp 1.0 1 2)
|
|
(clamp 3 1 2)
|
|
(clamp 0 1 2))
|
|
(1.5 2.0 1.0 2 1))
|
|
|
|
(deftest gaussian-random.1
|
|
(let ((min -0.2)
|
|
(max +0.2))
|
|
(multiple-value-bind (g1 g2)
|
|
(gaussian-random min max)
|
|
(values (<= min g1 max)
|
|
(<= min g2 max)
|
|
(/= g1 g2) ;uh
|
|
)))
|
|
t
|
|
t
|
|
t)
|
|
|
|
#+sbcl
|
|
(deftest gaussian-random.2
|
|
(handler-case
|
|
(sb-ext:with-timeout 2
|
|
(progn
|
|
(loop
|
|
:repeat 10000
|
|
:do (gaussian-random 0 nil))
|
|
'done))
|
|
(sb-ext:timeout ()
|
|
'timed-out))
|
|
done)
|
|
|
|
(deftest iota.1
|
|
(iota 3)
|
|
(0 1 2))
|
|
|
|
(deftest iota.2
|
|
(iota 3 :start 0.0d0)
|
|
(0.0d0 1.0d0 2.0d0))
|
|
|
|
(deftest iota.3
|
|
(iota 3 :start 2 :step 3.0)
|
|
(2.0 5.0 8.0))
|
|
|
|
(deftest map-iota.1
|
|
(let (all)
|
|
(declare (notinline map-iota))
|
|
(values (map-iota (lambda (x) (push x all))
|
|
3
|
|
:start 2
|
|
:step 1.1d0)
|
|
all))
|
|
3
|
|
(4.2d0 3.1d0 2.0d0))
|
|
|
|
(deftest lerp.1
|
|
(lerp 0.5 1 2)
|
|
1.5)
|
|
|
|
(deftest lerp.2
|
|
(lerp 0.1 1 2)
|
|
1.1)
|
|
|
|
(deftest lerp.3
|
|
(lerp 0.1 4 25)
|
|
6.1)
|
|
|
|
(deftest mean.1
|
|
(mean '(1 2 3))
|
|
2)
|
|
|
|
(deftest mean.2
|
|
(mean '(1 2 3 4))
|
|
5/2)
|
|
|
|
(deftest mean.3
|
|
(mean '(1 2 10))
|
|
13/3)
|
|
|
|
(deftest median.1
|
|
(median '(100 0 99 1 98 2 97))
|
|
97)
|
|
|
|
(deftest median.2
|
|
(median '(100 0 99 1 98 2 97 96))
|
|
193/2)
|
|
|
|
(deftest variance.1
|
|
(variance (list 1 2 3))
|
|
2/3)
|
|
|
|
(deftest standard-deviation.1
|
|
(< 0 (standard-deviation (list 1 2 3)) 1)
|
|
t)
|
|
|
|
(deftest maxf.1
|
|
(let ((x 1))
|
|
(maxf x 2)
|
|
x)
|
|
2)
|
|
|
|
(deftest maxf.2
|
|
(let ((x 1))
|
|
(maxf x 0)
|
|
x)
|
|
1)
|
|
|
|
(deftest maxf.3
|
|
(let ((x 1)
|
|
(c 0))
|
|
(maxf x (incf c))
|
|
(list x c))
|
|
(1 1))
|
|
|
|
(deftest maxf.4
|
|
(let ((xv (vector 0 0 0))
|
|
(p 0))
|
|
(maxf (svref xv (incf p)) (incf p))
|
|
(list p xv))
|
|
(2 #(0 2 0)))
|
|
|
|
(deftest minf.1
|
|
(let ((y 1))
|
|
(minf y 0)
|
|
y)
|
|
0)
|
|
|
|
(deftest minf.2
|
|
(let ((xv (vector 10 10 10))
|
|
(p 0))
|
|
(minf (svref xv (incf p)) (incf p))
|
|
(list p xv))
|
|
(2 #(10 2 10)))
|
|
|
|
(deftest subfactorial.1
|
|
(mapcar #'subfactorial (iota 22))
|
|
(1
|
|
0
|
|
1
|
|
2
|
|
9
|
|
44
|
|
265
|
|
1854
|
|
14833
|
|
133496
|
|
1334961
|
|
14684570
|
|
176214841
|
|
2290792932
|
|
32071101049
|
|
481066515734
|
|
7697064251745
|
|
130850092279664
|
|
2355301661033953
|
|
44750731559645106
|
|
895014631192902121
|
|
18795307255050944540))
|
|
|
|
;;;; Arrays
|
|
|
|
#+nil
|
|
(deftest array-index.type)
|
|
|
|
#+nil
|
|
(deftest copy-array)
|
|
|
|
;;;; Sequences
|
|
|
|
(deftest rotate.1
|
|
(list (rotate (list 1 2 3) 0)
|
|
(rotate (list 1 2 3) 1)
|
|
(rotate (list 1 2 3) 2)
|
|
(rotate (list 1 2 3) 3)
|
|
(rotate (list 1 2 3) 4))
|
|
((1 2 3)
|
|
(3 1 2)
|
|
(2 3 1)
|
|
(1 2 3)
|
|
(3 1 2)))
|
|
|
|
(deftest rotate.2
|
|
(list (rotate (vector 1 2 3 4) 0)
|
|
(rotate (vector 1 2 3 4))
|
|
(rotate (vector 1 2 3 4) 2)
|
|
(rotate (vector 1 2 3 4) 3)
|
|
(rotate (vector 1 2 3 4) 4)
|
|
(rotate (vector 1 2 3 4) 5))
|
|
(#(1 2 3 4)
|
|
#(4 1 2 3)
|
|
#(3 4 1 2)
|
|
#(2 3 4 1)
|
|
#(1 2 3 4)
|
|
#(4 1 2 3)))
|
|
|
|
(deftest rotate.3
|
|
(list (rotate (list 1 2 3) 0)
|
|
(rotate (list 1 2 3) -1)
|
|
(rotate (list 1 2 3) -2)
|
|
(rotate (list 1 2 3) -3)
|
|
(rotate (list 1 2 3) -4))
|
|
((1 2 3)
|
|
(2 3 1)
|
|
(3 1 2)
|
|
(1 2 3)
|
|
(2 3 1)))
|
|
|
|
(deftest rotate.4
|
|
(list (rotate (vector 1 2 3 4) 0)
|
|
(rotate (vector 1 2 3 4) -1)
|
|
(rotate (vector 1 2 3 4) -2)
|
|
(rotate (vector 1 2 3 4) -3)
|
|
(rotate (vector 1 2 3 4) -4)
|
|
(rotate (vector 1 2 3 4) -5))
|
|
(#(1 2 3 4)
|
|
#(2 3 4 1)
|
|
#(3 4 1 2)
|
|
#(4 1 2 3)
|
|
#(1 2 3 4)
|
|
#(2 3 4 1)))
|
|
|
|
(deftest rotate.5
|
|
(values (rotate (list 1) 17)
|
|
(rotate (list 1) -5))
|
|
(1)
|
|
(1))
|
|
|
|
(deftest shuffle.1
|
|
(let ((s (shuffle (iota 100))))
|
|
(list (equal s (iota 100))
|
|
(every (lambda (x)
|
|
(member x s))
|
|
(iota 100))
|
|
(every (lambda (x)
|
|
(typep x '(integer 0 99)))
|
|
s)))
|
|
(nil t t))
|
|
|
|
(deftest shuffle.2
|
|
(let ((s (shuffle (coerce (iota 100) 'vector))))
|
|
(list (equal s (coerce (iota 100) 'vector))
|
|
(every (lambda (x)
|
|
(find x s))
|
|
(iota 100))
|
|
(every (lambda (x)
|
|
(typep x '(integer 0 99)))
|
|
s)))
|
|
(nil t t))
|
|
|
|
(deftest shuffle.3
|
|
(let* ((orig (coerce (iota 21) 'vector))
|
|
(copy (copy-seq orig)))
|
|
(shuffle copy :start 10 :end 15)
|
|
(list (every #'eql (subseq copy 0 10) (subseq orig 0 10))
|
|
(every #'eql (subseq copy 15) (subseq orig 15))))
|
|
(t t))
|
|
|
|
(deftest random-elt.1
|
|
(let ((s1 #(1 2 3 4))
|
|
(s2 '(1 2 3 4)))
|
|
(list (dotimes (i 1000 nil)
|
|
(unless (member (random-elt s1) s2)
|
|
(return nil))
|
|
(when (/= (random-elt s1) (random-elt s1))
|
|
(return t)))
|
|
(dotimes (i 1000 nil)
|
|
(unless (member (random-elt s2) s2)
|
|
(return nil))
|
|
(when (/= (random-elt s2) (random-elt s2))
|
|
(return t)))))
|
|
(t t))
|
|
|
|
(deftest removef.1
|
|
(let* ((x '(1 2 3))
|
|
(x* x)
|
|
(y #(1 2 3))
|
|
(y* y))
|
|
(removef x 1)
|
|
(removef y 3)
|
|
(list x x* y y*))
|
|
((2 3)
|
|
(1 2 3)
|
|
#(1 2)
|
|
#(1 2 3)))
|
|
|
|
(deftest deletef.1
|
|
(let* ((x (list 1 2 3))
|
|
(x* x)
|
|
(y (vector 1 2 3)))
|
|
(deletef x 2)
|
|
(deletef y 1)
|
|
(list x x* y))
|
|
((1 3)
|
|
(1 3)
|
|
#(2 3)))
|
|
|
|
(deftest map-permutations.1
|
|
(let ((seq (list 1 2 3))
|
|
(seen nil)
|
|
(ok t))
|
|
(map-permutations (lambda (s)
|
|
(unless (set-equal s seq)
|
|
(setf ok nil))
|
|
(when (member s seen :test 'equal)
|
|
(setf ok nil))
|
|
(push s seen))
|
|
seq
|
|
:copy t)
|
|
(values ok (length seen)))
|
|
t
|
|
6)
|
|
|
|
(deftest proper-sequence.type.1
|
|
(mapcar (lambda (x)
|
|
(typep x 'proper-sequence))
|
|
(list (list 1 2 3)
|
|
(vector 1 2 3)
|
|
#2a((1 2) (3 4))
|
|
(circular-list 1 2 3 4)))
|
|
(t t nil nil))
|
|
|
|
(deftest emptyp.1
|
|
(mapcar #'emptyp
|
|
(list (list 1)
|
|
(circular-list 1)
|
|
nil
|
|
(vector)
|
|
(vector 1)))
|
|
(nil nil t t nil))
|
|
|
|
(deftest sequence-of-length-p.1
|
|
(mapcar #'sequence-of-length-p
|
|
(list nil
|
|
#()
|
|
(list 1)
|
|
(vector 1)
|
|
(list 1 2)
|
|
(vector 1 2)
|
|
(list 1 2)
|
|
(vector 1 2)
|
|
(list 1 2)
|
|
(vector 1 2))
|
|
(list 0
|
|
0
|
|
1
|
|
1
|
|
2
|
|
2
|
|
1
|
|
1
|
|
4
|
|
4))
|
|
(t t t t t t nil nil nil nil))
|
|
|
|
(deftest length=.1
|
|
(mapcar #'length=
|
|
(list nil
|
|
#()
|
|
(list 1)
|
|
(vector 1)
|
|
(list 1 2)
|
|
(vector 1 2)
|
|
(list 1 2)
|
|
(vector 1 2)
|
|
(list 1 2)
|
|
(vector 1 2))
|
|
(list 0
|
|
0
|
|
1
|
|
1
|
|
2
|
|
2
|
|
1
|
|
1
|
|
4
|
|
4))
|
|
(t t t t t t nil nil nil nil))
|
|
|
|
(deftest length=.2
|
|
;; test the compiler macro
|
|
(macrolet ((x (&rest args)
|
|
(funcall
|
|
(compile nil
|
|
`(lambda ()
|
|
(length= ,@args))))))
|
|
(list (x 2 '(1 2))
|
|
(x '(1 2) '(3 4))
|
|
(x '(1 2) 2)
|
|
(x '(1 2) 2 '(3 4))
|
|
(x 1 2 3)))
|
|
(t t t t nil))
|
|
|
|
(deftest copy-sequence.1
|
|
(let ((l (list 1 2 3))
|
|
(v (vector #\a #\b #\c)))
|
|
(declare (notinline copy-sequence))
|
|
(let ((l.list (copy-sequence 'list l))
|
|
(l.vector (copy-sequence 'vector l))
|
|
(l.spec-v (copy-sequence '(vector fixnum) l))
|
|
(v.vector (copy-sequence 'vector v))
|
|
(v.list (copy-sequence 'list v))
|
|
(v.string (copy-sequence 'string v)))
|
|
(list (member l (list l.list l.vector l.spec-v))
|
|
(member v (list v.vector v.list v.string))
|
|
(equal l.list l)
|
|
(equalp l.vector #(1 2 3))
|
|
(type= (upgraded-array-element-type 'fixnum)
|
|
(array-element-type l.spec-v))
|
|
(equalp v.vector v)
|
|
(equal v.list '(#\a #\b #\c))
|
|
(equal "abc" v.string))))
|
|
(nil nil t t t t t t))
|
|
|
|
(deftest first-elt.1
|
|
(mapcar #'first-elt
|
|
(list (list 1 2 3)
|
|
"abc"
|
|
(vector :a :b :c)))
|
|
(1 #\a :a))
|
|
|
|
(deftest first-elt.error.1
|
|
(mapcar (lambda (x)
|
|
(handler-case
|
|
(first-elt x)
|
|
(type-error ()
|
|
:type-error)))
|
|
(list nil
|
|
#()
|
|
12
|
|
:zot))
|
|
(:type-error
|
|
:type-error
|
|
:type-error
|
|
:type-error))
|
|
|
|
(deftest setf-first-elt.1
|
|
(let ((l (list 1 2 3))
|
|
(s (copy-seq "foobar"))
|
|
(v (vector :a :b :c)))
|
|
(setf (first-elt l) -1
|
|
(first-elt s) #\x
|
|
(first-elt v) 'zot)
|
|
(values l s v))
|
|
(-1 2 3)
|
|
"xoobar"
|
|
#(zot :b :c))
|
|
|
|
(deftest setf-first-elt.error.1
|
|
(let ((l 'foo))
|
|
(multiple-value-bind (res err)
|
|
(ignore-errors (setf (first-elt l) 4))
|
|
(typep err 'type-error)))
|
|
t)
|
|
|
|
(deftest last-elt.1
|
|
(mapcar #'last-elt
|
|
(list (list 1 2 3)
|
|
(vector :a :b :c)
|
|
"FOOBAR"
|
|
#*001
|
|
#*010))
|
|
(3 :c #\R 1 0))
|
|
|
|
(deftest last-elt.error.1
|
|
(mapcar (lambda (x)
|
|
(handler-case
|
|
(last-elt x)
|
|
(type-error ()
|
|
:type-error)))
|
|
(list nil
|
|
#()
|
|
12
|
|
:zot
|
|
(circular-list 1 2 3)
|
|
(list* 1 2 3 (circular-list 4 5))))
|
|
(:type-error
|
|
:type-error
|
|
:type-error
|
|
:type-error
|
|
:type-error
|
|
:type-error))
|
|
|
|
(deftest setf-last-elt.1
|
|
(let ((l (list 1 2 3))
|
|
(s (copy-seq "foobar"))
|
|
(b (copy-seq #*010101001)))
|
|
(setf (last-elt l) '???
|
|
(last-elt s) #\?
|
|
(last-elt b) 0)
|
|
(values l s b))
|
|
(1 2 ???)
|
|
"fooba?"
|
|
#*010101000)
|
|
|
|
(deftest setf-last-elt.error.1
|
|
(handler-case
|
|
(setf (last-elt 'foo) 13)
|
|
(type-error ()
|
|
:type-error))
|
|
:type-error)
|
|
|
|
(deftest starts-with.1
|
|
(list (starts-with 1 '(1 2 3))
|
|
(starts-with 1 #(1 2 3))
|
|
(starts-with #\x "xyz")
|
|
(starts-with 2 '(1 2 3))
|
|
(starts-with 3 #(1 2 3))
|
|
(starts-with 1 1)
|
|
(starts-with nil nil))
|
|
(t t t nil nil nil nil))
|
|
|
|
(deftest starts-with.2
|
|
(values (starts-with 1 '(-1 2 3) :key '-)
|
|
(starts-with "foo" '("foo" "bar") :test 'equal)
|
|
(starts-with "f" '(#\f) :key 'string :test 'equal)
|
|
(starts-with -1 '(0 1 2) :key #'1+)
|
|
(starts-with "zot" '("ZOT") :test 'equal))
|
|
t
|
|
t
|
|
t
|
|
nil
|
|
nil)
|
|
|
|
(deftest ends-with.1
|
|
(list (ends-with 3 '(1 2 3))
|
|
(ends-with 3 #(1 2 3))
|
|
(ends-with #\z "xyz")
|
|
(ends-with 2 '(1 2 3))
|
|
(ends-with 1 #(1 2 3))
|
|
(ends-with 1 1)
|
|
(ends-with nil nil))
|
|
(t t t nil nil nil nil))
|
|
|
|
(deftest ends-with.2
|
|
(values (ends-with 2 '(0 13 1) :key '1+)
|
|
(ends-with "foo" (vector "bar" "foo") :test 'equal)
|
|
(ends-with "X" (vector 1 2 #\X) :key 'string :test 'equal)
|
|
(ends-with "foo" "foo" :test 'equal))
|
|
t
|
|
t
|
|
t
|
|
nil)
|
|
|
|
(deftest ends-with.error.1
|
|
(handler-case
|
|
(ends-with 3 (circular-list 3 3 3 1 3 3))
|
|
(type-error ()
|
|
:type-error))
|
|
:type-error)
|
|
|
|
(deftest sequences.passing-improper-lists
|
|
(macrolet ((signals-error-p (form)
|
|
`(handler-case
|
|
(progn ,form nil)
|
|
(type-error (e)
|
|
t)))
|
|
(cut (fn &rest args)
|
|
(with-gensyms (arg)
|
|
(print`(lambda (,arg)
|
|
(apply ,fn (list ,@(substitute arg '_ args))))))))
|
|
(let ((circular-list (make-circular-list 5 :initial-element :foo))
|
|
(dotted-list (list* 'a 'b 'c 'd)))
|
|
(loop for nth from 0
|
|
for fn in (list
|
|
(cut #'lastcar _)
|
|
(cut #'rotate _ 3)
|
|
(cut #'rotate _ -3)
|
|
(cut #'shuffle _)
|
|
(cut #'random-elt _)
|
|
(cut #'last-elt _)
|
|
(cut #'ends-with :foo _))
|
|
nconcing
|
|
(let ((on-circular-p (signals-error-p (funcall fn circular-list)))
|
|
(on-dotted-p (signals-error-p (funcall fn dotted-list))))
|
|
(when (or (not on-circular-p) (not on-dotted-p))
|
|
(append
|
|
(unless on-circular-p
|
|
(let ((*print-circle* t))
|
|
(list
|
|
(format nil
|
|
"No appropriate error signalled when passing ~S to ~Ath entry."
|
|
circular-list nth))))
|
|
(unless on-dotted-p
|
|
(list
|
|
(format nil
|
|
"No appropriate error signalled when passing ~S to ~Ath entry."
|
|
dotted-list nth)))))))))
|
|
nil)
|
|
|
|
;;;; IO
|
|
|
|
(deftest read-stream-content-into-string.1
|
|
(values (with-input-from-string (stream "foo bar")
|
|
(read-stream-content-into-string stream))
|
|
(with-input-from-string (stream "foo bar")
|
|
(read-stream-content-into-string stream :buffer-size 1))
|
|
(with-input-from-string (stream "foo bar")
|
|
(read-stream-content-into-string stream :buffer-size 6))
|
|
(with-input-from-string (stream "foo bar")
|
|
(read-stream-content-into-string stream :buffer-size 7)))
|
|
"foo bar"
|
|
"foo bar"
|
|
"foo bar"
|
|
"foo bar")
|
|
|
|
(deftest read-stream-content-into-string.2
|
|
(handler-case
|
|
(let ((stream (make-broadcast-stream)))
|
|
(read-stream-content-into-string stream :buffer-size 0))
|
|
(type-error ()
|
|
:type-error))
|
|
:type-error)
|
|
|
|
#+(or)
|
|
(defvar *octets*
|
|
(map '(simple-array (unsigned-byte 8) (7)) #'char-code "foo bar"))
|
|
|
|
#+(or)
|
|
(deftest read-stream-content-into-byte-vector.1
|
|
(values (with-input-from-byte-vector (stream *octets*)
|
|
(read-stream-content-into-byte-vector stream))
|
|
(with-input-from-byte-vector (stream *octets*)
|
|
(read-stream-content-into-byte-vector stream :initial-size 1))
|
|
(with-input-from-byte-vector (stream *octets*)
|
|
(read-stream-content-into-byte-vector stream 'alexandria::%length 6))
|
|
(with-input-from-byte-vector (stream *octets*)
|
|
(read-stream-content-into-byte-vector stream 'alexandria::%length 3)))
|
|
*octets*
|
|
*octets*
|
|
*octets*
|
|
(subseq *octets* 0 3))
|
|
|
|
(deftest read-stream-content-into-byte-vector.2
|
|
(handler-case
|
|
(let ((stream (make-broadcast-stream)))
|
|
(read-stream-content-into-byte-vector stream :initial-size 0))
|
|
(type-error ()
|
|
:type-error))
|
|
:type-error)
|
|
|
|
;;;; Macros
|
|
|
|
(deftest with-unique-names.1
|
|
(let ((*gensym-counter* 0))
|
|
(let ((syms (with-unique-names (foo bar quux)
|
|
(list foo bar quux))))
|
|
(list (find-if #'symbol-package syms)
|
|
(equal '("FOO0" "BAR1" "QUUX2")
|
|
(mapcar #'symbol-name syms)))))
|
|
(nil t))
|
|
|
|
(deftest with-unique-names.2
|
|
(let ((*gensym-counter* 0))
|
|
(let ((syms (with-unique-names ((foo "_foo_") (bar -bar-) (quux #\q))
|
|
(list foo bar quux))))
|
|
(list (find-if #'symbol-package syms)
|
|
(equal '("_foo_0" "-BAR-1" "q2")
|
|
(mapcar #'symbol-name syms)))))
|
|
(nil t))
|
|
|
|
(deftest with-unique-names.3
|
|
(let ((*gensym-counter* 0))
|
|
(multiple-value-bind (res err)
|
|
(ignore-errors
|
|
(eval
|
|
'(let ((syms
|
|
(with-unique-names ((foo "_foo_") (bar -bar-) (quux 42))
|
|
(list foo bar quux))))
|
|
(list (find-if #'symbol-package syms)
|
|
(equal '("_foo_0" "-BAR-1" "q2")
|
|
(mapcar #'symbol-name syms))))))
|
|
(errorp err)))
|
|
t)
|
|
|
|
(deftest once-only.1
|
|
(macrolet ((cons1.good (x)
|
|
(once-only (x)
|
|
`(cons ,x ,x)))
|
|
(cons1.bad (x)
|
|
`(cons ,x ,x)))
|
|
(let ((y 0))
|
|
(list (cons1.good (incf y))
|
|
y
|
|
(cons1.bad (incf y))
|
|
y)))
|
|
((1 . 1) 1 (2 . 3) 3))
|
|
|
|
(deftest once-only.2
|
|
(macrolet ((cons1 (x)
|
|
(once-only ((y x))
|
|
`(cons ,y ,y))))
|
|
(let ((z 0))
|
|
(list (cons1 (incf z))
|
|
z
|
|
(cons1 (incf z)))))
|
|
((1 . 1) 1 (2 . 2)))
|
|
|
|
(deftest parse-body.1
|
|
(parse-body '("doc" "body") :documentation t)
|
|
("body")
|
|
nil
|
|
"doc")
|
|
|
|
(deftest parse-body.2
|
|
(parse-body '("body") :documentation t)
|
|
("body")
|
|
nil
|
|
nil)
|
|
|
|
(deftest parse-body.3
|
|
(parse-body '("doc" "body"))
|
|
("doc" "body")
|
|
nil
|
|
nil)
|
|
|
|
(deftest parse-body.4
|
|
(parse-body '((declare (foo)) "doc" (declare (bar)) body) :documentation t)
|
|
(body)
|
|
((declare (foo)) (declare (bar)))
|
|
"doc")
|
|
|
|
(deftest parse-body.5
|
|
(parse-body '((declare (foo)) "doc" (declare (bar)) body))
|
|
("doc" (declare (bar)) body)
|
|
((declare (foo)))
|
|
nil)
|
|
|
|
(deftest parse-body.6
|
|
(multiple-value-bind (res err)
|
|
(ignore-errors
|
|
(parse-body '("foo" "bar" "quux")
|
|
:documentation t))
|
|
(errorp err))
|
|
t)
|
|
|
|
;;;; Symbols
|
|
|
|
(deftest ensure-symbol.1
|
|
(ensure-symbol :cons :cl)
|
|
cons
|
|
:external)
|
|
|
|
(deftest ensure-symbol.2
|
|
(ensure-symbol "CONS" :alexandria)
|
|
cons
|
|
:inherited)
|
|
|
|
(deftest ensure-symbol.3
|
|
(ensure-symbol 'foo :keyword)
|
|
:foo
|
|
:external)
|
|
|
|
(deftest ensure-symbol.4
|
|
(ensure-symbol #\* :alexandria)
|
|
*
|
|
:inherited)
|
|
|
|
(deftest format-symbol.1
|
|
(let ((s (format-symbol nil '#:x-~d 13)))
|
|
(list (symbol-package s)
|
|
(string= (string '#:x-13) (symbol-name s))))
|
|
(nil t))
|
|
|
|
(deftest format-symbol.2
|
|
(format-symbol :keyword '#:sym-~a (string :bolic))
|
|
:sym-bolic)
|
|
|
|
(deftest format-symbol.3
|
|
(let ((*package* (find-package :cl)))
|
|
(format-symbol t '#:find-~a (string 'package)))
|
|
find-package)
|
|
|
|
(deftest make-keyword.1
|
|
(list (make-keyword 'zot)
|
|
(make-keyword "FOO")
|
|
(make-keyword #\Q))
|
|
(:zot :foo :q))
|
|
|
|
(deftest make-gensym-list.1
|
|
(let ((*gensym-counter* 0))
|
|
(let ((syms (make-gensym-list 3 "FOO")))
|
|
(list (find-if 'symbol-package syms)
|
|
(equal '("FOO0" "FOO1" "FOO2")
|
|
(mapcar 'symbol-name syms)))))
|
|
(nil t))
|
|
|
|
(deftest make-gensym-list.2
|
|
(let ((*gensym-counter* 0))
|
|
(let ((syms (make-gensym-list 3)))
|
|
(list (find-if 'symbol-package syms)
|
|
(equal '("G0" "G1" "G2")
|
|
(mapcar 'symbol-name syms)))))
|
|
(nil t))
|
|
|
|
;;;; Type-system
|
|
|
|
(deftest of-type.1
|
|
(locally
|
|
(declare (notinline of-type))
|
|
(let ((f (of-type 'string)))
|
|
(list (funcall f "foo")
|
|
(funcall f 'bar))))
|
|
(t nil))
|
|
|
|
(deftest type=.1
|
|
(type= 'string 'string)
|
|
t
|
|
t)
|
|
|
|
(deftest type=.2
|
|
(type= 'list '(or null cons))
|
|
t
|
|
t)
|
|
|
|
(deftest type=.3
|
|
(type= 'null '(and symbol list))
|
|
t
|
|
t)
|
|
|
|
(deftest type=.4
|
|
(type= 'string '(satisfies emptyp))
|
|
nil
|
|
nil)
|
|
|
|
(deftest type=.5
|
|
(type= 'string 'list)
|
|
nil
|
|
t)
|
|
|
|
(macrolet
|
|
((test (type numbers)
|
|
`(deftest ,(format-symbol t '#:cdr5.~a (string type))
|
|
(let ((numbers ,numbers))
|
|
(values (mapcar (of-type ',(format-symbol t '#:negative-~a (string type))) numbers)
|
|
(mapcar (of-type ',(format-symbol t '#:non-positive-~a (string type))) numbers)
|
|
(mapcar (of-type ',(format-symbol t '#:non-negative-~a (string type))) numbers)
|
|
(mapcar (of-type ',(format-symbol t '#:positive-~a (string type))) numbers)))
|
|
(t t t nil nil nil nil)
|
|
(t t t t nil nil nil)
|
|
(nil nil nil t t t t)
|
|
(nil nil nil nil t t t))))
|
|
(test fixnum (list most-negative-fixnum -42 -1 0 1 42 most-positive-fixnum))
|
|
(test integer (list (1- most-negative-fixnum) -42 -1 0 1 42 (1+ most-positive-fixnum)))
|
|
(test rational (list (1- most-negative-fixnum) -42/13 -1 0 1 42/13 (1+ most-positive-fixnum)))
|
|
(test real (list most-negative-long-float -42/13 -1 0 1 42/13 most-positive-long-float))
|
|
(test float (list most-negative-short-float -42.02 -1.0 0.0 1.0 42.02 most-positive-short-float))
|
|
(test short-float (list most-negative-short-float -42.02s0 -1.0s0 0.0s0 1.0s0 42.02s0 most-positive-short-float))
|
|
(test single-float (list most-negative-single-float -42.02f0 -1.0f0 0.0f0 1.0f0 42.02f0 most-positive-single-float))
|
|
(test double-float (list most-negative-double-float -42.02d0 -1.0d0 0.0d0 1.0d0 42.02d0 most-positive-double-float))
|
|
(test long-float (list most-negative-long-float -42.02l0 -1.0l0 0.0l0 1.0l0 42.02l0 most-positive-long-float)))
|
|
|
|
;;;; Bindings
|
|
|
|
(declaim (notinline opaque))
|
|
(defun opaque (x)
|
|
x)
|
|
|
|
(deftest if-let.1
|
|
(if-let (x (opaque :ok))
|
|
x
|
|
:bad)
|
|
:ok)
|
|
|
|
(deftest if-let.2
|
|
(if-let (x (opaque nil))
|
|
:bad
|
|
(and (not x) :ok))
|
|
:ok)
|
|
|
|
(deftest if-let.3
|
|
(let ((x 1))
|
|
(if-let ((x 2)
|
|
(y x))
|
|
(+ x y)
|
|
:oops))
|
|
3)
|
|
|
|
(deftest if-let.4
|
|
(if-let ((x 1)
|
|
(y nil))
|
|
:oops
|
|
(and (not y) x))
|
|
1)
|
|
|
|
(deftest if-let.5
|
|
(if-let (x)
|
|
:oops
|
|
(not x))
|
|
t)
|
|
|
|
(deftest if-let.error.1
|
|
(handler-case
|
|
(eval '(if-let x
|
|
:oops
|
|
:oops))
|
|
(type-error ()
|
|
:type-error))
|
|
:type-error)
|
|
|
|
(deftest when-let.1
|
|
(when-let (x (opaque :ok))
|
|
(setf x (cons x x))
|
|
x)
|
|
(:ok . :ok))
|
|
|
|
(deftest when-let.2
|
|
(when-let ((x 1)
|
|
(y nil)
|
|
(z 3))
|
|
:oops)
|
|
nil)
|
|
|
|
(deftest when-let.3
|
|
(let ((x 1))
|
|
(when-let ((x 2)
|
|
(y x))
|
|
(+ x y)))
|
|
3)
|
|
|
|
(deftest when-let.error.1
|
|
(handler-case
|
|
(eval '(when-let x :oops))
|
|
(type-error ()
|
|
:type-error))
|
|
:type-error)
|
|
|
|
(deftest when-let*.1
|
|
(let ((x 1))
|
|
(when-let* ((x 2)
|
|
(y x))
|
|
(+ x y)))
|
|
4)
|
|
|
|
(deftest when-let*.2
|
|
(let ((y 1))
|
|
(when-let* (x y)
|
|
(1+ x)))
|
|
2)
|
|
|
|
(deftest when-let*.3
|
|
(when-let* ((x t)
|
|
(y (consp x))
|
|
(z (error "OOPS")))
|
|
t)
|
|
nil)
|
|
|
|
(deftest when-let*.error.1
|
|
(handler-case
|
|
(eval '(when-let* x :oops))
|
|
(type-error ()
|
|
:type-error))
|
|
:type-error)
|
|
|
|
(deftest doplist.1
|
|
(let (keys values)
|
|
(doplist (k v '(a 1 b 2 c 3) (values t (reverse keys) (reverse values) k v))
|
|
(push k keys)
|
|
(push v values)))
|
|
t
|
|
(a b c)
|
|
(1 2 3)
|
|
nil
|
|
nil)
|
|
|
|
(deftest count-permutations.1
|
|
(values (count-permutations 31 7)
|
|
(count-permutations 1 1)
|
|
(count-permutations 2 1)
|
|
(count-permutations 2 2)
|
|
(count-permutations 3 2)
|
|
(count-permutations 3 1))
|
|
13253058000
|
|
1
|
|
2
|
|
2
|
|
6
|
|
3)
|
|
|
|
(deftest binomial-coefficient.1
|
|
(alexandria:binomial-coefficient 1239 139)
|
|
28794902202288970200771694600561826718847179309929858835480006683522184441358211423695124921058123706380656375919763349913245306834194782172712255592710204598527867804110129489943080460154)
|
|
|
|
;; Exercise bignum case (at least on x86).
|
|
(deftest binomial-coefficient.2
|
|
(alexandria:binomial-coefficient 2000000000000 20)
|
|
430998041177272843950422879590338454856322722740402365741730748431530623813012487773080486408378680853987520854296499536311275320016878730999689934464711239072435565454954447356845336730100919970769793030177499999999900000000000)
|
|
|
|
(deftest copy-stream.1
|
|
(let ((data "sdkfjhsakfh weior763495ewofhsdfk sdfadlkfjhsadf woif sdlkjfhslkdfh sdklfjh"))
|
|
(values (equal data
|
|
(with-input-from-string (in data)
|
|
(with-output-to-string (out)
|
|
(alexandria:copy-stream in out))))
|
|
(equal (subseq data 10 20)
|
|
(with-input-from-string (in data)
|
|
(with-output-to-string (out)
|
|
(alexandria:copy-stream in out :start 10 :end 20))))
|
|
(equal (subseq data 10)
|
|
(with-input-from-string (in data)
|
|
(with-output-to-string (out)
|
|
(alexandria:copy-stream in out :start 10))))
|
|
(equal (subseq data 0 20)
|
|
(with-input-from-string (in data)
|
|
(with-output-to-string (out)
|
|
(alexandria:copy-stream in out :end 20))))))
|
|
t
|
|
t
|
|
t
|
|
t)
|
|
|
|
(deftest extremum.1
|
|
(let ((n 0))
|
|
(dotimes (i 10)
|
|
(let ((data (shuffle (coerce (iota 10000 :start i) 'vector)))
|
|
(ok t))
|
|
(unless (eql i (extremum data #'<))
|
|
(setf ok nil))
|
|
(unless (eql i (extremum (coerce data 'list) #'<))
|
|
(setf ok nil))
|
|
(unless (eql (+ 9999 i) (extremum data #'>))
|
|
(setf ok nil))
|
|
(unless (eql (+ 9999 i) (extremum (coerce data 'list) #'>))
|
|
(setf ok nil))
|
|
(when ok
|
|
(incf n))))
|
|
(when (eql 10 (extremum #(100 1 10 1000) #'> :start 1 :end 3))
|
|
(incf n))
|
|
(when (eql -1000 (extremum #(100 1 10 -1000) #'> :key 'abs))
|
|
(incf n))
|
|
(when (eq nil (extremum "" (lambda (a b) (error "wtf? ~S, ~S" a b))))
|
|
(incf n))
|
|
n)
|
|
13)
|
|
|
|
(deftest starts-with-subseq.string
|
|
(starts-with-subseq "f" "foo" :return-suffix t)
|
|
t
|
|
"oo")
|
|
|
|
(deftest starts-with-subseq.vector
|
|
(starts-with-subseq #(1) #(1 2 3) :return-suffix t)
|
|
t
|
|
#(2 3))
|
|
|
|
(deftest starts-with-subseq.list
|
|
(starts-with-subseq '(1) '(1 2 3) :return-suffix t)
|
|
t
|
|
(2 3))
|
|
|
|
(deftest starts-with-subseq.start1
|
|
(starts-with-subseq "foo" "oop" :start1 1)
|
|
t
|
|
nil)
|
|
|
|
(deftest starts-with-subseq.start2
|
|
(starts-with-subseq "foo" "xfoop" :start2 1)
|
|
t
|
|
nil)
|
|
|
|
(deftest format-symbol.print-case-bound
|
|
(let ((upper (intern "FOO-BAR"))
|
|
(lower (intern "foo-bar"))
|
|
(*print-escape* nil))
|
|
(values
|
|
(let ((*print-case* :downcase))
|
|
(and (eq upper (format-symbol t "~A" upper))
|
|
(eq lower (format-symbol t "~A" lower))))
|
|
(let ((*print-case* :upcase))
|
|
(and (eq upper (format-symbol t "~A" upper))
|
|
(eq lower (format-symbol t "~A" lower))))
|
|
(let ((*print-case* :capitalize))
|
|
(and (eq upper (format-symbol t "~A" upper))
|
|
(eq lower (format-symbol t "~A" lower))))))
|
|
t
|
|
t
|
|
t)
|
|
|
|
(deftest iota.fp-start-and-complex-integer-step
|
|
(equal '(#C(0.0 0.0) #C(0.0 2.0) #C(0.0 4.0))
|
|
(iota 3 :start 0.0 :step #C(0 2)))
|
|
t)
|
|
|
|
(deftest parse-ordinary-lambda-list.1
|
|
(multiple-value-bind (req opt rest keys allowp aux keyp)
|
|
(parse-ordinary-lambda-list '(a b c
|
|
&optional o1 (o2 42) (o3 42 o3-supplied?)
|
|
&key (k1) ((:key k2)) (k3 42 k3-supplied?))
|
|
:normalize t)
|
|
(and (equal '(a b c) req)
|
|
(equal '((o1 nil nil)
|
|
(o2 42 nil)
|
|
(o3 42 o3-supplied?))
|
|
opt)
|
|
(equal '(((:k1 k1) nil nil)
|
|
((:key k2) nil nil)
|
|
((:k3 k3) 42 k3-supplied?))
|
|
keys)
|
|
(not allowp)
|
|
(not aux)
|
|
(eq t keyp)))
|
|
t)
|