Add a few more control-flow tests
| author |
Steve Losh <steve@stevelosh.com> |
| date |
Sun, 17 Jun 2018 16:50:40 -0700 |
| parents |
0dd5e94be86b
|
| children |
7db631c1cf60
|
| branches/tags |
(none) |
| files |
src/control-flow.lisp test/control-flow.lisp |
Changes
--- a/src/control-flow.lisp Sun Jun 17 16:28:57 2018 -0700
+++ b/src/control-flow.lisp Sun Jun 17 16:50:40 2018 -0700
@@ -473,10 +473,14 @@
; 2 11
"
- (if (null ranges)
- `(progn ,@body)
- (destructuring-bind (var from below) (first ranges)
- `(loop :for ,var :from ,from :below ,below
- :do (do-range ,(rest ranges) ,@body)))))
+ (assert (not (null ranges)) ()
+ "Ranges to iterate in DO-RANGE must not be null.")
+ (recursively ((ranges ranges))
+ (if (null ranges)
+ `(progn ,@body)
+ (destructuring-bind (var from below) (first ranges)
+ `(loop
+ :for ,var :from ,from :below ,below
+ :do ,(recur (rest ranges)))))))
--- a/test/control-flow.lisp Sun Jun 17 16:28:57 2018 -0700
+++ b/test/control-flow.lisp Sun Jun 17 16:50:40 2018 -0700
@@ -2,169 +2,247 @@
(define-test when-let
- (locally
- #+sbcl (declare (sb-ext:muffle-conditions sb-ext:code-deletion-note))
- (is (eql :foo (when-let ()
- :foo)))
- (is (eql 1 (when-let ((a 1))
- a)))
- (is (eql 3 (when-let ((a 1)
+ #+sbcl (declare (sb-ext:muffle-conditions sb-ext:code-deletion-note))
+ (is (eql :foo (when-let ()
+ :foo)))
+ (is (eql 1 (when-let ((a 1))
+ a)))
+ (is (eql 3 (when-let ((a 1)
+ (b 2))
+ (+ a b))))
+ (is (eql nil (when-let ((a nil)
(b 2))
(+ a b))))
- (is (eql nil (when-let ((a nil)
- (b 2))
- (+ a b))))
- (is (eql nil (when-let ((a 1)
- (b nil))
- (+ a b))))
- (is (eql nil (when-let ((a 1)
- (b nil)
- (c 3))
- (+ a b c))))
- (let (x)
- (is (eql nil (when-let ((a (progn (push 1 x) 1))
- (b (progn (push 2 x) nil))
- (c (progn (push 3 x) 3)))
- (declare (type fixnum a b c))
- (push :body x)
- (+ a b c))))
- (is (equal '(2 1) x)))
- (let (x)
- (is (eql 6 (when-let ((a (progn (push 1 x) 1))
- (b (progn (push 2 x) 2))
+ (is (eql nil (when-let ((a 1)
+ (b nil))
+ (+ a b))))
+ (is (eql nil (when-let ((a 1)
+ (b nil)
+ (c 3))
+ (+ a b c))))
+ (let (x)
+ (is (eql nil (when-let ((a (progn (push 1 x) 1))
+ (b (progn (push 2 x) nil))
(c (progn (push 3 x) 3)))
(declare (type fixnum a b c))
(push :body x)
(+ a b c))))
- (is (equal '(:body 3 2 1) x)))))
+ (is (equal '(2 1) x)))
+ (let (x)
+ (is (eql 6 (when-let ((a (progn (push 1 x) 1))
+ (b (progn (push 2 x) 2))
+ (c (progn (push 3 x) 3)))
+ (declare (type fixnum a b c))
+ (push :body x)
+ (+ a b c))))
+ (is (equal '(:body 3 2 1) x))))
(define-test when-let*
- (locally
- #+sbcl (declare (sb-ext:muffle-conditions sb-ext:code-deletion-note))
- (is (eql :foo (when-let* ()
- :foo)))
- (is (eql 1 (when-let* ((a 1))
- a)))
- (is (eql 2 (when-let* ((a 1)
- (b (1+ a)))
- b)))
- (is (eql nil (when-let* ((a nil)
- (b 2))
- (+ a b))))
- (is (eql nil (when-let* ((a 1)
- (b nil))
- (+ a b))))
- (is (eql nil (when-let* ((a 1)
- (b nil)
- (c (+ 2 a)))
- (+ a b c))))
- (let (x)
- (is (eql nil (when-let* ((a (progn (push 1 x) 1))
- (b (progn (push 2 x) nil))
- (c (progn (push 3 x) 3)))
- (push :body x)
- (+ a b c))))
- (is (equal '(2 1) x)))
- (let (x)
- (is (eql 6 (when-let* ((a (progn (push 1 x) 1))
- (b (progn (push 2 x) 2))
+ #+sbcl (declare (sb-ext:muffle-conditions sb-ext:code-deletion-note))
+ (is (eql :foo (when-let* ()
+ :foo)))
+ (is (eql 1 (when-let* ((a 1))
+ a)))
+ (is (eql 2 (when-let* ((a 1)
+ (b (1+ a)))
+ b)))
+ (is (eql nil (when-let* ((a nil)
+ (b 2))
+ (+ a b))))
+ (is (eql nil (when-let* ((a 1)
+ (b nil))
+ (+ a b))))
+ (is (eql nil (when-let* ((a 1)
+ (b nil)
+ (c (+ 2 a)))
+ (+ a b c))))
+ (let (x)
+ (is (eql nil (when-let* ((a (progn (push 1 x) 1))
+ (b (progn (push 2 x) nil))
(c (progn (push 3 x) 3)))
(push :body x)
(+ a b c))))
- (is (equal '(:body 3 2 1) x)))))
+ (is (equal '(2 1) x)))
+ (let (x)
+ (is (eql 6 (when-let* ((a (progn (push 1 x) 1))
+ (b (progn (push 2 x) 2))
+ (c (progn (push 3 x) 3)))
+ (push :body x)
+ (+ a b c))))
+ (is (equal '(:body 3 2 1) x))))
(define-test if-let
- (locally
- #+sbcl (declare (sb-ext:muffle-conditions sb-ext:code-deletion-note))
- (is (eql :foo (if-let ()
- :foo
- :bar)))
+ #+sbcl (declare (sb-ext:muffle-conditions sb-ext:code-deletion-note))
+ (is (eql :foo (if-let ()
+ :foo
+ :bar)))
- (is (eql 1 (if-let ((a 1))
- a
- :bar)))
- (is (eql :bar (if-let ((a nil))
- a
- :bar)))
- (is (eql 3 (if-let ((a 1)
- (b 2))
- (+ a b)
- :bar)))
- (is (eql :bar (if-let ((a nil)
- (b 2))
- (+ a b)
- :bar)))
- (is (eql :bar (if-let ((a 1)
- (b nil))
- (+ a b)
- :bar)))
- (is (eql :bar (if-let ((a 1)
- (b nil)
- (c 3))
+ (is (eql 1 (if-let ((a 1))
+ a
+ :bar)))
+ (is (eql :bar (if-let ((a nil))
+ a
+ :bar)))
+ (is (eql 3 (if-let ((a 1)
+ (b 2))
+ (+ a b)
+ :bar)))
+ (is (eql :bar (if-let ((a nil)
+ (b 2))
+ (+ a b)
+ :bar)))
+ (is (eql :bar (if-let ((a 1)
+ (b nil))
+ (+ a b)
+ :bar)))
+ (is (eql :bar (if-let ((a 1)
+ (b nil)
+ (c 3))
+ (+ a b c)
+ :bar)))
+ (let (x)
+ (is (eql :bar (if-let ((a (progn (push 1 x) 1))
+ (b (progn (push 2 x) nil))
+ (c (progn (push 3 x) 3)))
+ (declare (type fixnum a b c))
(+ a b c)
:bar)))
- (let (x)
- (is (eql :bar (if-let ((a (progn (push 1 x) 1))
- (b (progn (push 2 x) nil))
- (c (progn (push 3 x) 3)))
- (declare (type fixnum a b c))
- (+ a b c)
- :bar)))
- (is (equal '(2 1) x)))
- (let (x)
- (is (eql 6 (if-let ((a (progn (push 1 x) 1))
- (b (progn (push 2 x) 2))
- (c (progn (push 3 x) 3)))
- (declare (type fixnum a b c))
- (+ a b c)
- :bar)))
- (is (equal '(3 2 1) x)))))
+ (is (equal '(2 1) x)))
+ (let (x)
+ (is (eql 6 (if-let ((a (progn (push 1 x) 1))
+ (b (progn (push 2 x) 2))
+ (c (progn (push 3 x) 3)))
+ (declare (type fixnum a b c))
+ (+ a b c)
+ :bar)))
+ (is (equal '(3 2 1) x))))
(define-test if-let*
- (locally
- #+sbcl (declare (sb-ext:muffle-conditions sb-ext:code-deletion-note))
- (is (eql :foo (if-let* ()
- :foo
- :bar)))
+ #+sbcl (declare (sb-ext:muffle-conditions sb-ext:code-deletion-note))
+ (is (eql :foo (if-let* ()
+ :foo
+ :bar)))
- (is (eql 1 (if-let* ((a 1))
- a
- :bar)))
- (is (eql :bar (if-let* ((a nil))
- a
- :bar)))
- (is (eql 3 (if-let* ((a 1)
- (b (1+ a)))
- (+ a b)
- :bar)))
- (is (eql :bar (if-let* ((a nil)
- (b 2))
- (+ a b)
- :bar)))
- (is (eql :bar (if-let* ((a 1)
- (b nil))
- (+ a b)
- :bar)))
- (is (eql :bar (if-let* ((a 1)
- (b nil)
- (c 3))
+ (is (eql 1 (if-let* ((a 1))
+ a
+ :bar)))
+ (is (eql :bar (if-let* ((a nil))
+ a
+ :bar)))
+ (is (eql 3 (if-let* ((a 1)
+ (b (1+ a)))
+ (+ a b)
+ :bar)))
+ (is (eql :bar (if-let* ((a nil)
+ (b 2))
+ (+ a b)
+ :bar)))
+ (is (eql :bar (if-let* ((a 1)
+ (b nil))
+ (+ a b)
+ :bar)))
+ (is (eql :bar (if-let* ((a 1)
+ (b nil)
+ (c 3))
+ (+ a b c)
+ :bar)))
+ (let (x)
+ (is (eql :bar (if-let* ((a (progn (push 1 x) 1))
+ (b (progn (push 2 x) nil))
+ (c (progn (push 3 x) 3)))
+ (declare (type fixnum a b c))
(+ a b c)
:bar)))
- (let (x)
- (is (eql :bar (if-let* ((a (progn (push 1 x) 1))
- (b (progn (push 2 x) nil))
- (c (progn (push 3 x) 3)))
- (declare (type fixnum a b c))
- (+ a b c)
- :bar)))
- (is (equal '(2 1) x)))
- (let (x)
- (is (eql 6 (if-let* ((a (progn (push 1 x) 1))
- (b (progn (push 2 x) 2))
- (c (progn (push 3 x) 3)))
- (declare (type fixnum a b c))
- (+ a b c)
- :bar)))
- (is (equal '(3 2 1) x)))))
+ (is (equal '(2 1) x)))
+ (let (x)
+ (is (eql 6 (if-let* ((a (progn (push 1 x) 1))
+ (b (progn (push 2 x) 2))
+ (c (progn (push 3 x) 3)))
+ (declare (type fixnum a b c))
+ (+ a b c)
+ :bar)))
+ (is (equal '(3 2 1) x))))
+
+
+(define-test do-range
+ #+sbcl (declare (sb-ext:muffle-conditions sb-ext:code-deletion-note))
+ (is (equal '(1 2 3)
+ (gathering
+ (do-range ((x 1 4))
+ (gather x)))))
+ (is (equal '()
+ (gathering
+ (do-range ((x 1 1))
+ (gather x)))))
+ (is (equal '((1 . 1) (1 . 2) (1 . 3)
+ (2 . 1) (2 . 2) (2 . 3))
+ (gathering
+ (do-range ((x 1 3)
+ (y 1 4))
+ (gather (cons x y)))))))
+
+(define-test do-repeat
+ #+sbcl (declare (sb-ext:muffle-conditions sb-ext:code-deletion-note))
+ (is (equal '(1 1 1)
+ (gathering
+ (do-repeat 3
+ (gather 1)))))
+ (is (equal '()
+ (gathering
+ (do-repeat 0
+ (gather 1))))))
+
+(define-test gathering
+ #+sbcl (declare (sb-ext:muffle-conditions sb-ext:code-deletion-note))
+ (is (equal '(1 2 3)
+ (gathering
+ (gather 1)
+ (gather 2)
+ (gather 3))))
+ (is (equal '()
+ (gathering
+ 1))))
+
+(define-test gathering-vector
+ #+sbcl (declare (sb-ext:muffle-conditions sb-ext:code-deletion-note))
+ (is (equalp #(1 2 3)
+ (gathering-vector ()
+ (gather 1)
+ (gather 2)
+ (gather 3))))
+ (is (equalp #()
+ (gathering-vector ()
+ 1))))
+
+
+(define-test when-found
+ (let ((h (make-hash-table)))
+ (setf (gethash 'foo h) 1)
+ (is (equal 2 (when-found (x (gethash 'foo h))
+ (1+ x))))
+ (is (equal nil (when-found (x (gethash 'bar h))
+ (1+ x))))))
+
+(define-test if-found
+ (let ((h (make-hash-table)))
+ (setf (gethash 'foo h) 1)
+ (is (equal 2 (if-found (x (gethash 'foo h))
+ (1+ x)
+ :no)))
+ (is (equal :no (if-found (x (gethash 'bar h))
+ (1+ x)
+ :no)))))
+
+
+(define-test nest
+ (is (equal '(1 2 1 2)
+ (nest
+ (let ((a 1)
+ (b 2)))
+ (let ((c a)
+ (d b)))
+ (list a b c d)))))
+
+