;; -*- Mode: Lisp; -*-
;; ---------------------------------------------------------------------------
;;     Title: DESTRUCTURING-BIND
;;   Created: 2024-08-15
;;    Author: Gilbert Baumann <gilbert@bauhh.de>
;;   License: MIT
;; ---------------------------------------------------------------------------
;;  (c) copyright 2024 by Gilbert Baumann

;;  Permission is hereby granted, free of charge, to any person obtaining
;;  a copy of this software and associated documentation files (the
;;  "Software"), to deal in the Software without restriction, including
;;  without limitation the rights to use, copy, modify, merge, publish,
;;  distribute, sublicense, and/or sell copies of the Software, and to
;;  permit persons to whom the Software is furnished to do so, subject to
;;  the following conditions:
;; 
;;  The above copyright notice and this permission notice shall be
;;  included in all copies or substantial portions of the Software.
;; 
;;  THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
;;  EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
;;  MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. 
;;  IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY
;;  CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
;;  TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
;;  SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.

(defpackage :ds
  (:use :cl)
  (:export #:destructuring-bind)
  (:shadow #:destructuring-bind))

(in-package :ds)

;; This is an implementation of DESTRUCTURING-BIND. The foremost aim was
;; to get this right. Further we use little of the more fancy parts of
;; Common Lisp. On top of that we made some effort to make this
;; reasonable fast. In fact keyword argument parsing is faster than with
;; any other Lisp I tested.

;; Testcase and a teeny tiny benchmark below.

;;; Notes

;; The overall strategy is to expand DESTRUCTURING-BIND to just one LET*. This
;; way we have no trouble with declarations. In general with ANSI-CL it is not
;; possible to tell whether a declaration like (DECLARE (FOO X)) is a
;; declaration that applies to the X lexical variable or not. And therefore we
;; cannot nest LETs and this would involve moving declarations.

;; Further, ANSI-CL is vague about whether duplicate variable names are
;; allowed in lambda lists or in DESTRUCTURING-BIND for that matter. And
;; whether declarations would apply to only one of the bound variables or to
;; all of them. By using LET* we delegate these issues.

;; Should (&key &allow-other-keys) check for keys being symbols? CCL does. No
;; other does.

;; Further we keep this as self-contained as possible and are conservative on
;; our use of the language. The idea is that you won't need too much to bring
;; this up in some other Lisp or a Common Lisp under construction.

;;; Future

;; I want to extend this into a general parameter parser to correctly parse
;; the other kind of lambda lists and parameters like ordinary lambda lists,
;; the DEFTYPE variant and all the others.

;; Also I want that we can pass in a function that is a generator returning
;; forms for: the argument list ended, the next argument, a generator for the
;; rest. The idea is that this way we can optimize cases when the form of the
;; argument list is something quoted or something like e.g. (LIST X Y) or
;; (LIST* X Y R). This usually would be the task of a sufficiently smart
;; compiler, but it has not been written yet.

(defmacro destructuring-bind (lambda-list expr &body body &environment env)
  (multiple-value-bind (bindings declarations)
      (destructuring-bind-1 lambda-list expr env)
    `(let* (,@bindings)
       (declare ,@declarations)
       ,@body)))

(eval-when (:compile-toplevel :load-toplevel :execute)

  (defun destructuring-bind-1 (lambda-list whole env
                               &aux binds
                                    declarations
                                    bounds
                                    duplicates
                                    (*gensym-counter* 1))
    (labels
        ((bind-one (q w)
           "Binds the pattern /q/ to the value /w/."
           (cond ((listp q)
                  ;; Note that this includes NIL which is taken as a pattern.
                  (bind-list q w))
                 (t
                  (ensure-var q)
                  (push (list q w) binds))))
         ;;
         (bind-list (q w &aux (dotted-ok t))
           "Binds the lambda list /q/ to the value /w/."
           ;; Optional &WHOLE
           (when (and (consp q) (eq (car q) '&whole))
             (pop q)                    ;the &WHOLE
             (unless (consp q) (error "Bad lambda list: ~S" lambda-list))
             (bind-one (pop q) w))
           ;; required arguments
           (do () ((not (and (consp q) (not (member (car q) lambda-list-keywords)))))
             (let* ((p (pop q))
                    (g (gensym))
                    (h (gensym)))
               (push (list g `(if (consp ,w)
                                  (car (the cons ,w))
                                  (error "Too few arguments")))
                     binds)
               (push (list h `(cdr (the cons ,w))) binds)
               (bind-one p g)
               (setq w h)))
           ;; optional arguments
           (when (and (consp q) (eq (car q) '&optional))
             ;; | Each following element is a variable or a list of a destructuring
             ;; | pattern, a default value form, and a supplied-p variable.
             ;;
             ;; This implies that (&optional nil) names a variable, while (&optional
             ;; (nil)) names a pattern.
             ;;
             (pop q)
             (do () ((not (and (consp q) (not (member (car q) lambda-list-keywords)))))
               (multiple-value-bind (pattern init svar)
                   (parse-optional-parameter (pop q))
                 (let* ((g (gensym))
                        (g? (gensym))
                        (h (gensym)))
                   (push (list g? `(not (endp ,w))) binds)
                   (push (list g `(if ,g? (car (the cons ,w)) ,init)) binds)
                   (push (list h `(if ,g? (cdr (the cons ,w)) nil)) binds)
                   (bind-one pattern g)
                   (when svar
                     (ensure-var svar)
                     (push (list svar g?) binds))
                   (setq w h)))))
           ;; rest
           ;; (when (and (consp q) (member (car q) '(&rest &body)))
           (when (and (consp q)
                      (member (car q) '(&rest &body))
                      (consp (cdr q)))
             (pop q)
             (bind-one (pop q) w)
             (setq w nil dotted-ok nil))
           ;; keywords
           (when (and (consp q) (eq (car q) '&key))
             (pop q)
             (setf (values q w) (bind-keys q w))
             (setq dotted-ok nil))
           ;; &aux
           (when (and (consp q) (eq (car q) '&aux))
             (setq dotted-ok nil)
             (pop q)
             (do () ((not (and (consp q) (not (member (car q) lambda-list-keywords)))))
               (multiple-value-bind (var init)
                   (parse-aux-parameter (pop q))
                 (ensure-var var)
                 (push (list var init) binds))))
           ;;
           (cond ((null q)
                  (unless (null w)
                    (push (list (dummy)
                                `(UNLESS (NULL ,w) (error "Too many arguments")))
                          binds)))
                 (dotted-ok
                  (ensure-var q)
                  (push (list q w) binds))
                 (t
                  (error "Bad lambda list: ~S" lambda-list))))
         ;;
         (bind-keys (q w &aux
                       (-identity- (list '-identity-))
                       (flag-limit
                        (integer-length (constant-value 'most-positive-fixnum env)))
                       (*gensym-counter* 1)
                       (positive-fixnum-type
                        `(integer 0 ,(constant-value 'most-positive-fixnum env))))
           ;; We're just past &KEY, bind those keys, returns the new Q and W.
           (let (;; /key-vars/ is a list of (<keyword> <value-var> <flag-var> <value-var-init> <flag-bit>)
                 (key-vars nil)
                 ;;
                 (key-parameters nil)
                 (allow-other-keys-p nil)
                 (other-needed-p t)
                 ;; Set to FLAG-LIMIT, so that the initial allocation will make a new one.
                 (flag-count flag-limit)
                 (flag-vars nil))
             ;; Collect keyword parameters into /key-parameters/. Each element is:
             ;;
             ;;     (<keyword> <pattern> <svar> <init>)
             ;;
             ;; The <init> can also be the marker -IDENTITY- indicating that no
             ;; default needs to be done anymore. If <svar> is NIL, there is no user
             ;; specified svar to be bound.
             ;;
             ;; Since it is okay to have the same keyword being used by multiple keyword
             ;; parameters like
             ;;
             ;;    (&key ((:x x) 10) ((:x y) 42))
             ;;
             ;; we have a second list /key-vars/ which is used for the loop and consists of
             ;;
             ;;    (<keyword> <value-var> <flag-var> <value-var-init>)
             ;;
             ;; the "user" variables and svars are then bound to the above once we finished
             ;; the loop. The svar-in-loop is always needed because no matter what a prior
             ;; given keyword shadows a latter, so we must have some flag telling us.
             ;;
             ;; However, we might optimize for the case that the init value is a literal
             ;; and there is only one key matching this variable.
             ;;
             ;; Collect KEY-VARS and KEY-PARAMETERS:
             (labels ((add-keyword (keyword)
                        (unless (assoc keyword key-vars)
                          (let ((g (gensym)))
                            (allocate-flag)
                            (push (list keyword g (car flag-vars) 'nil (1- flag-count))
                                  key-vars))))
                      (allocate-flag ()
                        (when (>= flag-count flag-limit)
                          (let ((g (gensym "FLAG.")))
                            (push g flag-vars)
                            (push `(type ,positive-fixnum-type ,g) declarations))
                          (setq flag-count 0))
                        (incf flag-count)))
                            
               (do () ((not (and (consp q) (not (member (car q) lambda-list-keywords)))))
                 (let ((p (pop q)))
                   (multiple-value-bind (pattern init svar keyword)
                       (parse-keyword-parameter p)
                     (when svar
                       (ensure-var svar))
                     (push (list keyword pattern svar init) key-parameters)
                     (add-keyword keyword))))
               (cond ((and (consp q) (eq (car q) '&allow-other-keys))
                      (setq allow-other-keys-p t)
                      (pop q)
                      (setq other-needed-p nil))
                     (t
                      (add-keyword ':allow-other-keys))))
             ;;
             ;; Optimization: If for a given keyword, all init forms are equal and
             ;; constantp, we can make the init form of the loop variable be that
             ;; init value and mark all init forms of the parameters with -IDENTITY-
             ;; saying that no dispatch on the presence flag needs to be done.
             ;;
             (dolist (k key-vars)
               (let ((params (remove (car k) key-parameters :test-not 'eq :key #'first)))
                 ;; (format t "User parameters for ~S: ~S~%" (car k) params)
                 (when (and params
                            (constantp (fourth (car params)))
                            (every (lambda (p)
                                     (equal (fourth p) (fourth (car params))))
                                   params))
                   ;; (format t "we won~%")
                   (setf (fourth k) (fourth (car params)))
                   (dolist (p params)
                     (setf (fourth p) -identity-)))))
             ;;
             (dolist (flag-var flag-vars)
               (push (list flag-var 0) binds))
             (dolist (k key-vars)
               (push (list (second k) (fourth k)) binds) ;variable for value
               ;; (push (list (third k) 'nil) binds) ;flag for svar
               )
             ;;
             (let ((other (and other-needed-p (gensym "OTHER."))))
               (when other-needed-p (push (list other 'nil) binds))
               (push (list (dummy)
                           (let ((g (gensym "Q."))
                                 (gk (gensym "K."))
                                 (v (gensym "V."))
                                 (m (gensym "M.")))
                             `(let (,v ,m)
                                (declare (ignorable ,v))
                                (do ((,g ,w))
                                    ((endp ,g)
                                     ,(if allow-other-keys-p
                                          'nil
                                          `(when (and ,other
                                                      (not ,(second (assoc ':allow-other-keys key-vars))))
                                             (error "~@<Unknown keyword: ~S; ~_Allowed keywords are ~@<~{~S~^, ~:_~}~:>~:>"
                                                    (car ,other)
                                                    ',(mapcar #'car (reverse key-vars))))))
                                  (let* ((,gk (car (the cons ,g))))
                                    (setq ,m (cdr (the cons ,g)))
                                    (unless (consp ,m)
                                      (error "Odd length or dotted keyword/value list"))
                                    (setq ,v (car (the cons ,m)))
                                    (setq ,m (cdr (the cons ,m)))
                                    (case ,gk
                                      ,@(mapcar (lambda (q)
                                                  `((,(car q))
                                                    (UNLESS (LOGBITP ,(fifth q)
                                                                     (THE ,positive-fixnum-type ,(third q)))
                                                      (SETQ ,(second q) ,v)
                                                      (SETQ ,(third q)
                                                            (THE ,positive-fixnum-type
                                                                 (LOGIOR (THE ,positive-fixnum-type ,(third q))
                                                                         ,(ash 1 (fifth q))))))))
                                                (reverse key-vars))
                                      ,@(and other-needed-p
                                             (list `(otherwise (setq ,other ,g)))))
                                    (setq ,g ,m))))))
                     binds))
             ;; Finally bind what was found.
             (dolist (param (reverse key-parameters))
               (let ((keyword (first param))
                     (pattern (second param))
                     (svar (third param))
                     (init (fourth param)))
                 (let ((q (assoc keyword key-vars)))
                   (if (eq init -identity-)
                       (bind-one pattern (second q))
                       (let ((g (gensym)))
                         (push (list g `(if (LOGBITP ,(fifth q)
                                                     (THE ,positive-fixnum-type ,(third q)))
                                            ,(second q)
                                            ,init))
                               binds)
                         (bind-one pattern g)))
                   (when svar
                     (push (list svar
                                 `(LOGBITP ,(fifth q)
                                           (THE ,positive-fixnum-type ,(third q)))) binds)))))
             ;;
             (setq w nil))
           (values q w))
         ;;
         #+(or)                         ;The old not so fancy version
         (bind-keys (q w)
           ;; We're just past &KEY, bind those keys, returns the new Q and W.
           (let (;; /key-vars/ is a list of (<keyword> <value-var> <flag-var> <value-var-init>)
                 (key-vars nil)
                 ;;
                 (key-parameters nil)
                 (allow-other-keys-p nil)
                 (other-needed-p t))
             ;; Collect keyword parameters into /key-parameters/. Each element is:
             ;;
             ;;     (<pattern> <init> <svar> <keyword>)
             ;;
             ;; The <init> can also be the marker -IDENTITY- indicating that no
             ;; default needs to be done anymore.
             ;;
             ;; Since it is okay to have the same keyword being used by multiple keyword
             ;; parameters like
             ;;
             ;;    (&key ((:x x) 10) ((:x y) 42))
             ;;
             ;; we have a second list /key-vars/ which is used for the loop and consists of
             ;;
             ;;    (<keyword> <value-var> <flag-var> <value-var-init>)
             ;;
             ;; the "user" variables and svars are then bound to the above once we finished
             ;; the loop. The svar-in-loop is always needed because no matter what a prior
             ;; given keyword shadows a latter, so we must have some flag telling us.
             ;;
             ;; However, we might optimize for the case that the init value is a literal
             ;; and there is only one key matching this variable.
             ;;
             ;; Collect KEY-VARS and KEY-PARAMETERS:
             (labels ((add-keyword (keyword)
                        (unless (assoc keyword key-vars)
                          (let ((g (gensym)) (g? (gensym)))
                            (push (list keyword g g? 'nil) key-vars)))))
               (do () ((not (and (consp q) (not (member (car q) lambda-list-keywords)))))
                 (let ((p (pop q)))
                   (multiple-value-bind (pattern init svar keyword)
                       (parse-keyword-parameter p)
                     (when svar
                       (ensure-var svar))
                     (push (list pattern init svar keyword) key-parameters)
                     (add-keyword keyword))))
               (cond ((and (consp q) (eq (car q) '&allow-other-keys))
                      (setq allow-other-keys-p t)
                      (pop q)
                      (setq other-needed-p nil))
                     (t
                      (add-keyword ':allow-other-keys))))
             ;;
             (dolist (k key-vars)
               (push (list (second k) (fourth k)) binds) ;variable for value
               (push (list (third k) 'nil) binds)) ;flag for svar
             ;;
             (let ((other (and other-needed-p (gensym "OTHER."))))
               (when other-needed-p (push (list other 'nil) binds))
               (push (list (dummy)
                           (let ((g (gensym "Q."))
                                 (gk (gensym "K."))
                                 (v (gensym "V."))
                                 (m (gensym "M.")))
                             `(let (,v ,m)
                                (declare (ignorable ,v))
                                (do ((,g ,w))
                                    ((endp ,g)
                                     ,(if allow-other-keys-p
                                          'nil
                                          `(when (and ,other
                                                      (not ,(second (assoc ':allow-other-keys key-vars))))
                                             (error "~@<Unknown keyword: ~S; ~_Allowed keywords are ~@<~{~S~^, ~:_~}~:>~:>"
                                                    (car ,other)
                                                    ',(mapcar #'car (reverse key-vars))))))
                                  (let* ((,gk (car (the cons ,g))))
                                    (setq ,m (cdr (the cons ,g)))
                                    (unless (consp ,m)
                                      (error "Odd length or dotted keyword/value list"))
                                    (setq ,v (car (the cons ,m)))
                                    (setq ,m (cdr (the cons ,m)))
                                    (case ,gk
                                      ,@(mapcar (lambda (k)
                                                  `((,(car k))
                                                    (unless ,(caddr k)
                                                      (setq ,(cadr k) ,v ,(caddr k) t))))
                                                (reverse key-vars))
                                      ,@(and other-needed-p
                                             (list `(otherwise (setq ,other ,g)))))
                                    (setq ,g ,m))))))
                     binds))
             ;; Finally bind what was found.
             (dolist (k (reverse key-parameters))
               (let ((q (assoc (fourth k) key-vars)))
                 (cond ((and (constantp (second k))
                             (eq 'nil (eval (second k))))
                        ;; Micro optimization for when the default value is NIL.
                        (let ((g (gensym)))
                          (push (list g (second q)) binds)
                          (bind-one (first k) g)
                          (when (third k)
                            (push (list (third k) (third q)) binds))))
                       (t
                        (let ((g (gensym)))
                          (push (list g `(if ,(third q) ,(second q) ,(second k))) binds)
                          (bind-one (first k) g)
                          (when (third k)
                            (push (list (third k) (third q)) binds)))))))
             ;;
             (setq w nil))
           (values q w))
         ;;
         (ensure-var (var)
           (if (member var bounds)
               (pushnew var duplicates)
               (push var bounds))
           (unless (valid-parameter-name-p var env)
             (error "Not a valid parameter name: ~S" var)))
         ;;
         (valid-parameter-name-p (object env)
           (and (symbolp object)
                (not (null object))
                (not (constantp object env))))
         ;;
         (dummy ()
           (let ((g (gensym "DUMMY.")))
             (push `(ignore ,g) declarations)
             g))
         ;;
         (parse-optional-parameter (parameter &optional (default-init 'nil))
           ;; -> var ; init ; svar
           ;; var | ( {var | ↓pattern} [init-form [supplied-p-parameter]] )
           ;;
           (labels ((bad ()
                      (error "Bad ~S parameter: ~S" '&optional parameter)))
             (let ((q parameter))
               (let (var (init default-init) (svar nil))
                 (cond ((and (symbolp q) (not (null q)))
                        (setq var q))
                       ((atom q) (bad))
                       (t
                        (setq var (pop q))
                        (cond ((null q))
                              ((atom q) (bad))
                              (t
                               (setq init (pop q))
                               (cond ((null q))
                                     ((atom q) (bad))
                                     (t
                                      (setq svar (pop q))
                                      (when (null svar) (bad))
                                      (unless (null q) (bad))))))))
                 (values var init svar)))))
         ;;
         (parse-keyword-parameter (parameter &optional (default-init 'nil))
           ;; -> var ; init ; svar ; keyword
           ;; var | ({var | (keyword-name {var | ↓pattern})} [init-form [supplied-p-parameter]])
           (let (var (init default-init) (svar nil) keyword)
             (labels ((bad ()
                        (error "Bad ~S parameter: ~S" '&key parameter)))
               (let ((q parameter))
                 (cond ((and (symbolp q) (not (null q)))
                        (setq var q keyword (intern (string var) :keyword)))
                       ((atom q) (bad))
                       (t
                        (let ((key-part (pop q)))
                          (cond ((and (symbolp key-part) (not (null key-part)))
                                 (setq var key-part keyword (intern (string key-part) :keyword)))
                                ((and (consp key-part)
                                      (symbolp (car key-part))
                                      (consp (cdr key-part))
                                      (null (cddr key-part)))
                                 (setq keyword (car key-part)
                                       var (cadr key-part)))
                                (t (bad))))
                        (cond ((null q))
                              ((atom q) (bad))
                              (t
                               (setq init (pop q))
                               (cond ((null q))
                                     ((atom q) (bad))
                                     (t
                                      (setq svar (pop q))
                                      (when (null svar) (bad))
                                      (unless (null q) (bad))))))))))
             (values var init svar keyword)))
         ;;
         (parse-aux-parameter (parameter)
           ;; var ; init. /var/ is not checked for being a valid parameter name.
           (cond ((symbolp parameter)
                  (values parameter nil))
                 ((and (consp parameter) (null (cdr parameter)))
                  (values (car parameter) nil))
                 ((and (consp parameter)
                       (consp (cdr parameter))
                       (null (cddr parameter)))
                  (values (car parameter) (cadr parameter)))
                 (t
                  (error "Bad ~S parameter: ~S" '&aux parameter))))
         ;;
         )
      ;;
      (unless (listp lambda-list)
        ;; This is actually an odd corner case if you ask me.
        (error "Bad lambda list: ~S" lambda-list))
      (let ((g (gensym)))
        (push (list g whole) binds)
        (bind-list lambda-list g))
      (dolist (k binds)
        (when (symbol-package (car k))
          (unless (member (car k) bounds)
            (error "We miss ~S" (car k)))))
      (values (reverse binds) declarations)))

  (defun constant-value (form &optional env)
    "Returns the value of the form /form/ which needs to be constant (according
to CONSTANTP) in the given environment /env/ which defaults to the global
runtime environment."
    ;; When cross compiling our constants like MOST-POSITIVE-FIXNUM might be
    ;; different from the target's one. While CONSTANTP takes an environment
    ;; argument, there is no means to get at the constant value.
    ;;
    ;; So we keep this here for later while we punt.
    (declare (ignore env))
    (eval form))
  )


;;;; ------------------------------------------------------------------------------------------


(defparameter *tests*
  '((DESTRUCTURING-BIND.1 (DESTRUCTURING-BIND (X Y Z) '(A B C) (VALUES X Y Z))
     (A B C))
    (DESTRUCTURING-BIND.2
     (DESTRUCTURING-BIND (X Y &REST Z) '(A B C D) (VALUES X Y Z)) (A B (C D)))
    (DESTRUCTURING-BIND.3
     (DESTRUCTURING-BIND (X Y &OPTIONAL Z) '(A B C) (VALUES X Y Z)) (A B C))
    (DESTRUCTURING-BIND.4
     (DESTRUCTURING-BIND (X Y &OPTIONAL Z) '(A B) (VALUES X Y Z)) (A B NIL))
    (DESTRUCTURING-BIND.5
     (DESTRUCTURING-BIND (X Y &OPTIONAL (Z 'W)) '(A B) (VALUES X Y Z)) (A B W))
    (DESTRUCTURING-BIND.6
     (DESTRUCTURING-BIND (X Y &OPTIONAL (Z 'W Z-P)) '(A B) (VALUES X Y Z Z-P))
     (A B W NIL))
    (DESTRUCTURING-BIND.7
     (DESTRUCTURING-BIND
           (X Y &OPTIONAL (Z 'W Z-P))
         '(A B C)
       (VALUES X Y Z (NOTNOT Z-P)))
     (A B C T))
    (DESTRUCTURING-BIND.7A
     (DESTRUCTURING-BIND (X Y &OPTIONAL (Z X Z-P)) '(A B) (VALUES X Y Z Z-P))
     (A B A NIL))
    (DESTRUCTURING-BIND.8
     (DESTRUCTURING-BIND (X Y &OPTIONAL Z W) '(A B C) (VALUES X Y Z W))
     (A B C NIL))
    (DESTRUCTURING-BIND.9 (DESTRUCTURING-BIND ((X Y)) '((A B)) (VALUES X Y))
     (A B))
    (DESTRUCTURING-BIND.10
     (DESTRUCTURING-BIND (&WHOLE W (X Y)) '((A B)) (VALUES X Y W)) (A B ((A B))))
    (DESTRUCTURING-BIND.11
     (DESTRUCTURING-BIND ((X . Y) . W) '((A B) C) (VALUES X Y W)) (A (B) (C)))
    (DESTRUCTURING-BIND.12
     (DESTRUCTURING-BIND (X Y &BODY Z) '(A B C D) (VALUES X Y Z)) (A B (C D)))
    (DESTRUCTURING-BIND.12A
     (DESTRUCTURING-BIND ((X Y &BODY Z)) '((A B C D)) (VALUES X Y Z)) (A B (C D)))
    (DESTRUCTURING-BIND.13
     (DESTRUCTURING-BIND (&WHOLE X Y Z) '(A B) (VALUES X Y Z)) ((A B) A B))
    (DESTRUCTURING-BIND.14
     (DESTRUCTURING-BIND (W (&WHOLE X Y Z)) '(1 (A B)) (VALUES W X Y Z))
     (1 (A B) A B))
    (DESTRUCTURING-BIND.15
     (DESTRUCTURING-BIND (&KEY A B C) '(:A 1) (VALUES A B C)) (1 NIL NIL))
    (DESTRUCTURING-BIND.16
     (DESTRUCTURING-BIND (&KEY A B C) '(:B 1) (VALUES A B C)) (NIL 1 NIL))
    (DESTRUCTURING-BIND.17
     (DESTRUCTURING-BIND (&KEY A B C) '(:C 1) (VALUES A B C)) (NIL NIL 1))
    (DESTRUCTURING-BIND.17A
     (DESTRUCTURING-BIND (&KEY (A 'FOO) (B 'BAR) C) '(:C 1) (VALUES A B C))
     (FOO BAR 1))
    (DESTRUCTURING-BIND.17C
     (DESTRUCTURING-BIND
           (&KEY (A 'FOO A-P) (B A B-P) (C 'ZZZ C-P))
         '(:C 1)
       (VALUES A B C A-P B-P (NOTNOT C-P)))
     (FOO FOO 1 NIL NIL T))
    (DESTRUCTURING-BIND.18
     (DESTRUCTURING-BIND ((&KEY A B C)) '((:C 1 :B 2)) (VALUES A B C)) (NIL 2 1))
    (DESTRUCTURING-BIND.19
     (BLOCK NIL
       (TAGBODY (DESTRUCTURING-BIND (A . B) '(1 2) (GO 10) 10 (RETURN 'BAD))
         10
               (RETURN 'GOOD)))
     (GOOD))
    (DESTRUCTURING-BIND.20
     (DESTRUCTURING-BIND (&WHOLE (A . B) C . D) '(1 . 2) (LIST A B C D))
     ((1 2 1 2)))
    (DESTRUCTURING-BIND.21
     (DESTRUCTURING-BIND (X &REST (Y Z)) '(1 2 3) (VALUES X Y Z)) (1 2 3))
    (DESTRUCTURING-BIND.22 (DESTRUCTURING-BIND (X Y &KEY) '(1 2) (VALUES X Y))
     (1 2))
    (DESTRUCTURING-BIND.23
     (DESTRUCTURING-BIND (&REST X &KEY) '(:ALLOW-OTHER-KEYS 1) X)
     ((:ALLOW-OTHER-KEYS 1)))
    (DESTRUCTURING-BIND.24 (DESTRUCTURING-BIND (&REST X &KEY) NIL X) (NIL))
    (DESTRUCTURING-BIND.25
     (LET ((X :BAD))
       (DECLARE (SPECIAL X))
       (LET ((X :GOOD))
         (DESTRUCTURING-BIND (Y) (LIST X) (DECLARE (SPECIAL X)) Y)))
     (:GOOD))
    (DESTRUCTURING-BIND.26 (DESTRUCTURING-BIND (X) (LIST 1)) (NIL))
    (DESTRUCTURING-BIND.27 (DESTRUCTURING-BIND (X) (LIST 1) (DECLARE (OPTIMIZE)))
     (NIL))
    (DESTRUCTURING-BIND.28
     (DESTRUCTURING-BIND (X) (LIST 1) (DECLARE (OPTIMIZE)) (DECLARE)) (NIL))
    (DESTRUCTURING-BIND.29 (DESTRUCTURING-BIND (X &AUX Y) '(:FOO) (VALUES X Y))
     (:FOO NIL))
    (DESTRUCTURING-BIND.30
     (DESTRUCTURING-BIND (X &AUX (Y (LIST X))) '(:FOO) (VALUES X Y))
     (:FOO (:FOO)))

    #+(or)
    (DESTRUCTURING-BIND.31
     (MACROLET ((%M (Z) Z))
       (DESTRUCTURING-BIND
             (A B C)
           (EXPAND-IN-CURRENT-ENV (%M '(1 2 3)))
         (VALUES A B C)))
     (1 2 3))
    (destructuring-bind.32
     (destructuring-bind (&key ((:a a)) ((:a b))) '(:a 42) (values a b))
     (42 42))

    #+(or)
    ;; This is for debate. We still have to find the passage that says that
    ;; duplicate parameter names are forbidden. In fact this specific one is fine
    ;; with every Lisp tested.
    (destructuring-bind.33
     (destructuring-bind (&key ((:a a)) ((:a a))) '(:a 42) (values a))
     :error)
    (destructuring-bind.34
     (destructuring-bind (&whole (&key x (y 20)) &rest r) '(:x 10)
       (values x y r))
     (10 20 (:x 10)))
    (destructuring-bind.35
     (destructuring-bind (&key ((:x x) 10) ((:x y) 20)) '()
       (values x y))
     (10 20))
    (destructuring-bind.36
     (destructuring-bind (&key ((nil x))) '(nil 42) x)
     (42))

    ;; NIL as a pattern
    (destructuring-bind.37 (destructuring-bind (&key ((:x nil))) '(:x nil))     (nil))
    (destructuring-bind.38 (destructuring-bind (nil) '(nil))                    (nil))
    (destructuring-bind.39 (destructuring-bind (nil) '(42))                     :error)

    ;; It says:
    ;; var | ({var | (keyword-name {var | ↓pattern})} [init-form [supplied-p-parameter]])
    ;; So this is a var:
    (destructuring-bind.40a (destructuring-bind (&key nil) ())                  :error)
    ;; And so is this:
    (destructuring-bind.40b (destructuring-bind (&key (nil)) ())                :error)
    ;; But this is not, NIL is a pattern here
    (destructuring-bind.40c (destructuring-bind (&key ((:a nil))) '())          (nil))
    (destructuring-bind.40d (destructuring-bind (&key ((:a nil))) '(:a nil))    (nil))
    (destructuring-bind.40e (destructuring-bind (&key ((:a nil))) '(:a 42))     :error)
    
    ;; It says
    ;; &OPTIONAL {var | ({var | ↓pattern} [init-form [supplied-p-parameter]])}*
    ;; Therefore when there's just a symbol
    ;; that's a way and so in &OPTIONAL NIL the NIL is a var.
    ;;
    (destructuring-bind.40 (destructuring-bind (&optional nil) '())             :error)
    (destructuring-bind.42 (destructuring-bind (&optional (nil)) '())           (nil))
    (destructuring-bind.43 (destructuring-bind (&optional (nil)) '(nil))        (nil))
    (destructuring-bind.44 (destructuring-bind (&optional (nil)) '(42))         :error)
    ;; &REST allows for a pattern or a var.
    (destructuring-bind.45 (destructuring-bind (&rest nil) '())                 (nil))
    (destructuring-bind.46 (destructuring-bind (&rest nil) '(42))               :error)
    (destructuring-bind.45 (destructuring-bind (&whole nil) '())                (nil))
    ;; Same for &whole
    (destructuring-bind.46 (destructuring-bind (&whole nil &rest r)
                               '()
                             (declare (ignore r)))
     (nil))
    (destructuring-bind.47 (destructuring-bind (&whole nil &rest r)
                               '(42)
                             (declare (ignore r)))
     :error)
    
    ;; Malformed lambda lists around &WHOLE
    (destructuring-bind.47 (destructuring-bind (&whole) nil) :error)
    (destructuring-bind.48 (destructuring-bind (&whole . a) '(a)) :error)
    (destructuring-bind.49 (destructuring-bind (a &whole b) '(a)) :error)
    (destructuring-bind.50 (destructuring-bind (a &whole b) '(a w b)) :error)

    ;; Malformed lambda list around &REST
    (destructuring-bind.51 (destructuring-bind (&rest) nil) :error)
    (destructuring-bind.52 (destructuring-bind (&rest . a) nil) :error)
    (destructuring-bind.53 (destructuring-bind (&rest a . b) nil) :error)
    (destructuring-bind.54 (destructuring-bind (&rest a b) nil) :error)
    ;; Dotted after &whole is okay
    (destructuring-bind.55 (destructuring-bind (&whole w . x) '(a) (values w x)) ((a) (a)))

    ;; Syntax for &aux
    (destructuring-bind.60 (destructuring-bind (&aux a) nil a) (nil))
    (destructuring-bind.61 (destructuring-bind (&aux (a 42)) nil a) (42))
    (destructuring-bind.62 (destructuring-bind (&aux ((a b) '(1 2))) nil (+ a b)) :error)
    (destructuring-bind.63 (destructuring-bind (&aux) nil) (nil))
    (destructuring-bind.64 (destructuring-bind (&aux . x) nil) :error)
    (destructuring-bind.65 (destructuring-bind (&aux nil) nil) :error)
    (destructuring-bind.66 (destructuring-bind (&aux 42) nil) :error)
    (destructuring-bind.67 (destructuring-bind (&aux (a)) nil a) (nil))
    (destructuring-bind.68 (destructuring-bind (&aux (a 42 . x)) nil a) :error)
    (destructuring-bind.69 (destructuring-bind (&aux (a 42 x)) nil a) :error)

    ;; Syntax for &optional
    (destructuring-bind.70 (destructuring-bind (&optional nil) nil) :error)
    (destructuring-bind.71 (destructuring-bind (&optional (nil)) '(nil)) (nil))
    (destructuring-bind.72 (destructuring-bind (&optional (nil nil nil-p)) '(nil) nil-p) (t))
    (destructuring-bind.73 (destructuring-bind (&optional (a . b)) nil) :error)
    (destructuring-bind.74 (destructuring-bind (&optional (a :b)) nil a) (:b))
    (destructuring-bind.75 (destructuring-bind (&optional (a :b . c)) nil) :error)
    (destructuring-bind.76 (destructuring-bind (&optional (a :b c)) nil c) (nil))
    (destructuring-bind.78 (destructuring-bind (&optional (a :b c)) '(a) c) (t))
    (destructuring-bind.79 (destructuring-bind (&optional (a :b c . x)) nil) :error)
    (destructuring-bind.80 (destructuring-bind (&optional (a :b c x)) nil) :error)
    (destructuring-bind.81 (destructuring-bind (&optional ((a b) '(1 2))) nil (+ a b)) (3))
    (destructuring-bind.82 (destructuring-bind (&optional . r) '(a b) r) ((a b)))
    (destructuring-bind.82a (destructuring-bind (&optional (a nil nil)) nil) :error)
    (destructuring-bind.82b (destructuring-bind (&optional (a nil (x))) nil) :error)

    ;; &allow-other-keys
    (destructuring-bind.100
     (destructuring-bind (&key (allow-other-keys t)) '(:foo))
     :error)
    (destructuring-bind.101
     (destructuring-bind (&key) '(:foo 42 :allow-other-keys t))
     (nil))
    (destructuring-bind.102
     (destructuring-bind (&key ((:allow-other-keys a) t)) '(:foo))
     :error)
    (destructuring-bind.103
     (destructuring-bind (&key (allow-other-keys :default) &allow-other-keys) '()
       allow-other-keys)
     (:default))
    (destructuring-bind.104
     (destructuring-bind (&key &allow-other-keys) '(:allow-other-keys nil :foo 42)
       nil)
     (nil))
    (destructuring-bind.105
     (destructuring-bind (&key) '(:allow-other-keys t :allow-other-keys nil :foo 42)
       nil)
     (nil))
    (destructuring-bind.106
     (destructuring-bind (&key) '(:allow-other-keys nil :allow-other-keys t :foo 42)
       nil)
     :error)
    (destructuring-bind.107
     (destructuring-bind (&key) '(:foo 42 :allow-other-keys t)
       nil)
     (nil))

    ;; More syntax for &KEY
    (destructuring-bind.120
     ;; keyword-name must be a symbol
     (destructuring-bind (&key ((42 x))) ()) :error)
    (destructuring-bind.120a
     ;; NIL is a symbol.
     (destructuring-bind (&key ((nil x))) '(nil 42) x) (42))
    (destructuring-bind.121 (destructuring-bind (&key (a . b)) ()) :error)
    (destructuring-bind.122 (destructuring-bind (&key (a b . c)) ()) :error)
    (destructuring-bind.123 (destructuring-bind (&key (a b c . d)) ()) :error)
    (destructuring-bind.124 (destructuring-bind (&key (a b c d)) ()) :error)
    (destructuring-bind.125 (destructuring-bind (&key (42)) ()) :error)
    (destructuring-bind.126 (destructuring-bind (&key ((a))) ()) :error)
    (destructuring-bind.127 (destructuring-bind (&key ((a . b))) ()) :error)
    (destructuring-bind.128 (destructuring-bind (&key ((a b . c))) ()) :error)
    (destructuring-bind.129 (destructuring-bind (&key ((a b c))) ()) :error)
    ;;
    (destructuring-bind.130
     (destructuring-bind (&optional ((&rest a)) . b) '(1 2) (values a b))
     (1 (2)))
    ))

;; I want further tests for that all the parameters are strictly bound
;; from left to right. Also with regards to defaults.

(defun test (&optional (macro-sym 'destructuring-bind) &aux have)
  (let ((failed nil))
    (loop for (name form values) in *tests*
          do
          (let ((form (subst macro-sym 'destructuring-bind form)))
            (unless (equalp values
                            (setq have (or (ignore-errors
                                             (multiple-value-list
                                              (let ((*error-output* (make-broadcast-stream)))
                                                (eval `(labels ((notnot(x)(if x 't 'nil)))
                                                         ,form)))))
                                           :error)))
              (push name failed)
              (format t "~&~%Test ~S failed:~%~S~%want ~S~%have ~S~%"
                      name form values have))))
    (let ((*print-pretty* t))
      (if failed
          (format t "~&~%~@<;; ~@;Failed: ~2I~_~{~A~^ ~_~}~:>"
                  (reverse failed))
          (format t "~&;; ALL ~:@(~R~) TEST(S) PASSED." (length *tests*))))))

(defun test-them ()
  (test 'cl:destructuring-bind))

(defun test-us ()
  (test 'destructuring-bind))

(defun bench ()
  (declare (optimize (speed 3) (safety 1)))
   (macrolet ((test-cases ()
                `(progn
                   (test (&key (a 0) (b 0) (c 0) (d 0) (e 0)) '()
                         (+ a b c d e))
                   (test (&key (a 0) (b 0) (c 0) (d 0) (e 0)) '(:d 42 :a 69 :d 0)
                         (+ a b c d e))))
               (test-with (destructuring-bind)
                 `(let ((ti (get-internal-run-time)))
                    (dotimes (i 1000000)
                      (macrolet ((test (&rest more)
                                   `(test-1 ,',destructuring-bind ,@more)))
                        (test-cases)))
                    (let ((*package* (find-package :keyword)))
                      (format t "~&;; Using ~S took ~:Dus~%"
                              ',destructuring-bind
                              (round (* 1e6 (- (get-internal-run-time) ti))
                                     internal-time-units-per-second)))))
               (test-1 (destructuring-bind &rest more)
                 `(,destructuring-bind ,@more)))
  (test-with cl:destructuring-bind)
  (test-with ds:destructuring-bind) ))

;; fin