ttests.lisp - clic - Clic is an command line interactive client for gopher written in Common LISP
(HTM) git clone git://bitreich.org/clic/ git://hg6vgqziawt5s4dj.onion/clic/
(DIR) Log
(DIR) Files
(DIR) Refs
(DIR) Tags
(DIR) LICENSE
---
ttests.lisp (54259B)
---
1 (in-package :cl-user)
2
3 (defpackage :alexandria-tests
4 (:use :cl :alexandria #+sbcl :sb-rt #-sbcl :rtest)
5 (:import-from #+sbcl :sb-rt #-sbcl :rtest
6 #:*compile-tests* #:*expected-failures*))
7
8 (in-package :alexandria-tests)
9
10 (defun run-tests (&key ((:compiled *compile-tests*)))
11 (do-tests))
12
13 (defun hash-table-test-name (name)
14 ;; Workaround for Clisp calling EQL in a hash-table FASTHASH-EQL.
15 (hash-table-test (make-hash-table :test name)))
16
17 ;;;; Arrays
18
19 (deftest copy-array.1
20 (let* ((orig (vector 1 2 3))
21 (copy (copy-array orig)))
22 (values (eq orig copy) (equalp orig copy)))
23 nil t)
24
25 (deftest copy-array.2
26 (let ((orig (make-array 1024 :fill-pointer 0)))
27 (vector-push-extend 1 orig)
28 (vector-push-extend 2 orig)
29 (vector-push-extend 3 orig)
30 (let ((copy (copy-array orig)))
31 (values (eq orig copy) (equalp orig copy)
32 (array-has-fill-pointer-p copy)
33 (eql (fill-pointer orig) (fill-pointer copy)))))
34 nil t t t)
35
36 (deftest copy-array.3
37 (let* ((orig (vector 1 2 3))
38 (copy (copy-array orig)))
39 (typep copy 'simple-array))
40 t)
41
42 (deftest copy-array.4
43 (let ((orig (make-array 21
44 :adjustable t
45 :fill-pointer 0)))
46 (dotimes (n 42)
47 (vector-push-extend n orig))
48 (let ((copy (copy-array orig
49 :adjustable nil
50 :fill-pointer nil)))
51 (typep copy 'simple-array)))
52 t)
53
54 (deftest array-index.1
55 (typep 0 'array-index)
56 t)
57
58 ;;;; Conditions
59
60 (deftest unwind-protect-case.1
61 (let (result)
62 (unwind-protect-case ()
63 (random 10)
64 (:normal (push :normal result))
65 (:abort (push :abort result))
66 (:always (push :always result)))
67 result)
68 (:always :normal))
69
70 (deftest unwind-protect-case.2
71 (let (result)
72 (unwind-protect-case ()
73 (random 10)
74 (:always (push :always result))
75 (:normal (push :normal result))
76 (:abort (push :abort result)))
77 result)
78 (:normal :always))
79
80 (deftest unwind-protect-case.3
81 (let (result1 result2 result3)
82 (ignore-errors
83 (unwind-protect-case ()
84 (error "FOOF!")
85 (:normal (push :normal result1))
86 (:abort (push :abort result1))
87 (:always (push :always result1))))
88 (catch 'foof
89 (unwind-protect-case ()
90 (throw 'foof 42)
91 (:normal (push :normal result2))
92 (:abort (push :abort result2))
93 (:always (push :always result2))))
94 (block foof
95 (unwind-protect-case ()
96 (return-from foof 42)
97 (:normal (push :normal result3))
98 (:abort (push :abort result3))
99 (:always (push :always result3))))
100 (values result1 result2 result3))
101 (:always :abort)
102 (:always :abort)
103 (:always :abort))
104
105 (deftest unwind-protect-case.4
106 (let (result)
107 (unwind-protect-case (aborted-p)
108 (random 42)
109 (:always (setq result aborted-p)))
110 result)
111 nil)
112
113 (deftest unwind-protect-case.5
114 (let (result)
115 (block foof
116 (unwind-protect-case (aborted-p)
117 (return-from foof)
118 (:always (setq result aborted-p))))
119 result)
120 t)
121
122 ;;;; Control flow
123
124 (deftest switch.1
125 (switch (13 :test =)
126 (12 :oops)
127 (13.0 :yay))
128 :yay)
129
130 (deftest switch.2
131 (switch (13)
132 ((+ 12 2) :oops)
133 ((- 13 1) :oops2)
134 (t :yay))
135 :yay)
136
137 (deftest eswitch.1
138 (let ((x 13))
139 (eswitch (x :test =)
140 (12 :oops)
141 (13.0 :yay)))
142 :yay)
143
144 (deftest eswitch.2
145 (let ((x 13))
146 (eswitch (x :key 1+)
147 (11 :oops)
148 (14 :yay)))
149 :yay)
150
151 (deftest cswitch.1
152 (cswitch (13 :test =)
153 (12 :oops)
154 (13.0 :yay))
155 :yay)
156
157 (deftest cswitch.2
158 (cswitch (13 :key 1-)
159 (12 :yay)
160 (13.0 :oops))
161 :yay)
162
163 (deftest multiple-value-prog2.1
164 (multiple-value-prog2
165 (values 1 1 1)
166 (values 2 20 200)
167 (values 3 3 3))
168 2 20 200)
169
170 (deftest nth-value-or.1
171 (multiple-value-bind (a b c)
172 (nth-value-or 1
173 (values 1 nil 1)
174 (values 2 2 2))
175 (= a b c 2))
176 t)
177
178 (deftest whichever.1
179 (let ((x (whichever 1 2 3)))
180 (and (member x '(1 2 3)) t))
181 t)
182
183 (deftest whichever.2
184 (let* ((a 1)
185 (b 2)
186 (c 3)
187 (x (whichever a b c)))
188 (and (member x '(1 2 3)) t))
189 t)
190
191 (deftest xor.1
192 (xor nil nil 1 nil)
193 1
194 t)
195
196 (deftest xor.2
197 (xor nil nil 1 2)
198 nil
199 nil)
200
201 (deftest xor.3
202 (xor nil nil nil)
203 nil
204 t)
205
206 ;;;; Definitions
207
208 (deftest define-constant.1
209 (let ((name (gensym)))
210 (eval `(define-constant ,name "FOO" :test 'equal))
211 (eval `(define-constant ,name "FOO" :test 'equal))
212 (values (equal "FOO" (symbol-value name))
213 (constantp name)))
214 t
215 t)
216
217 (deftest define-constant.2
218 (let ((name (gensym)))
219 (eval `(define-constant ,name 13))
220 (eval `(define-constant ,name 13))
221 (values (eql 13 (symbol-value name))
222 (constantp name)))
223 t
224 t)
225
226 ;;;; Errors
227
228 ;;; TYPEP is specified to return a generalized boolean and, for
229 ;;; example, ECL exploits this by returning the superclasses of ERROR
230 ;;; in this case.
231 (defun errorp (x)
232 (not (null (typep x 'error))))
233
234 (deftest required-argument.1
235 (multiple-value-bind (res err)
236 (ignore-errors (required-argument))
237 (errorp err))
238 t)
239
240 ;;;; Hash tables
241
242 (deftest ensure-gethash.1
243 (let ((table (make-hash-table))
244 (x (list 1)))
245 (multiple-value-bind (value already-there)
246 (ensure-gethash x table 42)
247 (and (= value 42)
248 (not already-there)
249 (= 42 (gethash x table))
250 (multiple-value-bind (value2 already-there2)
251 (ensure-gethash x table 13)
252 (and (= value2 42)
253 already-there2
254 (= 42 (gethash x table)))))))
255 t)
256
257 (deftest ensure-gethash.2
258 (let ((table (make-hash-table))
259 (count 0))
260 (multiple-value-call #'values
261 (ensure-gethash (progn (incf count) :foo)
262 (progn (incf count) table)
263 (progn (incf count) :bar))
264 (gethash :foo table)
265 count))
266 :bar nil :bar t 3)
267
268 (deftest copy-hash-table.1
269 (let ((orig (make-hash-table :test 'eq :size 123))
270 (foo "foo"))
271 (setf (gethash orig orig) t
272 (gethash foo orig) t)
273 (let ((eq-copy (copy-hash-table orig))
274 (eql-copy (copy-hash-table orig :test 'eql))
275 (equal-copy (copy-hash-table orig :test 'equal))
276 (equalp-copy (copy-hash-table orig :test 'equalp)))
277 (list (eql (hash-table-size eq-copy) (hash-table-size orig))
278 (eql (hash-table-rehash-size eq-copy)
279 (hash-table-rehash-size orig))
280 (hash-table-count eql-copy)
281 (gethash orig eq-copy)
282 (gethash (copy-seq foo) eql-copy)
283 (gethash foo eql-copy)
284 (gethash (copy-seq foo) equal-copy)
285 (gethash "FOO" equal-copy)
286 (gethash "FOO" equalp-copy))))
287 (t t 2 t nil t t nil t))
288
289 (deftest copy-hash-table.2
290 (let ((ht (make-hash-table))
291 (list (list :list (vector :A :B :C))))
292 (setf (gethash 'list ht) list)
293 (let* ((shallow-copy (copy-hash-table ht))
294 (deep1-copy (copy-hash-table ht :key 'copy-list))
295 (list (gethash 'list ht))
296 (shallow-list (gethash 'list shallow-copy))
297 (deep1-list (gethash 'list deep1-copy)))
298 (list (eq ht shallow-copy)
299 (eq ht deep1-copy)
300 (eq list shallow-list)
301 (eq list deep1-list) ; outer list was copied.
302 (eq (second list) (second shallow-list))
303 (eq (second list) (second deep1-list)) ; inner vector wasn't copied.
304 )))
305 (nil nil t nil t t))
306
307 (deftest maphash-keys.1
308 (let ((keys nil)
309 (table (make-hash-table)))
310 (declare (notinline maphash-keys))
311 (dotimes (i 10)
312 (setf (gethash i table) t))
313 (maphash-keys (lambda (k) (push k keys)) table)
314 (set-equal keys '(0 1 2 3 4 5 6 7 8 9)))
315 t)
316
317 (deftest maphash-values.1
318 (let ((vals nil)
319 (table (make-hash-table)))
320 (declare (notinline maphash-values))
321 (dotimes (i 10)
322 (setf (gethash i table) (- i)))
323 (maphash-values (lambda (v) (push v vals)) table)
324 (set-equal vals '(0 -1 -2 -3 -4 -5 -6 -7 -8 -9)))
325 t)
326
327 (deftest hash-table-keys.1
328 (let ((table (make-hash-table)))
329 (dotimes (i 10)
330 (setf (gethash i table) t))
331 (set-equal (hash-table-keys table) '(0 1 2 3 4 5 6 7 8 9)))
332 t)
333
334 (deftest hash-table-values.1
335 (let ((table (make-hash-table)))
336 (dotimes (i 10)
337 (setf (gethash (gensym) table) i))
338 (set-equal (hash-table-values table) '(0 1 2 3 4 5 6 7 8 9)))
339 t)
340
341 (deftest hash-table-alist.1
342 (let ((table (make-hash-table)))
343 (dotimes (i 10)
344 (setf (gethash i table) (- i)))
345 (let ((alist (hash-table-alist table)))
346 (list (length alist)
347 (assoc 0 alist)
348 (assoc 3 alist)
349 (assoc 9 alist)
350 (assoc nil alist))))
351 (10 (0 . 0) (3 . -3) (9 . -9) nil))
352
353 (deftest hash-table-plist.1
354 (let ((table (make-hash-table)))
355 (dotimes (i 10)
356 (setf (gethash i table) (- i)))
357 (let ((plist (hash-table-plist table)))
358 (list (length plist)
359 (getf plist 0)
360 (getf plist 2)
361 (getf plist 7)
362 (getf plist nil))))
363 (20 0 -2 -7 nil))
364
365 (deftest alist-hash-table.1
366 (let* ((alist '((0 a) (1 b) (2 c)))
367 (table (alist-hash-table alist)))
368 (list (hash-table-count table)
369 (gethash 0 table)
370 (gethash 1 table)
371 (gethash 2 table)
372 (eq (hash-table-test-name 'eql)
373 (hash-table-test table))))
374 (3 (a) (b) (c) t))
375
376 (deftest alist-hash-table.duplicate-keys
377 (let* ((alist '((0 a) (1 b) (0 c) (1 d) (2 e)))
378 (table (alist-hash-table alist)))
379 (list (hash-table-count table)
380 (gethash 0 table)
381 (gethash 1 table)
382 (gethash 2 table)))
383 (3 (a) (b) (e)))
384
385 (deftest plist-hash-table.1
386 (let* ((plist '(:a 1 :b 2 :c 3))
387 (table (plist-hash-table plist :test 'eq)))
388 (list (hash-table-count table)
389 (gethash :a table)
390 (gethash :b table)
391 (gethash :c table)
392 (gethash 2 table)
393 (gethash nil table)
394 (eq (hash-table-test-name 'eq)
395 (hash-table-test table))))
396 (3 1 2 3 nil nil t))
397
398 (deftest plist-hash-table.duplicate-keys
399 (let* ((plist '(:a 1 :b 2 :a 3 :b 4 :c 5))
400 (table (plist-hash-table plist)))
401 (list (hash-table-count table)
402 (gethash :a table)
403 (gethash :b table)
404 (gethash :c table)))
405 (3 1 2 5))
406
407 ;;;; Functions
408
409 (deftest disjoin.1
410 (let ((disjunction (disjoin (lambda (x)
411 (and (consp x) :cons))
412 (lambda (x)
413 (and (stringp x) :string)))))
414 (list (funcall disjunction 'zot)
415 (funcall disjunction '(foo bar))
416 (funcall disjunction "test")))
417 (nil :cons :string))
418
419 (deftest disjoin.2
420 (let ((disjunction (disjoin #'zerop)))
421 (list (funcall disjunction 0)
422 (funcall disjunction 1)))
423 (t nil))
424
425 (deftest conjoin.1
426 (let ((conjunction (conjoin #'consp
427 (lambda (x)
428 (stringp (car x)))
429 (lambda (x)
430 (char (car x) 0)))))
431 (list (funcall conjunction 'zot)
432 (funcall conjunction '(foo))
433 (funcall conjunction '("foo"))))
434 (nil nil #\f))
435
436 (deftest conjoin.2
437 (let ((conjunction (conjoin #'zerop)))
438 (list (funcall conjunction 0)
439 (funcall conjunction 1)))
440 (t nil))
441
442 (deftest compose.1
443 (let ((composite (compose '1+
444 (lambda (x)
445 (* x 2))
446 #'read-from-string)))
447 (funcall composite "1"))
448 3)
449
450 (deftest compose.2
451 (let ((composite
452 (locally (declare (notinline compose))
453 (compose '1+
454 (lambda (x)
455 (* x 2))
456 #'read-from-string))))
457 (funcall composite "2"))
458 5)
459
460 (deftest compose.3
461 (let ((compose-form (funcall (compiler-macro-function 'compose)
462 '(compose '1+
463 (lambda (x)
464 (* x 2))
465 #'read-from-string)
466 nil)))
467 (let ((fun (funcall (compile nil `(lambda () ,compose-form)))))
468 (funcall fun "3")))
469 7)
470
471 (deftest compose.4
472 (let ((composite (compose #'zerop)))
473 (list (funcall composite 0)
474 (funcall composite 1)))
475 (t nil))
476
477 (deftest multiple-value-compose.1
478 (let ((composite (multiple-value-compose
479 #'truncate
480 (lambda (x y)
481 (values y x))
482 (lambda (x)
483 (with-input-from-string (s x)
484 (values (read s) (read s)))))))
485 (multiple-value-list (funcall composite "2 7")))
486 (3 1))
487
488 (deftest multiple-value-compose.2
489 (let ((composite (locally (declare (notinline multiple-value-compose))
490 (multiple-value-compose
491 #'truncate
492 (lambda (x y)
493 (values y x))
494 (lambda (x)
495 (with-input-from-string (s x)
496 (values (read s) (read s))))))))
497 (multiple-value-list (funcall composite "2 11")))
498 (5 1))
499
500 (deftest multiple-value-compose.3
501 (let ((compose-form (funcall (compiler-macro-function 'multiple-value-compose)
502 '(multiple-value-compose
503 #'truncate
504 (lambda (x y)
505 (values y x))
506 (lambda (x)
507 (with-input-from-string (s x)
508 (values (read s) (read s)))))
509 nil)))
510 (let ((fun (funcall (compile nil `(lambda () ,compose-form)))))
511 (multiple-value-list (funcall fun "2 9"))))
512 (4 1))
513
514 (deftest multiple-value-compose.4
515 (let ((composite (multiple-value-compose #'truncate)))
516 (multiple-value-list (funcall composite 9 2)))
517 (4 1))
518
519 (deftest curry.1
520 (let ((curried (curry '+ 3)))
521 (funcall curried 1 5))
522 9)
523
524 (deftest curry.2
525 (let ((curried (locally (declare (notinline curry))
526 (curry '* 2 3))))
527 (funcall curried 7))
528 42)
529
530 (deftest curry.3
531 (let ((curried-form (funcall (compiler-macro-function 'curry)
532 '(curry '/ 8)
533 nil)))
534 (let ((fun (funcall (compile nil `(lambda () ,curried-form)))))
535 (funcall fun 2)))
536 4)
537
538 (deftest curry.4
539 (let* ((x 1)
540 (curried (curry (progn
541 (incf x)
542 (lambda (y z) (* x y z)))
543 3)))
544 (list (funcall curried 7)
545 (funcall curried 7)
546 x))
547 (42 42 2))
548
549 (deftest rcurry.1
550 (let ((r (rcurry '/ 2)))
551 (funcall r 8))
552 4)
553
554 (deftest rcurry.2
555 (let* ((x 1)
556 (curried (rcurry (progn
557 (incf x)
558 (lambda (y z) (* x y z)))
559 3)))
560 (list (funcall curried 7)
561 (funcall curried 7)
562 x))
563 (42 42 2))
564
565 (deftest named-lambda.1
566 (let ((fac (named-lambda fac (x)
567 (if (> x 1)
568 (* x (fac (- x 1)))
569 x))))
570 (funcall fac 5))
571 120)
572
573 (deftest named-lambda.2
574 (let ((fac (named-lambda fac (&key x)
575 (if (> x 1)
576 (* x (fac :x (- x 1)))
577 x))))
578 (funcall fac :x 5))
579 120)
580
581 ;;;; Lists
582
583 (deftest alist-plist.1
584 (alist-plist '((a . 1) (b . 2) (c . 3)))
585 (a 1 b 2 c 3))
586
587 (deftest plist-alist.1
588 (plist-alist '(a 1 b 2 c 3))
589 ((a . 1) (b . 2) (c . 3)))
590
591 (deftest unionf.1
592 (let* ((list (list 1 2 3))
593 (orig list))
594 (unionf list (list 1 2 4))
595 (values (equal orig (list 1 2 3))
596 (eql (length list) 4)
597 (set-difference list (list 1 2 3 4))
598 (set-difference (list 1 2 3 4) list)))
599 t
600 t
601 nil
602 nil)
603
604 (deftest nunionf.1
605 (let ((list (list 1 2 3)))
606 (nunionf list (list 1 2 4))
607 (values (eql (length list) 4)
608 (set-difference (list 1 2 3 4) list)
609 (set-difference list (list 1 2 3 4))))
610 t
611 nil
612 nil)
613
614 (deftest appendf.1
615 (let* ((list (list 1 2 3))
616 (orig list))
617 (appendf list '(4 5 6) '(7 8))
618 (list list (eq list orig)))
619 ((1 2 3 4 5 6 7 8) nil))
620
621 (deftest nconcf.1
622 (let ((list1 (list 1 2 3))
623 (list2 (list 4 5 6)))
624 (nconcf list1 list2 (list 7 8 9))
625 list1)
626 (1 2 3 4 5 6 7 8 9))
627
628 (deftest circular-list.1
629 (let ((circle (circular-list 1 2 3)))
630 (list (first circle)
631 (second circle)
632 (third circle)
633 (fourth circle)
634 (eq circle (nthcdr 3 circle))))
635 (1 2 3 1 t))
636
637 (deftest circular-list-p.1
638 (let* ((circle (circular-list 1 2 3 4))
639 (tree (list circle circle))
640 (dotted (cons circle t))
641 (proper (list 1 2 3 circle))
642 (tailcirc (list* 1 2 3 circle)))
643 (list (circular-list-p circle)
644 (circular-list-p tree)
645 (circular-list-p dotted)
646 (circular-list-p proper)
647 (circular-list-p tailcirc)))
648 (t nil nil nil t))
649
650 (deftest circular-list-p.2
651 (circular-list-p 'foo)
652 nil)
653
654 (deftest circular-tree-p.1
655 (let* ((circle (circular-list 1 2 3 4))
656 (tree1 (list circle circle))
657 (tree2 (let* ((level2 (list 1 nil 2))
658 (level1 (list level2)))
659 (setf (second level2) level1)
660 level1))
661 (dotted (cons circle t))
662 (proper (list 1 2 3 circle))
663 (tailcirc (list* 1 2 3 circle))
664 (quite-proper (list 1 2 3))
665 (quite-dotted (list 1 (cons 2 3))))
666 (list (circular-tree-p circle)
667 (circular-tree-p tree1)
668 (circular-tree-p tree2)
669 (circular-tree-p dotted)
670 (circular-tree-p proper)
671 (circular-tree-p tailcirc)
672 (circular-tree-p quite-proper)
673 (circular-tree-p quite-dotted)))
674 (t t t t t t nil nil))
675
676 (deftest circular-tree-p.2
677 (alexandria:circular-tree-p '#1=(#1#))
678 t)
679
680 (deftest proper-list-p.1
681 (let ((l1 (list 1))
682 (l2 (list 1 2))
683 (l3 (cons 1 2))
684 (l4 (list (cons 1 2) 3))
685 (l5 (circular-list 1 2)))
686 (list (proper-list-p l1)
687 (proper-list-p l2)
688 (proper-list-p l3)
689 (proper-list-p l4)
690 (proper-list-p l5)))
691 (t t nil t nil))
692
693 (deftest proper-list-p.2
694 (proper-list-p '(1 2 . 3))
695 nil)
696
697 (deftest proper-list.type.1
698 (let ((l1 (list 1))
699 (l2 (list 1 2))
700 (l3 (cons 1 2))
701 (l4 (list (cons 1 2) 3))
702 (l5 (circular-list 1 2)))
703 (list (typep l1 'proper-list)
704 (typep l2 'proper-list)
705 (typep l3 'proper-list)
706 (typep l4 'proper-list)
707 (typep l5 'proper-list)))
708 (t t nil t nil))
709
710 (deftest proper-list-length.1
711 (values
712 (proper-list-length nil)
713 (proper-list-length (list 1))
714 (proper-list-length (list 2 2))
715 (proper-list-length (list 3 3 3))
716 (proper-list-length (list 4 4 4 4))
717 (proper-list-length (list 5 5 5 5 5))
718 (proper-list-length (list 6 6 6 6 6 6))
719 (proper-list-length (list 7 7 7 7 7 7 7))
720 (proper-list-length (list 8 8 8 8 8 8 8 8))
721 (proper-list-length (list 9 9 9 9 9 9 9 9 9)))
722 0 1 2 3 4 5 6 7 8 9)
723
724 (deftest proper-list-length.2
725 (flet ((plength (x)
726 (handler-case
727 (proper-list-length x)
728 (type-error ()
729 :ok))))
730 (values
731 (plength (list* 1))
732 (plength (list* 2 2))
733 (plength (list* 3 3 3))
734 (plength (list* 4 4 4 4))
735 (plength (list* 5 5 5 5 5))
736 (plength (list* 6 6 6 6 6 6))
737 (plength (list* 7 7 7 7 7 7 7))
738 (plength (list* 8 8 8 8 8 8 8 8))
739 (plength (list* 9 9 9 9 9 9 9 9 9))))
740 :ok :ok :ok
741 :ok :ok :ok
742 :ok :ok :ok)
743
744 (deftest lastcar.1
745 (let ((l1 (list 1))
746 (l2 (list 1 2)))
747 (list (lastcar l1)
748 (lastcar l2)))
749 (1 2))
750
751 (deftest lastcar.error.2
752 (handler-case
753 (progn
754 (lastcar (circular-list 1 2 3))
755 nil)
756 (error ()
757 t))
758 t)
759
760 (deftest setf-lastcar.1
761 (let ((l (list 1 2 3 4)))
762 (values (lastcar l)
763 (progn
764 (setf (lastcar l) 42)
765 (lastcar l))))
766 4
767 42)
768
769 (deftest setf-lastcar.2
770 (let ((l (circular-list 1 2 3)))
771 (multiple-value-bind (res err)
772 (ignore-errors (setf (lastcar l) 4))
773 (typep err 'type-error)))
774 t)
775
776 (deftest make-circular-list.1
777 (let ((l (make-circular-list 3 :initial-element :x)))
778 (setf (car l) :y)
779 (list (eq l (nthcdr 3 l))
780 (first l)
781 (second l)
782 (third l)
783 (fourth l)))
784 (t :y :x :x :y))
785
786 (deftest circular-list.type.1
787 (let* ((l1 (list 1 2 3))
788 (l2 (circular-list 1 2 3))
789 (l3 (list* 1 2 3 l2)))
790 (list (typep l1 'circular-list)
791 (typep l2 'circular-list)
792 (typep l3 'circular-list)))
793 (nil t t))
794
795 (deftest ensure-list.1
796 (let ((x (list 1))
797 (y 2))
798 (list (ensure-list x)
799 (ensure-list y)))
800 ((1) (2)))
801
802 (deftest ensure-cons.1
803 (let ((x (cons 1 2))
804 (y nil)
805 (z "foo"))
806 (values (ensure-cons x)
807 (ensure-cons y)
808 (ensure-cons z)))
809 (1 . 2)
810 (nil)
811 ("foo"))
812
813 (deftest setp.1
814 (setp '(1))
815 t)
816
817 (deftest setp.2
818 (setp nil)
819 t)
820
821 (deftest setp.3
822 (setp "foo")
823 nil)
824
825 (deftest setp.4
826 (setp '(1 2 3 1))
827 nil)
828
829 (deftest setp.5
830 (setp '(1 2 3))
831 t)
832
833 (deftest setp.6
834 (setp '(a :a))
835 t)
836
837 (deftest setp.7
838 (setp '(a :a) :key 'character)
839 nil)
840
841 (deftest setp.8
842 (setp '(a :a) :key 'character :test (constantly nil))
843 t)
844
845 (deftest set-equal.1
846 (set-equal '(1 2 3) '(3 1 2))
847 t)
848
849 (deftest set-equal.2
850 (set-equal '("Xa") '("Xb")
851 :test (lambda (a b) (eql (char a 0) (char b 0))))
852 t)
853
854 (deftest set-equal.3
855 (set-equal '(1 2) '(4 2))
856 nil)
857
858 (deftest set-equal.4
859 (set-equal '(a b c) '(:a :b :c) :key 'string :test 'equal)
860 t)
861
862 (deftest set-equal.5
863 (set-equal '(a d c) '(:a :b :c) :key 'string :test 'equal)
864 nil)
865
866 (deftest set-equal.6
867 (set-equal '(a b c) '(a b c d))
868 nil)
869
870 (deftest map-product.1
871 (map-product 'cons '(2 3) '(1 4))
872 ((2 . 1) (2 . 4) (3 . 1) (3 . 4)))
873
874 (deftest map-product.2
875 (map-product #'cons '(2 3) '(1 4))
876 ((2 . 1) (2 . 4) (3 . 1) (3 . 4)))
877
878 (deftest flatten.1
879 (flatten '((1) 2 (((3 4))) ((((5)) 6)) 7))
880 (1 2 3 4 5 6 7))
881
882 (deftest remove-from-plist.1
883 (let ((orig '(a 1 b 2 c 3 d 4)))
884 (list (remove-from-plist orig 'a 'c)
885 (remove-from-plist orig 'b 'd)
886 (remove-from-plist orig 'b)
887 (remove-from-plist orig 'a)
888 (remove-from-plist orig 'd 42 "zot")
889 (remove-from-plist orig 'a 'b 'c 'd)
890 (remove-from-plist orig 'a 'b 'c 'd 'x)
891 (equal orig '(a 1 b 2 c 3 d 4))))
892 ((b 2 d 4)
893 (a 1 c 3)
894 (a 1 c 3 d 4)
895 (b 2 c 3 d 4)
896 (a 1 b 2 c 3)
897 nil
898 nil
899 t))
900
901 (deftest delete-from-plist.1
902 (let ((orig '(a 1 b 2 c 3 d 4 d 5)))
903 (list (delete-from-plist (copy-list orig) 'a 'c)
904 (delete-from-plist (copy-list orig) 'b 'd)
905 (delete-from-plist (copy-list orig) 'b)
906 (delete-from-plist (copy-list orig) 'a)
907 (delete-from-plist (copy-list orig) 'd 42 "zot")
908 (delete-from-plist (copy-list orig) 'a 'b 'c 'd)
909 (delete-from-plist (copy-list orig) 'a 'b 'c 'd 'x)
910 (equal orig (delete-from-plist orig))
911 (eq orig (delete-from-plist orig))))
912 ((b 2 d 4 d 5)
913 (a 1 c 3)
914 (a 1 c 3 d 4 d 5)
915 (b 2 c 3 d 4 d 5)
916 (a 1 b 2 c 3)
917 nil
918 nil
919 t
920 t))
921
922 (deftest mappend.1
923 (mappend (compose 'list '*) '(1 2 3) '(1 2 3))
924 (1 4 9))
925
926 (deftest assoc-value.1
927 (let ((key1 '(complex key))
928 (key2 'simple-key)
929 (alist '())
930 (result '()))
931 (push 1 (assoc-value alist key1 :test #'equal))
932 (push 2 (assoc-value alist key1 :test 'equal))
933 (push 42 (assoc-value alist key2))
934 (push 43 (assoc-value alist key2 :test 'eq))
935 (push (assoc-value alist key1 :test #'equal) result)
936 (push (assoc-value alist key2) result)
937
938 (push 'very (rassoc-value alist (list 2 1) :test #'equal))
939 (push (cdr (assoc '(very complex key) alist :test #'equal)) result)
940 result)
941 ((2 1) (43 42) (2 1)))
942
943 ;;;; Numbers
944
945 (deftest clamp.1
946 (list (clamp 1.5 1 2)
947 (clamp 2.0 1 2)
948 (clamp 1.0 1 2)
949 (clamp 3 1 2)
950 (clamp 0 1 2))
951 (1.5 2.0 1.0 2 1))
952
953 (deftest gaussian-random.1
954 (let ((min -0.2)
955 (max +0.2))
956 (multiple-value-bind (g1 g2)
957 (gaussian-random min max)
958 (values (<= min g1 max)
959 (<= min g2 max)
960 (/= g1 g2) ;uh
961 )))
962 t
963 t
964 t)
965
966 #+sbcl
967 (deftest gaussian-random.2
968 (handler-case
969 (sb-ext:with-timeout 2
970 (progn
971 (loop
972 :repeat 10000
973 :do (gaussian-random 0 nil))
974 'done))
975 (sb-ext:timeout ()
976 'timed-out))
977 done)
978
979 (deftest iota.1
980 (iota 3)
981 (0 1 2))
982
983 (deftest iota.2
984 (iota 3 :start 0.0d0)
985 (0.0d0 1.0d0 2.0d0))
986
987 (deftest iota.3
988 (iota 3 :start 2 :step 3.0)
989 (2.0 5.0 8.0))
990
991 (deftest map-iota.1
992 (let (all)
993 (declare (notinline map-iota))
994 (values (map-iota (lambda (x) (push x all))
995 3
996 :start 2
997 :step 1.1d0)
998 all))
999 3
1000 (4.2d0 3.1d0 2.0d0))
1001
1002 (deftest lerp.1
1003 (lerp 0.5 1 2)
1004 1.5)
1005
1006 (deftest lerp.2
1007 (lerp 0.1 1 2)
1008 1.1)
1009
1010 (deftest lerp.3
1011 (lerp 0.1 4 25)
1012 6.1)
1013
1014 (deftest mean.1
1015 (mean '(1 2 3))
1016 2)
1017
1018 (deftest mean.2
1019 (mean '(1 2 3 4))
1020 5/2)
1021
1022 (deftest mean.3
1023 (mean '(1 2 10))
1024 13/3)
1025
1026 (deftest median.1
1027 (median '(100 0 99 1 98 2 97))
1028 97)
1029
1030 (deftest median.2
1031 (median '(100 0 99 1 98 2 97 96))
1032 193/2)
1033
1034 (deftest variance.1
1035 (variance (list 1 2 3))
1036 2/3)
1037
1038 (deftest standard-deviation.1
1039 (< 0 (standard-deviation (list 1 2 3)) 1)
1040 t)
1041
1042 (deftest maxf.1
1043 (let ((x 1))
1044 (maxf x 2)
1045 x)
1046 2)
1047
1048 (deftest maxf.2
1049 (let ((x 1))
1050 (maxf x 0)
1051 x)
1052 1)
1053
1054 (deftest maxf.3
1055 (let ((x 1)
1056 (c 0))
1057 (maxf x (incf c))
1058 (list x c))
1059 (1 1))
1060
1061 (deftest maxf.4
1062 (let ((xv (vector 0 0 0))
1063 (p 0))
1064 (maxf (svref xv (incf p)) (incf p))
1065 (list p xv))
1066 (2 #(0 2 0)))
1067
1068 (deftest minf.1
1069 (let ((y 1))
1070 (minf y 0)
1071 y)
1072 0)
1073
1074 (deftest minf.2
1075 (let ((xv (vector 10 10 10))
1076 (p 0))
1077 (minf (svref xv (incf p)) (incf p))
1078 (list p xv))
1079 (2 #(10 2 10)))
1080
1081 (deftest subfactorial.1
1082 (mapcar #'subfactorial (iota 22))
1083 (1
1084 0
1085 1
1086 2
1087 9
1088 44
1089 265
1090 1854
1091 14833
1092 133496
1093 1334961
1094 14684570
1095 176214841
1096 2290792932
1097 32071101049
1098 481066515734
1099 7697064251745
1100 130850092279664
1101 2355301661033953
1102 44750731559645106
1103 895014631192902121
1104 18795307255050944540))
1105
1106 ;;;; Arrays
1107
1108 #+nil
1109 (deftest array-index.type)
1110
1111 #+nil
1112 (deftest copy-array)
1113
1114 ;;;; Sequences
1115
1116 (deftest rotate.1
1117 (list (rotate (list 1 2 3) 0)
1118 (rotate (list 1 2 3) 1)
1119 (rotate (list 1 2 3) 2)
1120 (rotate (list 1 2 3) 3)
1121 (rotate (list 1 2 3) 4))
1122 ((1 2 3)
1123 (3 1 2)
1124 (2 3 1)
1125 (1 2 3)
1126 (3 1 2)))
1127
1128 (deftest rotate.2
1129 (list (rotate (vector 1 2 3 4) 0)
1130 (rotate (vector 1 2 3 4))
1131 (rotate (vector 1 2 3 4) 2)
1132 (rotate (vector 1 2 3 4) 3)
1133 (rotate (vector 1 2 3 4) 4)
1134 (rotate (vector 1 2 3 4) 5))
1135 (#(1 2 3 4)
1136 #(4 1 2 3)
1137 #(3 4 1 2)
1138 #(2 3 4 1)
1139 #(1 2 3 4)
1140 #(4 1 2 3)))
1141
1142 (deftest rotate.3
1143 (list (rotate (list 1 2 3) 0)
1144 (rotate (list 1 2 3) -1)
1145 (rotate (list 1 2 3) -2)
1146 (rotate (list 1 2 3) -3)
1147 (rotate (list 1 2 3) -4))
1148 ((1 2 3)
1149 (2 3 1)
1150 (3 1 2)
1151 (1 2 3)
1152 (2 3 1)))
1153
1154 (deftest rotate.4
1155 (list (rotate (vector 1 2 3 4) 0)
1156 (rotate (vector 1 2 3 4) -1)
1157 (rotate (vector 1 2 3 4) -2)
1158 (rotate (vector 1 2 3 4) -3)
1159 (rotate (vector 1 2 3 4) -4)
1160 (rotate (vector 1 2 3 4) -5))
1161 (#(1 2 3 4)
1162 #(2 3 4 1)
1163 #(3 4 1 2)
1164 #(4 1 2 3)
1165 #(1 2 3 4)
1166 #(2 3 4 1)))
1167
1168 (deftest rotate.5
1169 (values (rotate (list 1) 17)
1170 (rotate (list 1) -5))
1171 (1)
1172 (1))
1173
1174 (deftest shuffle.1
1175 (let ((s (shuffle (iota 100))))
1176 (list (equal s (iota 100))
1177 (every (lambda (x)
1178 (member x s))
1179 (iota 100))
1180 (every (lambda (x)
1181 (typep x '(integer 0 99)))
1182 s)))
1183 (nil t t))
1184
1185 (deftest shuffle.2
1186 (let ((s (shuffle (coerce (iota 100) 'vector))))
1187 (list (equal s (coerce (iota 100) 'vector))
1188 (every (lambda (x)
1189 (find x s))
1190 (iota 100))
1191 (every (lambda (x)
1192 (typep x '(integer 0 99)))
1193 s)))
1194 (nil t t))
1195
1196 (deftest shuffle.3
1197 (let* ((orig (coerce (iota 21) 'vector))
1198 (copy (copy-seq orig)))
1199 (shuffle copy :start 10 :end 15)
1200 (list (every #'eql (subseq copy 0 10) (subseq orig 0 10))
1201 (every #'eql (subseq copy 15) (subseq orig 15))))
1202 (t t))
1203
1204 (deftest random-elt.1
1205 (let ((s1 #(1 2 3 4))
1206 (s2 '(1 2 3 4)))
1207 (list (dotimes (i 1000 nil)
1208 (unless (member (random-elt s1) s2)
1209 (return nil))
1210 (when (/= (random-elt s1) (random-elt s1))
1211 (return t)))
1212 (dotimes (i 1000 nil)
1213 (unless (member (random-elt s2) s2)
1214 (return nil))
1215 (when (/= (random-elt s2) (random-elt s2))
1216 (return t)))))
1217 (t t))
1218
1219 (deftest removef.1
1220 (let* ((x '(1 2 3))
1221 (x* x)
1222 (y #(1 2 3))
1223 (y* y))
1224 (removef x 1)
1225 (removef y 3)
1226 (list x x* y y*))
1227 ((2 3)
1228 (1 2 3)
1229 #(1 2)
1230 #(1 2 3)))
1231
1232 (deftest deletef.1
1233 (let* ((x (list 1 2 3))
1234 (x* x)
1235 (y (vector 1 2 3)))
1236 (deletef x 2)
1237 (deletef y 1)
1238 (list x x* y))
1239 ((1 3)
1240 (1 3)
1241 #(2 3)))
1242
1243 (deftest map-permutations.1
1244 (let ((seq (list 1 2 3))
1245 (seen nil)
1246 (ok t))
1247 (map-permutations (lambda (s)
1248 (unless (set-equal s seq)
1249 (setf ok nil))
1250 (when (member s seen :test 'equal)
1251 (setf ok nil))
1252 (push s seen))
1253 seq
1254 :copy t)
1255 (values ok (length seen)))
1256 t
1257 6)
1258
1259 (deftest proper-sequence.type.1
1260 (mapcar (lambda (x)
1261 (typep x 'proper-sequence))
1262 (list (list 1 2 3)
1263 (vector 1 2 3)
1264 #2a((1 2) (3 4))
1265 (circular-list 1 2 3 4)))
1266 (t t nil nil))
1267
1268 (deftest emptyp.1
1269 (mapcar #'emptyp
1270 (list (list 1)
1271 (circular-list 1)
1272 nil
1273 (vector)
1274 (vector 1)))
1275 (nil nil t t nil))
1276
1277 (deftest sequence-of-length-p.1
1278 (mapcar #'sequence-of-length-p
1279 (list nil
1280 #()
1281 (list 1)
1282 (vector 1)
1283 (list 1 2)
1284 (vector 1 2)
1285 (list 1 2)
1286 (vector 1 2)
1287 (list 1 2)
1288 (vector 1 2))
1289 (list 0
1290 0
1291 1
1292 1
1293 2
1294 2
1295 1
1296 1
1297 4
1298 4))
1299 (t t t t t t nil nil nil nil))
1300
1301 (deftest length=.1
1302 (mapcar #'length=
1303 (list nil
1304 #()
1305 (list 1)
1306 (vector 1)
1307 (list 1 2)
1308 (vector 1 2)
1309 (list 1 2)
1310 (vector 1 2)
1311 (list 1 2)
1312 (vector 1 2))
1313 (list 0
1314 0
1315 1
1316 1
1317 2
1318 2
1319 1
1320 1
1321 4
1322 4))
1323 (t t t t t t nil nil nil nil))
1324
1325 (deftest length=.2
1326 ;; test the compiler macro
1327 (macrolet ((x (&rest args)
1328 (funcall
1329 (compile nil
1330 `(lambda ()
1331 (length= ,@args))))))
1332 (list (x 2 '(1 2))
1333 (x '(1 2) '(3 4))
1334 (x '(1 2) 2)
1335 (x '(1 2) 2 '(3 4))
1336 (x 1 2 3)))
1337 (t t t t nil))
1338
1339 (deftest copy-sequence.1
1340 (let ((l (list 1 2 3))
1341 (v (vector #\a #\b #\c)))
1342 (declare (notinline copy-sequence))
1343 (let ((l.list (copy-sequence 'list l))
1344 (l.vector (copy-sequence 'vector l))
1345 (l.spec-v (copy-sequence '(vector fixnum) l))
1346 (v.vector (copy-sequence 'vector v))
1347 (v.list (copy-sequence 'list v))
1348 (v.string (copy-sequence 'string v)))
1349 (list (member l (list l.list l.vector l.spec-v))
1350 (member v (list v.vector v.list v.string))
1351 (equal l.list l)
1352 (equalp l.vector #(1 2 3))
1353 (type= (upgraded-array-element-type 'fixnum)
1354 (array-element-type l.spec-v))
1355 (equalp v.vector v)
1356 (equal v.list '(#\a #\b #\c))
1357 (equal "abc" v.string))))
1358 (nil nil t t t t t t))
1359
1360 (deftest first-elt.1
1361 (mapcar #'first-elt
1362 (list (list 1 2 3)
1363 "abc"
1364 (vector :a :b :c)))
1365 (1 #\a :a))
1366
1367 (deftest first-elt.error.1
1368 (mapcar (lambda (x)
1369 (handler-case
1370 (first-elt x)
1371 (type-error ()
1372 :type-error)))
1373 (list nil
1374 #()
1375 12
1376 :zot))
1377 (:type-error
1378 :type-error
1379 :type-error
1380 :type-error))
1381
1382 (deftest setf-first-elt.1
1383 (let ((l (list 1 2 3))
1384 (s (copy-seq "foobar"))
1385 (v (vector :a :b :c)))
1386 (setf (first-elt l) -1
1387 (first-elt s) #\x
1388 (first-elt v) 'zot)
1389 (values l s v))
1390 (-1 2 3)
1391 "xoobar"
1392 #(zot :b :c))
1393
1394 (deftest setf-first-elt.error.1
1395 (let ((l 'foo))
1396 (multiple-value-bind (res err)
1397 (ignore-errors (setf (first-elt l) 4))
1398 (typep err 'type-error)))
1399 t)
1400
1401 (deftest last-elt.1
1402 (mapcar #'last-elt
1403 (list (list 1 2 3)
1404 (vector :a :b :c)
1405 "FOOBAR"
1406 #*001
1407 #*010))
1408 (3 :c #\R 1 0))
1409
1410 (deftest last-elt.error.1
1411 (mapcar (lambda (x)
1412 (handler-case
1413 (last-elt x)
1414 (type-error ()
1415 :type-error)))
1416 (list nil
1417 #()
1418 12
1419 :zot
1420 (circular-list 1 2 3)
1421 (list* 1 2 3 (circular-list 4 5))))
1422 (:type-error
1423 :type-error
1424 :type-error
1425 :type-error
1426 :type-error
1427 :type-error))
1428
1429 (deftest setf-last-elt.1
1430 (let ((l (list 1 2 3))
1431 (s (copy-seq "foobar"))
1432 (b (copy-seq #*010101001)))
1433 (setf (last-elt l) '???
1434 (last-elt s) #\?
1435 (last-elt b) 0)
1436 (values l s b))
1437 (1 2 ???)
1438 "fooba?"
1439 #*010101000)
1440
1441 (deftest setf-last-elt.error.1
1442 (handler-case
1443 (setf (last-elt 'foo) 13)
1444 (type-error ()
1445 :type-error))
1446 :type-error)
1447
1448 (deftest starts-with.1
1449 (list (starts-with 1 '(1 2 3))
1450 (starts-with 1 #(1 2 3))
1451 (starts-with #\x "xyz")
1452 (starts-with 2 '(1 2 3))
1453 (starts-with 3 #(1 2 3))
1454 (starts-with 1 1)
1455 (starts-with nil nil))
1456 (t t t nil nil nil nil))
1457
1458 (deftest starts-with.2
1459 (values (starts-with 1 '(-1 2 3) :key '-)
1460 (starts-with "foo" '("foo" "bar") :test 'equal)
1461 (starts-with "f" '(#\f) :key 'string :test 'equal)
1462 (starts-with -1 '(0 1 2) :key #'1+)
1463 (starts-with "zot" '("ZOT") :test 'equal))
1464 t
1465 t
1466 t
1467 nil
1468 nil)
1469
1470 (deftest ends-with.1
1471 (list (ends-with 3 '(1 2 3))
1472 (ends-with 3 #(1 2 3))
1473 (ends-with #\z "xyz")
1474 (ends-with 2 '(1 2 3))
1475 (ends-with 1 #(1 2 3))
1476 (ends-with 1 1)
1477 (ends-with nil nil))
1478 (t t t nil nil nil nil))
1479
1480 (deftest ends-with.2
1481 (values (ends-with 2 '(0 13 1) :key '1+)
1482 (ends-with "foo" (vector "bar" "foo") :test 'equal)
1483 (ends-with "X" (vector 1 2 #\X) :key 'string :test 'equal)
1484 (ends-with "foo" "foo" :test 'equal))
1485 t
1486 t
1487 t
1488 nil)
1489
1490 (deftest ends-with.error.1
1491 (handler-case
1492 (ends-with 3 (circular-list 3 3 3 1 3 3))
1493 (type-error ()
1494 :type-error))
1495 :type-error)
1496
1497 (deftest sequences.passing-improper-lists
1498 (macrolet ((signals-error-p (form)
1499 `(handler-case
1500 (progn ,form nil)
1501 (type-error (e)
1502 t)))
1503 (cut (fn &rest args)
1504 (with-gensyms (arg)
1505 (print`(lambda (,arg)
1506 (apply ,fn (list ,@(substitute arg '_ args))))))))
1507 (let ((circular-list (make-circular-list 5 :initial-element :foo))
1508 (dotted-list (list* 'a 'b 'c 'd)))
1509 (loop for nth from 0
1510 for fn in (list
1511 (cut #'lastcar _)
1512 (cut #'rotate _ 3)
1513 (cut #'rotate _ -3)
1514 (cut #'shuffle _)
1515 (cut #'random-elt _)
1516 (cut #'last-elt _)
1517 (cut #'ends-with :foo _))
1518 nconcing
1519 (let ((on-circular-p (signals-error-p (funcall fn circular-list)))
1520 (on-dotted-p (signals-error-p (funcall fn dotted-list))))
1521 (when (or (not on-circular-p) (not on-dotted-p))
1522 (append
1523 (unless on-circular-p
1524 (let ((*print-circle* t))
1525 (list
1526 (format nil
1527 "No appropriate error signalled when passing ~S to ~Ath entry."
1528 circular-list nth))))
1529 (unless on-dotted-p
1530 (list
1531 (format nil
1532 "No appropriate error signalled when passing ~S to ~Ath entry."
1533 dotted-list nth)))))))))
1534 nil)
1535
1536 ;;;; IO
1537
1538 (deftest read-stream-content-into-string.1
1539 (values (with-input-from-string (stream "foo bar")
1540 (read-stream-content-into-string stream))
1541 (with-input-from-string (stream "foo bar")
1542 (read-stream-content-into-string stream :buffer-size 1))
1543 (with-input-from-string (stream "foo bar")
1544 (read-stream-content-into-string stream :buffer-size 6))
1545 (with-input-from-string (stream "foo bar")
1546 (read-stream-content-into-string stream :buffer-size 7)))
1547 "foo bar"
1548 "foo bar"
1549 "foo bar"
1550 "foo bar")
1551
1552 (deftest read-stream-content-into-string.2
1553 (handler-case
1554 (let ((stream (make-broadcast-stream)))
1555 (read-stream-content-into-string stream :buffer-size 0))
1556 (type-error ()
1557 :type-error))
1558 :type-error)
1559
1560 #+(or)
1561 (defvar *octets*
1562 (map '(simple-array (unsigned-byte 8) (7)) #'char-code "foo bar"))
1563
1564 #+(or)
1565 (deftest read-stream-content-into-byte-vector.1
1566 (values (with-input-from-byte-vector (stream *octets*)
1567 (read-stream-content-into-byte-vector stream))
1568 (with-input-from-byte-vector (stream *octets*)
1569 (read-stream-content-into-byte-vector stream :initial-size 1))
1570 (with-input-from-byte-vector (stream *octets*)
1571 (read-stream-content-into-byte-vector stream 'alexandria::%length 6))
1572 (with-input-from-byte-vector (stream *octets*)
1573 (read-stream-content-into-byte-vector stream 'alexandria::%length 3)))
1574 *octets*
1575 *octets*
1576 *octets*
1577 (subseq *octets* 0 3))
1578
1579 (deftest read-stream-content-into-byte-vector.2
1580 (handler-case
1581 (let ((stream (make-broadcast-stream)))
1582 (read-stream-content-into-byte-vector stream :initial-size 0))
1583 (type-error ()
1584 :type-error))
1585 :type-error)
1586
1587 ;;;; Macros
1588
1589 (deftest with-unique-names.1
1590 (let ((*gensym-counter* 0))
1591 (let ((syms (with-unique-names (foo bar quux)
1592 (list foo bar quux))))
1593 (list (find-if #'symbol-package syms)
1594 (equal '("FOO0" "BAR1" "QUUX2")
1595 (mapcar #'symbol-name syms)))))
1596 (nil t))
1597
1598 (deftest with-unique-names.2
1599 (let ((*gensym-counter* 0))
1600 (let ((syms (with-unique-names ((foo "_foo_") (bar -bar-) (quux #\q))
1601 (list foo bar quux))))
1602 (list (find-if #'symbol-package syms)
1603 (equal '("_foo_0" "-BAR-1" "q2")
1604 (mapcar #'symbol-name syms)))))
1605 (nil t))
1606
1607 (deftest with-unique-names.3
1608 (let ((*gensym-counter* 0))
1609 (multiple-value-bind (res err)
1610 (ignore-errors
1611 (eval
1612 '(let ((syms
1613 (with-unique-names ((foo "_foo_") (bar -bar-) (quux 42))
1614 (list foo bar quux))))
1615 (list (find-if #'symbol-package syms)
1616 (equal '("_foo_0" "-BAR-1" "q2")
1617 (mapcar #'symbol-name syms))))))
1618 (errorp err)))
1619 t)
1620
1621 (deftest once-only.1
1622 (macrolet ((cons1.good (x)
1623 (once-only (x)
1624 `(cons ,x ,x)))
1625 (cons1.bad (x)
1626 `(cons ,x ,x)))
1627 (let ((y 0))
1628 (list (cons1.good (incf y))
1629 y
1630 (cons1.bad (incf y))
1631 y)))
1632 ((1 . 1) 1 (2 . 3) 3))
1633
1634 (deftest once-only.2
1635 (macrolet ((cons1 (x)
1636 (once-only ((y x))
1637 `(cons ,y ,y))))
1638 (let ((z 0))
1639 (list (cons1 (incf z))
1640 z
1641 (cons1 (incf z)))))
1642 ((1 . 1) 1 (2 . 2)))
1643
1644 (deftest parse-body.1
1645 (parse-body '("doc" "body") :documentation t)
1646 ("body")
1647 nil
1648 "doc")
1649
1650 (deftest parse-body.2
1651 (parse-body '("body") :documentation t)
1652 ("body")
1653 nil
1654 nil)
1655
1656 (deftest parse-body.3
1657 (parse-body '("doc" "body"))
1658 ("doc" "body")
1659 nil
1660 nil)
1661
1662 (deftest parse-body.4
1663 (parse-body '((declare (foo)) "doc" (declare (bar)) body) :documentation t)
1664 (body)
1665 ((declare (foo)) (declare (bar)))
1666 "doc")
1667
1668 (deftest parse-body.5
1669 (parse-body '((declare (foo)) "doc" (declare (bar)) body))
1670 ("doc" (declare (bar)) body)
1671 ((declare (foo)))
1672 nil)
1673
1674 (deftest parse-body.6
1675 (multiple-value-bind (res err)
1676 (ignore-errors
1677 (parse-body '("foo" "bar" "quux")
1678 :documentation t))
1679 (errorp err))
1680 t)
1681
1682 ;;;; Symbols
1683
1684 (deftest ensure-symbol.1
1685 (ensure-symbol :cons :cl)
1686 cons
1687 :external)
1688
1689 (deftest ensure-symbol.2
1690 (ensure-symbol "CONS" :alexandria)
1691 cons
1692 :inherited)
1693
1694 (deftest ensure-symbol.3
1695 (ensure-symbol 'foo :keyword)
1696 :foo
1697 :external)
1698
1699 (deftest ensure-symbol.4
1700 (ensure-symbol #\* :alexandria)
1701 *
1702 :inherited)
1703
1704 (deftest format-symbol.1
1705 (let ((s (format-symbol nil '#:x-~d 13)))
1706 (list (symbol-package s)
1707 (string= (string '#:x-13) (symbol-name s))))
1708 (nil t))
1709
1710 (deftest format-symbol.2
1711 (format-symbol :keyword '#:sym-~a (string :bolic))
1712 :sym-bolic)
1713
1714 (deftest format-symbol.3
1715 (let ((*package* (find-package :cl)))
1716 (format-symbol t '#:find-~a (string 'package)))
1717 find-package)
1718
1719 (deftest make-keyword.1
1720 (list (make-keyword 'zot)
1721 (make-keyword "FOO")
1722 (make-keyword #\Q))
1723 (:zot :foo :q))
1724
1725 (deftest make-gensym-list.1
1726 (let ((*gensym-counter* 0))
1727 (let ((syms (make-gensym-list 3 "FOO")))
1728 (list (find-if 'symbol-package syms)
1729 (equal '("FOO0" "FOO1" "FOO2")
1730 (mapcar 'symbol-name syms)))))
1731 (nil t))
1732
1733 (deftest make-gensym-list.2
1734 (let ((*gensym-counter* 0))
1735 (let ((syms (make-gensym-list 3)))
1736 (list (find-if 'symbol-package syms)
1737 (equal '("G0" "G1" "G2")
1738 (mapcar 'symbol-name syms)))))
1739 (nil t))
1740
1741 ;;;; Type-system
1742
1743 (deftest of-type.1
1744 (locally
1745 (declare (notinline of-type))
1746 (let ((f (of-type 'string)))
1747 (list (funcall f "foo")
1748 (funcall f 'bar))))
1749 (t nil))
1750
1751 (deftest type=.1
1752 (type= 'string 'string)
1753 t
1754 t)
1755
1756 (deftest type=.2
1757 (type= 'list '(or null cons))
1758 t
1759 t)
1760
1761 (deftest type=.3
1762 (type= 'null '(and symbol list))
1763 t
1764 t)
1765
1766 (deftest type=.4
1767 (type= 'string '(satisfies emptyp))
1768 nil
1769 nil)
1770
1771 (deftest type=.5
1772 (type= 'string 'list)
1773 nil
1774 t)
1775
1776 (macrolet
1777 ((test (type numbers)
1778 `(deftest ,(format-symbol t '#:cdr5.~a (string type))
1779 (let ((numbers ,numbers))
1780 (values (mapcar (of-type ',(format-symbol t '#:negative-~a (string type))) numbers)
1781 (mapcar (of-type ',(format-symbol t '#:non-positive-~a (string type))) numbers)
1782 (mapcar (of-type ',(format-symbol t '#:non-negative-~a (string type))) numbers)
1783 (mapcar (of-type ',(format-symbol t '#:positive-~a (string type))) numbers)))
1784 (t t t nil nil nil nil)
1785 (t t t t nil nil nil)
1786 (nil nil nil t t t t)
1787 (nil nil nil nil t t t))))
1788 (test fixnum (list most-negative-fixnum -42 -1 0 1 42 most-positive-fixnum))
1789 (test integer (list (1- most-negative-fixnum) -42 -1 0 1 42 (1+ most-positive-fixnum)))
1790 (test rational (list (1- most-negative-fixnum) -42/13 -1 0 1 42/13 (1+ most-positive-fixnum)))
1791 (test real (list most-negative-long-float -42/13 -1 0 1 42/13 most-positive-long-float))
1792 (test float (list most-negative-short-float -42.02 -1.0 0.0 1.0 42.02 most-positive-short-float))
1793 (test short-float (list most-negative-short-float -42.02s0 -1.0s0 0.0s0 1.0s0 42.02s0 most-positive-short-float))
1794 (test single-float (list most-negative-single-float -42.02f0 -1.0f0 0.0f0 1.0f0 42.02f0 most-positive-single-float))
1795 (test double-float (list most-negative-double-float -42.02d0 -1.0d0 0.0d0 1.0d0 42.02d0 most-positive-double-float))
1796 (test long-float (list most-negative-long-float -42.02l0 -1.0l0 0.0l0 1.0l0 42.02l0 most-positive-long-float)))
1797
1798 ;;;; Bindings
1799
1800 (declaim (notinline opaque))
1801 (defun opaque (x)
1802 x)
1803
1804 (deftest if-let.1
1805 (if-let (x (opaque :ok))
1806 x
1807 :bad)
1808 :ok)
1809
1810 (deftest if-let.2
1811 (if-let (x (opaque nil))
1812 :bad
1813 (and (not x) :ok))
1814 :ok)
1815
1816 (deftest if-let.3
1817 (let ((x 1))
1818 (if-let ((x 2)
1819 (y x))
1820 (+ x y)
1821 :oops))
1822 3)
1823
1824 (deftest if-let.4
1825 (if-let ((x 1)
1826 (y nil))
1827 :oops
1828 (and (not y) x))
1829 1)
1830
1831 (deftest if-let.5
1832 (if-let (x)
1833 :oops
1834 (not x))
1835 t)
1836
1837 (deftest if-let.error.1
1838 (handler-case
1839 (eval '(if-let x
1840 :oops
1841 :oops))
1842 (type-error ()
1843 :type-error))
1844 :type-error)
1845
1846 (deftest when-let.1
1847 (when-let (x (opaque :ok))
1848 (setf x (cons x x))
1849 x)
1850 (:ok . :ok))
1851
1852 (deftest when-let.2
1853 (when-let ((x 1)
1854 (y nil)
1855 (z 3))
1856 :oops)
1857 nil)
1858
1859 (deftest when-let.3
1860 (let ((x 1))
1861 (when-let ((x 2)
1862 (y x))
1863 (+ x y)))
1864 3)
1865
1866 (deftest when-let.error.1
1867 (handler-case
1868 (eval '(when-let x :oops))
1869 (type-error ()
1870 :type-error))
1871 :type-error)
1872
1873 (deftest when-let*.1
1874 (let ((x 1))
1875 (when-let* ((x 2)
1876 (y x))
1877 (+ x y)))
1878 4)
1879
1880 (deftest when-let*.2
1881 (let ((y 1))
1882 (when-let* (x y)
1883 (1+ x)))
1884 2)
1885
1886 (deftest when-let*.3
1887 (when-let* ((x t)
1888 (y (consp x))
1889 (z (error "OOPS")))
1890 t)
1891 nil)
1892
1893 (deftest when-let*.error.1
1894 (handler-case
1895 (eval '(when-let* x :oops))
1896 (type-error ()
1897 :type-error))
1898 :type-error)
1899
1900 (deftest doplist.1
1901 (let (keys values)
1902 (doplist (k v '(a 1 b 2 c 3) (values t (reverse keys) (reverse values) k v))
1903 (push k keys)
1904 (push v values)))
1905 t
1906 (a b c)
1907 (1 2 3)
1908 nil
1909 nil)
1910
1911 (deftest count-permutations.1
1912 (values (count-permutations 31 7)
1913 (count-permutations 1 1)
1914 (count-permutations 2 1)
1915 (count-permutations 2 2)
1916 (count-permutations 3 2)
1917 (count-permutations 3 1))
1918 13253058000
1919 1
1920 2
1921 2
1922 6
1923 3)
1924
1925 (deftest binomial-coefficient.1
1926 (alexandria:binomial-coefficient 1239 139)
1927 28794902202288970200771694600561826718847179309929858835480006683522184441358211423695124921058123706380656375919763349913245306834194782172712255592710204598527867804110129489943080460154)
1928
1929 ;; Exercise bignum case (at least on x86).
1930 (deftest binomial-coefficient.2
1931 (alexandria:binomial-coefficient 2000000000000 20)
1932 430998041177272843950422879590338454856322722740402365741730748431530623813012487773080486408378680853987520854296499536311275320016878730999689934464711239072435565454954447356845336730100919970769793030177499999999900000000000)
1933
1934 (deftest copy-stream.1
1935 (let ((data "sdkfjhsakfh weior763495ewofhsdfk sdfadlkfjhsadf woif sdlkjfhslkdfh sdklfjh"))
1936 (values (equal data
1937 (with-input-from-string (in data)
1938 (with-output-to-string (out)
1939 (alexandria:copy-stream in out))))
1940 (equal (subseq data 10 20)
1941 (with-input-from-string (in data)
1942 (with-output-to-string (out)
1943 (alexandria:copy-stream in out :start 10 :end 20))))
1944 (equal (subseq data 10)
1945 (with-input-from-string (in data)
1946 (with-output-to-string (out)
1947 (alexandria:copy-stream in out :start 10))))
1948 (equal (subseq data 0 20)
1949 (with-input-from-string (in data)
1950 (with-output-to-string (out)
1951 (alexandria:copy-stream in out :end 20))))))
1952 t
1953 t
1954 t
1955 t)
1956
1957 (deftest extremum.1
1958 (let ((n 0))
1959 (dotimes (i 10)
1960 (let ((data (shuffle (coerce (iota 10000 :start i) 'vector)))
1961 (ok t))
1962 (unless (eql i (extremum data #'<))
1963 (setf ok nil))
1964 (unless (eql i (extremum (coerce data 'list) #'<))
1965 (setf ok nil))
1966 (unless (eql (+ 9999 i) (extremum data #'>))
1967 (setf ok nil))
1968 (unless (eql (+ 9999 i) (extremum (coerce data 'list) #'>))
1969 (setf ok nil))
1970 (when ok
1971 (incf n))))
1972 (when (eql 10 (extremum #(100 1 10 1000) #'> :start 1 :end 3))
1973 (incf n))
1974 (when (eql -1000 (extremum #(100 1 10 -1000) #'> :key 'abs))
1975 (incf n))
1976 (when (eq nil (extremum "" (lambda (a b) (error "wtf? ~S, ~S" a b))))
1977 (incf n))
1978 n)
1979 13)
1980
1981 (deftest starts-with-subseq.string
1982 (starts-with-subseq "f" "foo" :return-suffix t)
1983 t
1984 "oo")
1985
1986 (deftest starts-with-subseq.vector
1987 (starts-with-subseq #(1) #(1 2 3) :return-suffix t)
1988 t
1989 #(2 3))
1990
1991 (deftest starts-with-subseq.list
1992 (starts-with-subseq '(1) '(1 2 3) :return-suffix t)
1993 t
1994 (2 3))
1995
1996 (deftest starts-with-subseq.start1
1997 (starts-with-subseq "foo" "oop" :start1 1)
1998 t
1999 nil)
2000
2001 (deftest starts-with-subseq.start2
2002 (starts-with-subseq "foo" "xfoop" :start2 1)
2003 t
2004 nil)
2005
2006 (deftest format-symbol.print-case-bound
2007 (let ((upper (intern "FOO-BAR"))
2008 (lower (intern "foo-bar"))
2009 (*print-escape* nil))
2010 (values
2011 (let ((*print-case* :downcase))
2012 (and (eq upper (format-symbol t "~A" upper))
2013 (eq lower (format-symbol t "~A" lower))))
2014 (let ((*print-case* :upcase))
2015 (and (eq upper (format-symbol t "~A" upper))
2016 (eq lower (format-symbol t "~A" lower))))
2017 (let ((*print-case* :capitalize))
2018 (and (eq upper (format-symbol t "~A" upper))
2019 (eq lower (format-symbol t "~A" lower))))))
2020 t
2021 t
2022 t)
2023
2024 (deftest iota.fp-start-and-complex-integer-step
2025 (equal '(#C(0.0 0.0) #C(0.0 2.0) #C(0.0 4.0))
2026 (iota 3 :start 0.0 :step #C(0 2)))
2027 t)
2028
2029 (deftest parse-ordinary-lambda-list.1
2030 (multiple-value-bind (req opt rest keys allowp aux keyp)
2031 (parse-ordinary-lambda-list '(a b c
2032 &optional o1 (o2 42) (o3 42 o3-supplied?)
2033 &key (k1) ((:key k2)) (k3 42 k3-supplied?))
2034 :normalize t)
2035 (and (equal '(a b c) req)
2036 (equal '((o1 nil nil)
2037 (o2 42 nil)
2038 (o3 42 o3-supplied?))
2039 opt)
2040 (equal '(((:k1 k1) nil nil)
2041 ((:key k2) nil nil)
2042 ((:k3 k3) 42 k3-supplied?))
2043 keys)
2044 (not allowp)
2045 (not aux)
2046 (eq t keyp)))
2047 t)