1 ;;;; lambda-list parsing tests with no side-effects
3 ;;;; This software is part of the SBCL system. See the README file for
6 ;;;; While most of SBCL is derived from the CMU CL system, the test
7 ;;;; files (like this one) were written from scratch after the fork
10 ;;;; This software is in the public domain and is provided with
11 ;;;; absolutely no warranty. See the COPYING and CREDITS files for
12 ;;;; more information.
14 (let ((*macroexpand-hook
*
16 (lambda (fun form env
)
17 (handler-bind ((error (lambda (c)
18 (when (eq 'destructuring-bind
(car form
))
19 (throw 'd-b-error c
)))))
20 (funcall fun form env
))))))
21 (macrolet ((maybe-funcall (&rest args
)
22 ;; The evaluator will delay lambda-list checks until
23 ;; the lambda is actually called.
24 (if (eq sb-ext
:*evaluator-mode
* :interpret
)
29 (multiple-value-bind (result error
)
30 (ignore-errors (maybe-funcall (eval `(lambda ,',ll
'ok
))))
31 (unless (and (not result
) error
)
32 (error "No error from lambda ~S." ',ll
)))
35 (eval `(lambda (x) (destructuring-bind ,',ll x
'ok
)))
37 (error "No error from d-b ~S." ',ll
)))))
38 (error-p (&aux
(foo 1) &aux
(bar 2)))
39 (error-p (&aux
(foo 1) &key bar
))
40 (error-p (&aux
(foo 1) &optional bar
))
41 (error-p (&aux
(foo 1) &rest bar
))
42 (error-p (&key foo
&allow-other-keys
&allow-other-keys
))
43 (error-p (&key foo
&key bar
))
44 (error-p (&key foo
&optional bar
))
45 (error-p (&key foo
&rest bar
))
46 (error-p (&optional foo
&optional bar
))
47 (error-p (&rest foo
&rest bar
))
48 (error-p (&rest foo
&optional bar
))))
50 (with-test (:name
:supplied-p-order
)
52 (assert (eql ((lambda (&key
(x * *)) () x
)) 10))
53 (assert (eql ((lambda (&key
(y * *) (x *)) () x
) :y
1) t
))
54 (assert (eql ((lambda (&key
(x *) (y * *)) () x
) :y
1) 10))
56 (assert (eql (destructuring-bind (&key
(x * *)) () x
) 10))
57 (assert (eql (destructuring-bind (&key
(y * *) (x *)) '(:y
1) x
) t
))
58 (assert (eql (destructuring-bind (&key
(x *) (y * *)) '(:y
1) x
) 10))
60 (assert (eql ((lambda (&optional
(x * *)) () x
)) 10))
61 (assert (eql ((lambda (&optional
(y * *) (x *)) () x
) 1) t
))
62 (assert (eql ((lambda (&optional
(x *) (y * *)) () x
)) 10))
64 (assert (eql (destructuring-bind (&optional
(x * *)) () x
) 10))
65 (assert (eql (destructuring-bind (&optional
(y * *) (x *)) '(1) x
) t
))
66 (assert (eql (destructuring-bind (&optional
(x *) (y * *)) () x
) 10))))
68 (with-test (:name
:supplied-p-order
)
70 (compile nil
'(lambda ()
71 (destructuring-bind (&optional
(x nil xp
)) '()
72 (declare (ignore x xp
))