3 (eval-when (:compile-toplevel
:load-toplevel
)
8 (defpackage :alexandria-test
9 (:use
:cl
:alexandria
:sb-rt
))
11 (in-package :alexandria-test
)
16 (let* ((orig (vector 1 2 3))
17 (copy (copy-array orig
)))
18 (values (eq orig copy
) (equalp orig copy
)))
22 (let ((orig (make-array 1024 :fill-pointer
0)))
23 (vector-push-extend 1 orig
)
24 (vector-push-extend 2 orig
)
25 (vector-push-extend 3 orig
)
26 (let ((copy (copy-array orig
)))
27 (values (eq orig copy
) (equalp orig copy
)
28 (array-has-fill-pointer-p copy
)
29 (eql (fill-pointer orig
) (fill-pointer copy
)))))
32 (deftest array-index
.1
33 (typep 0 'array-index
)
78 (let ((x (whichever 1 2 3)))
79 (and (member x
'(1 2 3)) t
))
86 (x (whichever a b c
)))
87 (and (member x
'(1 2 3)) t
))
97 (deftest define-constant
.1
98 (let ((name (gensym)))
99 (eval `(define-constant ,name
"FOO" :test equal
))
100 (eval `(define-constant ,name
"FOO" :test equal
))
101 (values (equal "FOO" (symbol-value name
))
106 (deftest define-constant
.2
107 (let ((name (gensym)))
108 (eval `(define-constant ,name
13))
109 (eval `(define-constant ,name
13))
110 (values (eql 13 (symbol-value name
))
117 (deftest required-argument
.1
118 (multiple-value-bind (res err
)
119 (ignore-errors (required-argument))
125 (deftest ensure-hash-table
.1
126 (let ((table (make-hash-table))
128 (multiple-value-bind (value already-there
)
129 (ensure-gethash x table
42)
132 (= 42 (gethash x table
))
133 (multiple-value-bind (value2 already-there2
)
134 (ensure-gethash x table
13)
137 (= 42 (gethash x table
)))))))
140 (deftest copy-hash-table
.1
141 (let ((orig (make-hash-table :test
'eq
:size
123))
143 (setf (gethash orig orig
) t
144 (gethash foo orig
) t
)
145 (let ((eq-copy (copy-hash-table orig
))
146 (eql-copy (copy-hash-table orig
:test
'eql
))
147 (equal-copy (copy-hash-table orig
:test
'equal
))
148 (equalp-copy (copy-hash-table orig
:test
'equalp
)))
149 (list (hash-table-size eq-copy
)
150 (hash-table-count eql-copy
)
151 (gethash orig eq-copy
)
152 (gethash (copy-seq foo
) eql-copy
)
153 (gethash foo eql-copy
)
154 (gethash (copy-seq foo
) equal-copy
)
155 (gethash "FOO" equal-copy
)
156 (gethash "FOO" equalp-copy
))))
157 (123 2 t nil t t nil t
))
159 (deftest maphash-keys
.1
161 (table (make-hash-table)))
162 (declare (notinline maphash-keys
))
164 (setf (gethash i table
) t
))
165 (maphash-keys (lambda (k) (push k keys
)) table
)
166 (set-equal keys
'(0 1 2 3 4 5 6 7 8 9)))
169 (deftest maphash-values
.1
171 (table (make-hash-table)))
172 (declare (notinline maphash-values
))
174 (setf (gethash i table
) (- i
)))
175 (maphash-values (lambda (v) (push v vals
)) table
)
176 (set-equal vals
'(0 -
1 -
2 -
3 -
4 -
5 -
6 -
7 -
8 -
9)))
179 (deftest hash-table-keys
.1
180 (let ((table (make-hash-table)))
182 (setf (gethash i table
) t
))
183 (set-equal (hash-table-keys table
) '(0 1 2 3 4 5 6 7 8 9)))
186 (deftest hash-table-values
.1
187 (let ((table (make-hash-table)))
189 (setf (gethash (gensym) table
) i
))
190 (set-equal (hash-table-values table
) '(0 1 2 3 4 5 6 7 8 9)))
193 (deftest hash-table-alist
.1
194 (let ((table (make-hash-table)))
196 (setf (gethash i table
) (- i
)))
197 (let ((alist (hash-table-alist table
)))
203 (10 (0 .
0) (3 . -
3) (9 . -
9) nil
))
205 (deftest hash-table-plist
.1
206 (let ((table (make-hash-table)))
208 (setf (gethash i table
) (- i
)))
209 (let ((plist (hash-table-plist table
)))
217 (deftest alist-hash-table
.1
218 (let* ((alist '((0 a
) (1 b
) (2 c
)))
219 (table (alist-hash-table alist
)))
220 (list (hash-table-count table
)
224 (hash-table-test table
)))
227 (deftest plist-hash-table
.1
228 (let* ((plist '(:a
1 :b
2 :c
3))
229 (table (plist-hash-table plist
:test
'eq
)))
230 (list (hash-table-count table
)
236 (hash-table-test table
)))
237 (3 1 2 3 nil nil eq
))
242 (let ((disjunction (disjoin (lambda (x)
243 (and (consp x
) :cons
))
245 (and (stringp x
) :string
)))))
246 (list (funcall disjunction
'zot
)
247 (funcall disjunction
'(foo bar
))
248 (funcall disjunction
"test")))
252 (let ((conjunction (conjoin #'consp
257 (list (funcall conjunction
'zot
)
258 (funcall conjunction
'(foo))
259 (funcall conjunction
'("foo"))))
263 (let ((composite (compose '1+
266 #'read-from-string
)))
267 (funcall composite
"1"))
272 (locally (declare (notinline compose
))
276 #'read-from-string
))))
277 (funcall composite
"2"))
281 (let ((compose-form (funcall (compiler-macro-function 'compose
)
287 (let ((fun (funcall (compile nil
`(lambda () ,compose-form
)))))
291 (deftest multiple-value-compose
.1
292 (let ((composite (multiple-value-compose
297 (with-input-from-string (s x
)
298 (values (read s
) (read s
)))))))
299 (multiple-value-list (funcall composite
"2 7")))
302 (deftest multiple-value-compose
.2
303 (let ((composite (locally (declare (notinline multiple-value-compose
))
304 (multiple-value-compose
309 (with-input-from-string (s x
)
310 (values (read s
) (read s
))))))))
311 (multiple-value-list (funcall composite
"2 11")))
314 (deftest multiple-value-compose
.3
315 (let ((compose-form (funcall (compiler-macro-function 'multiple-value-compose
)
316 '(multiple-value-compose
321 (with-input-from-string (s x
)
322 (values (read s
) (read s
)))))
324 (let ((fun (funcall (compile nil
`(lambda () ,compose-form
)))))
325 (multiple-value-list (funcall fun
"2 9"))))
329 (let ((curried (curry '+ 3)))
330 (funcall curried
1 5))
334 (let ((curried (locally (declare (notinline curry
))
340 (let ((curried-form (funcall (compiler-macro-function 'curry
)
343 (let ((fun (funcall (compile nil
`(lambda () ,curried-form
)))))
348 (let ((r (rcurry '/ 2)))
352 (deftest named-lambda
.1
353 (let ((fac (named-lambda fac
(x)
360 (deftest named-lambda
.2
361 (let ((fac (named-lambda fac
(&key x
)
363 (* x
(fac :x
(- x
1)))
370 (deftest alist-plist
.1
371 (alist-plist '((a .
1) (b .
2) (c .
3)))
374 (deftest plist-alist
.1
375 (plist-alist '(a 1 b
2 c
3))
376 ((a .
1) (b .
2) (c .
3)))
379 (let* ((list (list 1 2 3))
381 (unionf list
(list 1 2 4))
382 (values (equal orig
(list 1 2 3))
383 (eql (length list
) 4)
384 (set-difference list
(list 1 2 3 4))
385 (set-difference (list 1 2 3 4) list
)))
392 (let ((list (list 1 2 3)))
393 (nunionf list
(list 1 2 4))
394 (values (eql (length list
) 4)
395 (set-difference (list 1 2 3 4) list
)
396 (set-difference list
(list 1 2 3 4))))
402 (let* ((list (list 1 2 3))
404 (appendf list
'(4 5 6) '(7 8))
405 (list list
(eq list orig
)))
406 ((1 2 3 4 5 6 7 8) nil
))
409 (let ((list1 (list 1 2 3))
410 (list2 (list 4 5 6)))
411 (nconcf list1 list2
(list 7 8 9))
415 (deftest circular-list
.1
416 (let ((circle (circular-list 1 2 3)))
421 (eq circle
(nthcdr 3 circle
))))
424 (deftest circular-list-p
.1
425 (let* ((circle (circular-list 1 2 3 4))
426 (tree (list circle circle
))
427 (dotted (cons circle t
))
428 (proper (list 1 2 3 circle
))
429 (tailcirc (list* 1 2 3 circle
)))
430 (list (circular-list-p circle
)
431 (circular-list-p tree
)
432 (circular-list-p dotted
)
433 (circular-list-p proper
)
434 (circular-list-p tailcirc
)))
437 (deftest circular-list-p
.2
438 (circular-list-p 'foo
)
441 (deftest circular-tree-p
.1
442 (let* ((circle (circular-list 1 2 3 4))
443 (tree1 (list circle circle
))
444 (tree2 (let* ((level2 (list 1 nil
2))
445 (level1 (list level2
)))
446 (setf (second level2
) level1
)
448 (dotted (cons circle t
))
449 (proper (list 1 2 3 circle
))
450 (tailcirc (list* 1 2 3 circle
))
451 (quite-proper (list 1 2 3))
452 (quite-dotted (list 1 (cons 2 3))))
453 (list (circular-tree-p circle
)
454 (circular-tree-p tree1
)
455 (circular-tree-p tree2
)
456 (circular-tree-p dotted
)
457 (circular-tree-p proper
)
458 (circular-tree-p tailcirc
)
459 (circular-tree-p quite-proper
)
460 (circular-tree-p quite-dotted
)))
461 (t t t t t t nil nil
))
463 (deftest proper-list-p
.1
467 (l4 (list (cons 1 2) 3))
468 (l5 (circular-list 1 2)))
469 (list (proper-list-p l1
)
476 (deftest proper-list-p
.2
477 (proper-list-p '(1 2 .
3))
480 (deftest proper-list.type
.1
484 (l4 (list (cons 1 2) 3))
485 (l5 (circular-list 1 2)))
486 (list (typep l1
'proper-list
)
487 (typep l2
'proper-list
)
488 (typep l3
'proper-list
)
489 (typep l4
'proper-list
)
490 (typep l5
'proper-list
)))
500 (deftest lastcar.error
.2
503 (lastcar (circular-list 1 2 3))
509 (deftest setf-lastcar
.1
510 (let ((l (list 1 2 3 4)))
513 (setf (lastcar l
) 42)
518 (deftest setf-lastcar
.2
519 (let ((l (circular-list 1 2 3)))
520 (multiple-value-bind (res err
)
521 (ignore-errors (setf (lastcar l
) 4))
522 (typep err
'type-error
)))
525 (deftest make-circular-list
.1
526 (let ((l (make-circular-list 3 :initial-element
:x
)))
528 (list (eq l
(nthcdr 3 l
))
535 (deftest circular-list.type
.1
536 (let* ((l1 (list 1 2 3))
537 (l2 (circular-list 1 2 3))
538 (l3 (list* 1 2 3 l2
)))
539 (list (typep l1
'circular-list
)
540 (typep l2
'circular-list
)
541 (typep l3
'circular-list
)))
544 (deftest ensure-list
.1
547 (list (ensure-list x
)
551 (deftest ensure-cons
.1
555 (values (ensure-cons x
)
587 (setp '(a :a
) :key
'character
)
591 (setp '(a :a
) :key
'character
:test
(constantly nil
))
595 (set-equal '(1 2 3) '(3 1 2))
599 (set-equal '("Xa") '("Xb")
600 :test
(lambda (a b
) (eql (char a
0) (char b
0))))
604 (set-equal '(1 2) '(4 2))
608 (set-equal '(a b c
) '(:a
:b
:c
) :key
'string
:test
'equal
)
612 (set-equal '(a d c
) '(:a
:b
:c
) :key
'string
:test
'equal
)
616 (set-equal '(a b c
) '(a b c d
))
619 (deftest map-product
.1
620 (map-product 'cons
'(2 3) '(1 4))
621 ((2 .
1) (2 .
4) (3 .
1) (3 .
4)))
623 (deftest map-product
.2
624 (map-product #'cons
'(2 3) '(1 4))
625 ((2 .
1) (2 .
4) (3 .
1) (3 .
4)))
628 (flatten '((1) 2 (((3 4))) ((((5)) 6)) 7))
631 (deftest remove-from-plist
.1
632 (let ((orig '(a 1 b
2 c
3 d
4)))
633 (list (remove-from-plist orig
'a
'c
)
634 (remove-from-plist orig
'b
'd
)
635 (remove-from-plist orig
'b
)
636 (remove-from-plist orig
'a
)
637 (remove-from-plist orig
'd
42 "zot")
638 (remove-from-plist orig
'a
'b
'c
'd
)
639 (remove-from-plist orig
'a
'b
'c
'd
'x
)
640 (equal orig
'(a 1 b
2 c
3 d
4))))
651 (mappend (compose 'list
'*) '(1 2 3) '(1 2 3))
657 (list (clamp 1.5 1 2)
664 (deftest gaussian-random
.1
667 (multiple-value-bind (g1 g2
)
668 (gaussian-random min max
)
669 (values (<= min g1 max
)
682 (iota 3 :start
0.0d0
)
686 (iota 3 :start
2 :step
3.0)
691 (declare (notinline map-iota
))
692 (values (map-iota (lambda (x) (push x all
))
721 (median '(100 0 99 1 98 2 97))
725 (median '(100 0 99 1 98 2 97 96))
729 (variance (list 1 2 3))
732 (deftest standard-deviation
.1
733 (< 0 (standard-deviation (list 1 2 3)) 1)
756 (let ((xv (vector 0 0 0))
758 (maxf (svref xv
(incf p
)) (incf p
))
769 (let ((xv (vector 10 10 10))
771 (minf (svref xv
(incf p
)) (incf p
))
778 (deftest array-index.type
)
786 (list (rotate (list 1 2 3) 0)
787 (rotate (list 1 2 3) 1)
788 (rotate (list 1 2 3) 2)
789 (rotate (list 1 2 3) 3)
790 (rotate (list 1 2 3) 4))
798 (list (rotate (vector 1 2 3 4) 0)
799 (rotate (vector 1 2 3 4))
800 (rotate (vector 1 2 3 4) 2)
801 (rotate (vector 1 2 3 4) 3)
802 (rotate (vector 1 2 3 4) 4)
803 (rotate (vector 1 2 3 4) 5))
812 (list (rotate (list 1 2 3) 0)
813 (rotate (list 1 2 3) -
1)
814 (rotate (list 1 2 3) -
2)
815 (rotate (list 1 2 3) -
3)
816 (rotate (list 1 2 3) -
4))
824 (list (rotate (vector 1 2 3 4) 0)
825 (rotate (vector 1 2 3 4) -
1)
826 (rotate (vector 1 2 3 4) -
2)
827 (rotate (vector 1 2 3 4) -
3)
828 (rotate (vector 1 2 3 4) -
4)
829 (rotate (vector 1 2 3 4) -
5))
838 (values (rotate (list 1) 17)
839 (rotate (list 1) -
5))
844 (let ((s (shuffle (iota 100))))
845 (list (equal s
(iota 100))
850 (typep x
'(integer 0 99)))
855 (let ((s (shuffle (coerce (iota 100) 'vector
))))
856 (list (equal s
(coerce (iota 100) 'vector
))
861 (typep x
'(integer 0 99)))
865 (deftest random-elt
.1
866 (let ((s1 #(1 2 3 4))
868 (list (dotimes (i 1000 nil
)
869 (unless (member (random-elt s1
) s2
)
871 (when (/= (random-elt s1
) (random-elt s1
))
873 (dotimes (i 1000 nil
)
874 (unless (member (random-elt s2
) s2
)
876 (when (/= (random-elt s2
) (random-elt s2
))
894 (let* ((x (list 1 2 3))
904 (deftest proper-sequence.type
.1
906 (typep x
'proper-sequence
))
910 (circular-list 1 2 3 4)))
922 (deftest sequence-of-length-p
.1
923 (mapcar #'sequence-of-length-p
944 (t t t t t t nil nil nil nil
))
946 (deftest copy-sequence
.1
947 (let ((l (list 1 2 3))
948 (v (vector #\a #\b #\c
)))
949 (declare (notinline copy-sequence
))
950 (let ((l.list
(copy-sequence 'list l
))
951 (l.vector
(copy-sequence 'vector l
))
952 (l.spec-v
(copy-sequence '(vector fixnum
) l
))
953 (v.vector
(copy-sequence 'vector v
))
954 (v.list
(copy-sequence 'list v
))
955 (v.string
(copy-sequence 'string v
)))
956 (list (member l
(list l.list l.vector l.spec-v
))
957 (member v
(list v.vector v.list v.string
))
959 (equalp l.vector
#(1 2 3))
960 (eq 'fixnum
(array-element-type l.spec-v
))
962 (equal v.list
'(#\a #\b #\c
))
963 (equal "abc" v.string
))))
964 (nil nil t t t t t t
))
973 (deftest first-elt.error
.1
988 (deftest setf-first-elt
.1
989 (let ((l (list 1 2 3))
990 (s (copy-seq "foobar"))
991 (v (vector :a
:b
:c
)))
992 (setf (first-elt l
) -
1
1000 (deftest setf-first-elt.error
.1
1002 (multiple-value-bind (res err
)
1003 (ignore-errors (setf (first-elt l
) 4))
1004 (typep err
'type-error
)))
1016 (deftest last-elt.error
.1
1026 (circular-list 1 2 3)
1027 (list* 1 2 3 (circular-list 4 5))))
1035 (deftest setf-last-elt
.1
1036 (let ((l (list 1 2 3))
1037 (s (copy-seq "foobar"))
1038 (b (copy-seq #*010101001)))
1039 (setf (last-elt l
) '???
1047 (deftest setf-last-elt.error
.1
1049 (setf (last-elt 'foo
) 13)
1054 (deftest starts-with
.1
1055 (list (starts-with 1 '(1 2 3))
1056 (starts-with 1 #(1 2 3))
1057 (starts-with #\x
"xyz")
1058 (starts-with 2 '(1 2 3))
1059 (starts-with 3 #(1 2 3))
1061 (starts-with nil nil
))
1062 (t t t nil nil nil nil
))
1064 (deftest starts-with
.2
1065 (values (starts-with 1 '(-1 2 3) :key
'-
)
1066 (starts-with "foo" '("foo" "bar") :test
'equal
)
1067 (starts-with "f" '(#\f) :key
'string
:test
'equal
)
1068 (starts-with -
1 '(0 1 2) :key
#'1+)
1069 (starts-with "zot" '("ZOT") :test
'equal
))
1076 (deftest ends-with
.1
1077 (list (ends-with 3 '(1 2 3))
1078 (ends-with 3 #(1 2 3))
1079 (ends-with #\z
"xyz")
1080 (ends-with 2 '(1 2 3))
1081 (ends-with 1 #(1 2 3))
1083 (ends-with nil nil
))
1084 (t t t nil nil nil nil
))
1086 (deftest ends-with
.2
1087 (values (ends-with 2 '(0 13 1) :key
'1+)
1088 (ends-with "foo" (vector "bar" "foo") :test
'equal
)
1089 (ends-with "X" (vector 1 2 #\X
) :key
'string
:test
'equal
)
1090 (ends-with "foo" "foo" :test
'equal
))
1096 (deftest ends-with.error
.1
1098 (ends-with 3 (circular-list 3 3 3 1 3 3))
1103 (deftest with-unique-names
.1
1104 (let ((*gensym-counter
* 0))
1105 (let ((syms (with-unique-names (foo bar quux
)
1106 (list foo bar quux
))))
1107 (list (find-if #'symbol-package syms
)
1108 (equal '("FOO0" "BAR1" "QUUX2")
1109 (mapcar #'symbol-name syms
)))))
1112 (deftest with-unique-names
.2
1113 (let ((*gensym-counter
* 0))
1114 (let ((syms (with-unique-names ((foo "_foo_") (bar -bar-
) (quux #\q
))
1115 (list foo bar quux
))))
1116 (list (find-if #'symbol-package syms
)
1117 (equal '("_foo_0" "-BAR-1" "q2")
1118 (mapcar #'symbol-name syms
)))))
1121 (deftest with-unique-names
.3
1122 (let ((*gensym-counter
* 0))
1123 (multiple-value-bind (res err
)
1127 (with-unique-names ((foo "_foo_") (bar -bar-
) (quux 42))
1128 (list foo bar quux
))))
1129 (list (find-if #'symbol-package syms
)
1130 (equal '("_foo_0" "-BAR-1" "q2")
1131 (mapcar #'symbol-name syms
))))))
1132 (typep err
'error
)))
1135 (deftest once-only
.1
1136 (macrolet ((cons1.good
(x)
1142 (list (cons1.good
(incf y
))
1144 (cons1.bad
(incf y
))
1146 ((1 .
1) 1 (2 .
3) 3))
1148 (deftest once-only
.2
1149 (macrolet ((cons1 (x)
1153 (list (cons1 (incf z
))
1156 ((1 .
1) 1 (2 .
2)))
1158 (deftest parse-body
.1
1159 (parse-body '("doc" "body") :documentation t
)
1164 (deftest parse-body
.2
1165 (parse-body '("body") :documentation t
)
1170 (deftest parse-body
.3
1171 (parse-body '("doc" "body"))
1176 (deftest parse-body
.4
1177 (parse-body '((declare (foo)) "doc" (declare (bar)) body
) :documentation t
)
1179 ((declare (foo)) (declare (bar)))
1182 (deftest parse-body
.5
1183 (parse-body '((declare (foo)) "doc" (declare (bar)) body
))
1184 ("doc" (declare (bar)) body
)
1188 (deftest parse-body
.6
1189 (multiple-value-bind (res err
)
1191 (parse-body '("foo" "bar" "quux")
1198 (deftest ensure-symbol
.1
1199 (ensure-symbol :cons
:cl
)
1203 (deftest ensure-symbol
.2
1204 (ensure-symbol "CONS" :alexandria
)
1208 (deftest ensure-symbol
.3
1209 (ensure-symbol 'foo
:keyword
)
1213 (deftest ensure-symbol
.4
1214 (ensure-symbol #\
* :alexandria
)
1218 (deftest format-symbol
.1
1219 (let ((s (format-symbol nil
"X-~D" 13)))
1220 (list (symbol-package s
)
1224 (deftest format-symbol
.2
1225 (format-symbol :keyword
"SYM-~A" :bolic
)
1228 (deftest format-symbol
.3
1229 (let ((*package
* (find-package :cl
)))
1230 (format-symbol t
"FIND-~A" 'package
))
1233 (deftest make-keyword
.1
1234 (list (make-keyword 'zot
)
1235 (make-keyword "FOO")
1239 (deftest make-gensym-list
.1
1240 (let ((*gensym-counter
* 0))
1241 (let ((syms (make-gensym-list 3 "FOO")))
1242 (list (find-if 'symbol-package syms
)
1243 (equal '("FOO0" "FOO1" "FOO2")
1244 (mapcar 'symbol-name syms
)))))
1247 (deftest make-gensym-list
.2
1248 (let ((*gensym-counter
* 0))
1249 (let ((syms (make-gensym-list 3)))
1250 (list (find-if 'symbol-package syms
)
1251 (equal '("G0" "G1" "G2")
1252 (mapcar 'symbol-name syms
)))))
1259 (declare (notinline of-type
))
1260 (let ((f (of-type 'string
)))
1261 (list (funcall f
"foo")
1266 (type= 'string
'string
)
1271 (type= 'list
'(or null cons
))
1276 (type= 'null
'(and symbol list
))
1281 (type= 'string
'(satisfies emptyp
))
1286 (type= 'string
'list
)
1292 (declaim (notinline opaque
))
1297 (if-let (x (opaque :ok
))
1303 (if-let (x (opaque nil
))
1329 (deftest if-let.error
.1
1348 (y (prog1 x
(setf x nil
))))
1359 (deftest if-let
*.error
.1
1361 (eval '(if-let* x
:oops
:oops
))
1367 (when-let (x (opaque :ok
))
1386 (deftest when-let.error
.1
1388 (eval '(when-let x
:oops
))
1393 (deftest when-let
*.1
1400 (deftest when-let
*.2
1406 (deftest when-let
*.error
.1
1408 (eval '(when-let* x
:oops
))
1413 (deftest nth-value-or
.1
1414 (multiple-value-bind (a b c
)
1423 (doplist (k v
'(a 1 b
2 c
3) (values t
(reverse keys
) (reverse values
) k v
))