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 interpreters will delay lambda-list checks until
  23                ;; the lambda is actually called.
  24                (if (eq sb-ext:*evaluator-mode* :compile)
  25                    `(progn ,@args)
  26                    `(funcall ,@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))
  75
  76 (with-test (:name :aux-not-destructured)
  77   (assert-error (sb-c::parse-lambda-list
  78                  '(a &aux ((foo)))
  79                  :context 'destructuring-bind
  80                  :accept  (sb-int:lambda-list-keyword-mask 'destructuring-bind))))
  81
  82 (with-test (:name :exact-unparse)
  83   (labels ((round-trip (list)
  84              (multiple-value-bind (llks req opt rest keys aux)
  85                  (sb-c::parse-lambda-list
  86                   list
  87                   :accept (sb-c::lambda-list-keyword-mask 'destructuring-bind)
  88                   :context 'destructuring-bind)
  89                (sb-c::make-lambda-list llks nil req opt rest keys aux)))
  90            (try (list)
  91              (assert (equal list (round-trip list)))))
  92     (try '(a b . c))
  93     (try '(a b &rest r))
  94     (try '(a b &body b))
  95     (try '(a b &body b &key foo))))
  96
  97 (with-test (:name :fun-type-from-lambda-list)
  98   (assert (equal
  99            (sb-c::type-specifier
 100             (sb-c::ftype-from-lambda-list
 101              '(&key (size 1) color ((secret foo) 3 ssp) ((:what baz) nil)
 102                &allow-other-keys)))
 103            '(function (&key (:size t) (:color t) (secret t) (:what t)
 104                             &allow-other-keys) *))))
 105
 106 ;; CLHS 3.4.4 says
 107 ;; "&whole is followed by a single variable that is bound to the entire
 108 ;;  macro-call form; this is the value that the macro function receives
 109 ;;  as its first argument."
 110 ;;
 111 ;; but 3.4.4.1.2 says
 112 ;; "&whole - The next element is a destructuring pattern that matches
 113 ;; the entire form in a macro, or the entire subexpression at inner levels."
 114 ;;
 115 ;; So one paragraph says "a single variable" and the other "a pattern".
 116 ;;
 117 ;; If it can be a pattern, then it constrains the expected shape of input
 118 ;; in a way that can conflict with the remainder of the pattern.
 119 ;; e.g. Given (FOO (&WHOLE (BAZ BAR) X &OPTIONAL Y) MUM), would the
 120 ;; outer list's second element need to be a list that matches both
 121 ;; (BAZ BAR) and (X &OPTIONAL Y)?  Implementations disagree on this.
 122 ;;
 123 ;; Further 3.4.4 says "&whole can appear at any level of a macro
 124 ;; lambda list. At inner levels, the &whole variable is bound to the
 125 ;; corresponding part of the argument, as with &rest, but unlike &rest,
 126 ;; other arguments are also allowed."
 127 ;; This makes a strange implication that "&rest" does NOT allow
 128 ;; "other arguments", when clearly &REST can be followed by &KEY and
 129 ;; &AUX (if it means "formal" arguments), and followed by anything at
 130 ;; all if it means "actual" arguments. So it's not obvious from this
 131 ;; how &whole is supposed to be "unlike" &rest.
 132 ;;
 133 ;; And finally
 134 ;;   "The use of &whole does not affect the pattern of arguments specified."
 135 ;; which is is inconsistent in the case where you write
 136 ;; (&WHOLE (A B) ...) which certainly seems to require that the whole
 137 ;; form be exactly a 2-list. What it was trying to clarify - reasonably
 138 ;; in the case where &whole binds one symbol - is that
 139 ;;    (DEFMACRO MUMBLE (&WHOLE FOO) ...)
 140 ;; in terms of the pattern accepted, is exactly the same as
 141 ;;    (DEFMACRO MUMBLE () ...)
 142 ;; which means that MUMBLE accepts zero arguments.
 143 ;; This is a justified point because the equivalence of &WHOLE
 144 ;; and &REST at inner levels suggests that (&WHOLE FOO) actually means that
 145 ;; MUMBLE accepts anything when in fact it does not.
 146 ;;
 147 ;; To resolve these problems, we'll say that &WHOLE at the outermost level
 148 ;; of a macro can only bind one symbol, which fits the mental model that it
 149 ;; receives the input form and nothing but that.
 150 ;; Whoever uses &WHOLE with a non-symbol after it deserves a kick in the head.
 151
 152 (with-test (:name :destructuring-whole)
 153   (let* ((accept-inner
 154           (sb-int:lambda-list-keyword-mask 'destructuring-bind))
 155          (accept-outer
 156           (logior (sb-int:lambda-list-keyword-mask '&environment)
 157                   accept-inner)))
 158     (sb-c::parse-lambda-list '(&whole w a b x) :accept accept-outer)
 159     (sb-c::parse-lambda-list '(&whole (w) a b x) :accept accept-inner)
 160     (assert-error
 161      (sb-c::parse-lambda-list '(&whole 5 a b x) :accept accept-outer))
 162     (assert-error
 163      (sb-c::parse-lambda-list '(&whole (w) a b x) :accept accept-outer))))
 164
 165 ;; Unparsing a destructuring lambda list does not retain default values,
 166 ;; supplied-p variables, or &AUX.
 167 ;; This has a practical benefit of not saving source code unwittingly
 168 ;; in (X &OPTIONAL (A (MOAR-BIG-FN (DO-ALL-THE-THINGS (...)))))
 169 ;; as well as showing just what the lambda list expects as an interface.
 170 (with-test (:name :destructuring-parse/unparse)
 171   (flet ((try (input &optional (expect input))
 172            (let ((parse (sb-c::parse-ds-lambda-list input)))
 173              (assert (equal (sb-c::unparse-ds-lambda-list parse) expect)))))
 174
 175     (try '((a (b c)) . d)) ; parse/unparse undergoes no change
 176
 177     (try '(a &optional ((&optional)))) ; likewise
 178
 179     (try '(&optional . rest)) ; ... and even wackier
 180
 181     (try '(a (&rest foo) (&whole baz x y))
 182          '(a (&rest foo) (x y)))
 183
 184     (try '((&body foo) (&whole (a . d) x y) &aux)
 185          '((&body foo) (&whole (a . d) x y)))
 186
 187     (try '(&optional a ((bb1 bb2) (f)) (c 'c) (d 'd dsp) &aux foo (baz))
 188          '(&optional a ((bb1 bb2)) (c 'c) (d 'd)))
 189
 190     (try '(&key ((:bork (zook mook)) def bsp) (e 'e esp)
 191                 ((:name fred)) (color x csp))
 192          '(&key ((:bork (zook mook))) (e 'e) ((:name fred)) (color)))
 193
 194     (try '(x &optional (y) (((&whole (&whole w z . r) &body b) (c)) (def)))
 195          ;;                           ^ this &WHOLE variable is irrelevant
 196          ;;                   ^ but this one isn't
 197          '(x &optional (y) (((&whole (z . r) &body b) (c)))))
 198
 199     ;; Expanding a ds-bind of (((X))) re-conses the innermost list
 200     ;; list thrice, to generate code which produces three distinct
 201     ;; messages: "problem in (((X)))", "... in ((X))", "... in (X)"
 202     ;; This isn't great. Ideally the code should entail at most one
 203     ;; error message, but in general it's not easy to have a single point
 204     ;; at which the error is signaled, if you must already have pulled apart
 205     ;; the input to find the error. Thus, ds-bind expands into a sequence
 206     ;; of checks whether at each level, the structure is right.
 207     ;; In this limited case, it seems a particularly stupid technique.
 208     ;;
 209     ;; At any rate, the unparser memoizes intermediate results,
 210     ;; since the cost of doing that is virtually nothing.
 211     ;; This asserts that sharing works during re-construction.
 212     (let ((parse (sb-c::parse-ds-lambda-list '(((a)))))
 213           (cache (list nil)))
 214       (assert (eq (sb-c::unparse-ds-lambda-list parse cache)
 215                   (sb-c::unparse-ds-lambda-list parse cache))))))
 216
 217 (with-test (:name :macro-lambda-list)
 218   ;; This only parses the surface level, which suffices to check for
 219   ;; some edge cases at the toplevel of a macro lambda list.
 220   (flet ((parse (list)
 221            sb-c::
 222            (multiple-value-list
 223             (parse-lambda-list
 224              list :accept (logior (lambda-list-keyword-mask 'destructuring-bind)
 225                                   (lambda-list-keyword-mask '&environment))))))
 226     ;; The bitmasks of lambda-list-keywords differ, so don't compare them.
 227     (assert (equal (cdr (parse '(&environment e &rest rest)))
 228                    (cdr (parse '(&environment e . rest)))))
 229     (assert (equal (cdr (parse '(&whole w &rest r)))
 230                    (cdr (parse '(&whole w . r)))))
 231     (assert (equal (cdr (parse '(&whole w &environment e &rest r)))
 232                    (cdr (parse '(&whole w &environment e . r)))))
 233     (assert (equal (cdr (parse '(a b c &environment foo &rest rest)))
 234                    (cdr (parse '(a b c &environment foo . rest)))))
 235     (assert (equal (cdr (parse '(a b c &environment foo &body rest)))
 236                    (cdr (parse '(a b c &environment foo . rest)))))
 237     (assert-error (parse '(a b c &environment foo &rest r . rest)))
 238
 239     ;; lp# 707556
 240     (assert-error (parse '(a &key b &allow-other-keys c)))))
 241
 242 (with-test (:name :ds-lambda-list-symbols)
 243   (flet ((try (list expect)
 244            (assert (equal sb-c::(ds-lambda-list-variables
 245                                  (parse-ds-lambda-list list))
 246                          expect))))
 247     (try '(a ((b c))
 248            &rest (r1 r2)
 249            &key k1 (k2) (k3 'foo) (k4 'baz k4p) ((:boo (k5 k6)) '(1 2) k56p))
 250          '(a b c r1 r2 k1 k2 k3 k4 k4p k5 k6 k56p))
 251
 252     (try '(a &optional x (y) (z 'foo zp) ((w1 w2) (f)) &aux foo (bar) (baz 3))
 253          '(a x y z zp w1 w2 foo bar baz))))
 254
 255 (with-test (:name :ds-lambda-list-possible-mismatch-warning)
 256   (assert-signal (sb-c::parse-ds-lambda-list '(a &optional ((b c) 'foo)))
 257                  style-warning)
 258   ;; Suppose this meant: one required arg followed by one optional arg
 259   ;; which is a list of one required and one optional arg.
 260   ;; But it's accidentally missing a pair of disambiguating parentheses.
 261   (assert-signal (sb-c::parse-ds-lambda-list '(a &optional (b &optional c)))
 262                  style-warning)
 263   ;; Similarly...
 264   (assert-signal (sb-c::parse-ds-lambda-list '(a &optional (b c &key)))
 265                  style-warning))
 266
 267 (with-test (:name :ds-bind-list-checkers)
 268   (labels ((gen-check (lambda-list macro-context)
 269              (sb-c::emit-ds-bind-check (sb-c::parse-ds-lambda-list lambda-list)
 270                                        :ignore macro-context nil))
 271            (try (winp lambda-list input)
 272              (let ((check (gen-check lambda-list nil)))
 273                (if winp
 274                    (apply (car check) input (cddr check))
 275                    (assert-error (apply (car check) input (cddr check)))))))
 276     (try t '(a b . rest) '(1 2))
 277     (try t '(a b . rest) '(1 2 3))
 278     (try t '(a b . rest) '(1 2 . foo))
 279     (try nil '(a b . rest) '(1))
 280     (try t '(a &optional b . rest) '(1 2))
 281     (try nil '(a &key b) '(1 :b)) ; odd
 282     (try nil '(a &key b) '(1 :b . bar)) ; dotted
 283     (try nil '(a &key b) '(1 :b bar . baz)) ; dotted
 284     (try t '(a &key b) '(1 :b bar :allow-other-keys nil))
 285
 286     (let ((check (gen-check '(bar &key ((secret v)))
 287                             '(:macro whatever . define-compiler-macro))))
 288       (apply (car check) '(a secret 3) (cddr check))
 289       (assert-signal (apply (car check) '(a secret 3) (cddr check))
 290                      sb-c::compiler-macro-keyword-problem))))
 291
 292 ;; The same lambda lists and test inputs are each run two different ways.
 293 (macrolet ((with-test-ll ((name lambda-list) &body body)
 294              `(with-test (:name (:ds-bind-shape ,name))
 295                 (let ((fun
 296                        (lambda (args)
 297                          (sb-int:binding*
 298                              ,(sb-c::expand-ds-bind lambda-list 'args nil 'the)
 299                            (list ,@(sb-c::ds-lambda-list-variables
 300                                     (sb-c::parse-ds-lambda-list lambda-list))))))
 301                       (ast (sb-c::meta-abstractify-ds-lambda-list
 302                             (sb-c::parse-ds-lambda-list ',lambda-list))))
 303                   ,@body)))
 304            (win (x &optional expect)
 305              `(progn (assert (sb-c::ds-lambda-list-match-p ,x ast))
 306                      ,(if expect
 307                           `(assert (equal (funcall fun ,x) ,expect))
 308                           `(funcall fun ,x)))) ; don't crash is all
 309            (lose (x)
 310              `(progn (assert (not (sb-c::ds-lambda-list-match-p ,x ast)))
 311                      (assert-error (funcall fun ,x)))))
 312
 313   (with-test-ll (:want-0-args ()) ; this only allows NIL as its input
 314     (win '())
 315     (lose 'foo)
 316     (lose '(a)))
 317
 318   (with-test-ll (:want-1-arg (a))
 319     (lose '())
 320     (lose 'foo)
 321     (win '(a))
 322     (lose '(a . b))
 323     (lose '(a b)))
 324
 325   (with-test-ll (:want-1-or-2-args (a &optional b))
 326     (lose '())
 327     (lose 'foo)
 328     (win '(a))
 329     (lose '(a . b))
 330     (win '(a b))
 331     (lose '(a b . c))
 332     (lose '(a b c)))
 333
 334   (with-test-ll (:want-3-args (a b c))
 335     (lose '())
 336     (lose '(a))
 337     (lose '(a b))
 338     (lose '(a b . c))
 339     (win '(a b c))
 340     (lose '(a b c . d))
 341     (lose '(a b c d)))
 342
 343   (with-test-ll (:want-3-or-4-args (a b c &optional d))
 344     (lose '())
 345     (lose '(a))
 346     (lose '(a b))
 347     (lose '(a b . c))
 348     (win '(a b c))
 349     (lose '(a b c . d))
 350     (win '(a b c d))
 351     (lose '(a b c d . e))
 352     (lose '(a b c d ee)))
 353
 354   (with-test-ll (:want-3-or-more-args (a b c &optional d . r))
 355     (lose '())
 356     (lose '(a))
 357     (lose '(a b))
 358     (lose '(a b . c))
 359     (win '(a b c))
 360     (lose '(a b c . d))
 361     (win '(a b c d))
 362     (win '(a b c d . e))
 363     (win '(a b c d ee)))
 364
 365   (with-test-ll (:destructured-rest (a b &rest (c d)))
 366     (lose '())
 367     (lose '(a b))
 368     (lose '(a b . c))
 369     (lose '(a b c . d))
 370     (win '(a b c d))
 371     (lose '(a b c d . e))
 372     (lose '(a b c d ee)))
 373
 374   (with-test-ll (:hairy-1 ((a) ((b . c)) &optional ((x y) '(vx vy))))
 375     (win '((1) ((2 . whatever)) (3 4)))
 376     (win '((1) ((2 . whatever)) (3 4)))
 377     (lose '((1) ((2)) (3))))
 378
 379   (with-test-ll (:hairy-2 ((a) ((b . c)) &optional ((x &optional y) '(f))))
 380     (win '((1) ((2 . whatever)) (3)))
 381     (win '((1) ((2 . whatever))))
 382     (lose '((1) ((2 . whatever)) 3)))
 383
 384   ;; This destructuring &WHOLE pattern demands at least 2 args,
 385   ;; despite that the containing pattern otherwise accepts 0 or more.
 386   (with-test-ll (:destructured-whole (&whole (a b . c) &optional x &rest y))
 387     (lose '())
 388     (lose '(a))
 389     (lose '(a . b))
 390     (win '(a b))
 391     (win '(a b c)))
 392
 393   (with-test-ll (:destructured-key (a b &rest r
 394                                       &key ((:point (x y &optional z))
 395                                             (list 'foo 'bar))))
 396     (lose '(a b . foo))
 397     (win '(a b :point (1 2)))
 398     (lose '(a b :point (1 2 . 3)))
 399     (win '(a b :point (1 2 3)))
 400     (lose '(a b :point (1 2 3 4)))
 401     (lose '(a b :point (1 2 3) :baz 9))
 402     (win '(a b :point (1 2 3) :baz 9 :allow-other-keys t))
 403     (win '(a b :point (1 2 3) :baz 9 :allow-other-keys t
 404            :allow-other-keys nil)))
 405
 406   ;; This bizarro lambda lists expects that if you give the :FRUITS keyword,
 407   ;; then its value is NIL, because it has to match a lambda list that
 408   ;; accepts exactly zero required arguments, zero optionals, and no &REST.
 409   (with-test-ll (:fruity (&key ((:fruits (&optional)))))
 410     (win '())
 411     (lose 'a)
 412     (lose '(a))
 413     (lose '(a . b))
 414     (lose '(:fruits))
 415     (lose '(:fruits 3))
 416     (lose '(:fruits (3)))
 417     (win '(:fruits nil)))
 418
 419   ;; Test an EXPAND-DS-BIND that is hairier than you should ever write.
 420   (with-test-ll (:insane-hair
 421                  ((a ((b) &key)) &optional (((c &rest r)) '((wat)) csp)
 422                   &aux (bork 'end)))
 423     (win '((1 ((2)))) '(1 2 wat nil nil end))
 424     (win '((1 ((2) :size 3 :allow-other-keys t)))
 425          '(1 2 wat nil nil end))
 426     (win '((1 ((2))) ((3 . more))) '(1 2 3 more t end))
 427     (lose '((1 ((2 3)))))
 428     (lose '((1 ((2) 3))))
 429     (lose '((1 ((2)) 3)))
 430     (lose '((1 ((2))) wat))
 431     (lose '((1 ((2))) (wat))))
 432   )
 433
 434 (with-test (:name :arg-count-error-tail-calls-error)
 435  (assert
 436   (null
 437    (block found
 438      (handler-bind ((error
 439                      (lambda (c)
 440                        (declare (ignore c))
 441                        (return-from found
 442                          (assoc 'sb-c::ds-bind-error
 443                                 (sb-debug::list-backtrace))))))
 444        (sb-c::ds-bind-error '(foo) 2 3 '((:macro baz . deftype))))))))
 445
 446 (with-test (:name :destructuring-optional/key-warn-once-only)
 447   (let ((count 0))
 448     (handler-bind ((warning (lambda (c) (incf count) (muffle-warning c))))
 449       (macroexpand-1
 450        '(defmacro defx (name ll &optional (types '*) &key node) 1)))
 451     (assert (= count 1))))
 452
 453 (with-test (:name :silent-pcl-internals)
 454   (assert-no-signal
 455    (sb-int:parse-lambda-list
 456     '(sb-pcl::.pv. sb-pcl::.next-method-call. self &optional o &key k
 457        &allow-other-keys))))