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