diff options
Diffstat (limited to 'third_party/lisp/alexandria/tests.lisp')
| -rw-r--r-- | third_party/lisp/alexandria/tests.lisp | 2047 |
1 files changed, 0 insertions, 2047 deletions
diff --git a/third_party/lisp/alexandria/tests.lisp b/third_party/lisp/alexandria/tests.lisp deleted file mode 100644 index b70ef0475e..0000000000 --- a/third_party/lisp/alexandria/tests.lisp +++ /dev/null @@ -1,2047 +0,0 @@ -(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) |