(defun print-destructuring-bind-error (condition stream)
  (format stream "Failed to destructure ~S against ~S~:[.~;:~%~:*~A~]"
          (lambda-list condition) (expression condition) (reason condition)))

(define-condition destructuring-bind-error (error)
  ((%lambda-list :reader lambda-list
                 :initarg :lambda-list
                 :initform (error "Must provide LAMBDA-LIST."))
   (%expression :reader expression
                :initarg :expression
                :initform (error "Must provide EXPRESSION."))
   (%reason :reader reason
            :initarg :reason
            :initform nil))
  (:documentation "Condition type responsible for destructuring errors signaled
in DESTRUCTURING-BIND*.")
  (:report print-destructuring-bind-error))

(defun bind-modify-lambda-list (lambda-list gensym)
  (flet ((modify (elt)
           (cond ((atom elt) elt)
                 ((= 1 (length elt)) elt)
                 (t (list* (car elt)
                           `(prog2 (setf ,gensym t) ,(cadr elt)
                              (setf ,gensym nil))
                           (cddr elt))))))
    (loop with modifyp = nil
          for elt in lambda-list
          collect (modify elt)
          if (and (member elt lambda-list-keywords)
                  (member elt '(&key &optional)))
            do (setf modifyp t)
          else if (member elt lambda-list-keywords)
                 do (setf modifyp nil))))

(defmacro destructuring-bind* (lambda-list expression &body body)
  "Like DESTRUCTURING-BIND, except destructuring errors are signaled as
instances of condition type DESTRUCTURING-BIND-ERROR."
  (with-gensyms (in-body handle condition)
    (let ((new-lambda-list (bind-modify-lambda-list lambda-list in-body)))
      `(let (,in-body)
         (flet ((,handle (,condition)
                  (unless ,in-body
                    (error (make-condition 'destructuring-bind-error
                                           :lambda-list ',lambda-list
                                           :expression ',expression
                                           :reason ,condition)))))
           (handler-bind ((error #',handle))
             (destructuring-bind ,new-lambda-list
                 (progn (setf ,in-body t) ,expression)
               (setf ,in-body t) nil
               (locally ,@body))))))))