tests/destructure.impure.lisp

   1 ;;;; tests, with side effects, of DESTRUCTURING-BIND-ish functionality
   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 ;;; In sbcl-1.0.7.8, the printer for the ERROR condition signalled from
  15 ;;;   (DESTRUCTURING-BIND (...) 1 ...)
  16 ;;; contained the implicit assumption that the bad datum was a list,
  17 ;;; so that attempting to print the condition caused a new error.
  18 (defun frob-1-0-7-8 (x)
  19   (destructuring-bind (y . z) x (list y z)))
  20 (with-test (:name (destructuring-bind :dotted-list error :printable 1))
  21   (let ((error (nth-value 1 (ignore-errors (frob-1-0-7-8 1)))))
  22     ;; Printing ERROR shouldn't cause an error.
  23     (assert (search "(Y . Z)" (princ-to-string error)))))
  24
  25 (with-test (:name (destructuring-bind :dotted-list error :printable 2))
  26   (let ((c (make-condition 'sb-kernel::arg-count-error
  27                            :args 'x
  28                            :lambda-list '(a . b)
  29                            :minimum 1
  30                            :maximum nil
  31                            :name 'foo
  32                            :kind 'macro)))
  33     (assert (search "(A . B)" (write-to-string c :escape nil))))
  34   (let ((c (make-condition 'sb-kernel::arg-count-error
  35                            :args '(x . y)
  36                            :lambda-list '(a b . c)
  37                            :minimum 1
  38                            :maximum nil
  39                            :name 'foo
  40                            :kind 'macro)))
  41     (assert (search "(A B . C)" (write-to-string c :escape nil)))))