tests/lambda-list.pure.lisp

   1 ;;;; lambda-list parsing tests with no side-effects
   2
   3 ;;;; This software is part of the SBCL system. See the README file for
   4 ;;;; more information.
   5 ;;;;
   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
   8 ;;;; from CMU CL.
   9 ;;;;
  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.
  13
  14 (let ((*macroexpand-hook*
  15        (compile nil
  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)
  25                    `(funcall ,@args)
  26                    `(progn ,@args)))
  27              (error-p (ll)
  28                `(progn
  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)))
  33                   (catch 'd-b-error
  34                     (maybe-funcall
  35                      (eval `(lambda (x) (destructuring-bind ,',ll x 'ok)))
  36                      nil)
  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))))
  49
  50 (with-test (:name :supplied-p-order)
  51   (let ((* 10))
  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))
  55
  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))
  59
  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))
  63
  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))))
  67
  68 (with-test (:name :supplied-p-order)
  69   (assert-no-signal
  70    (compile nil '(lambda ()
  71                   (destructuring-bind (&optional (x nil xp)) '()
  72                     (declare (ignore x xp))
  73                     nil)))
  74    warning))