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