From attila.lendvai at gmail.com  Mon May 12 20:38:45 2008
From: attila.lendvai at gmail.com (Attila Lendvai)
Date: Mon, 12 May 2008 22:38:45 +0200
Subject: [Metabang-bind-devel] fix and bug report
Message-ID: <b54b34af0805121338o44431dd8w8e22668b9391ab4b@mail.gmail.com>

hi list!

please find a patch attached with a fix for a bug  that (bind () 1 2)
expands to 1.

unfortunately there was another bug that i couldn't fix in the two
minutes timespan i gave myself before i switched to a
destructuring-bind (but hey, at least i tried! :)

(bind (((a &key (b nil b-p)) (list 1 :b 42)))
            (list a b b-p))

in this destructuring-bind, bind replaces nil to a gensym in the
beliefe that it's an unused argument. the fix requires proper walking
of the lambda list. at the end of the mail i've copy-pasted the lambda
list parser from stefil, which may or may not help.

hth,

-- 
 attila


;;;;;;;;;;;;;;;;;;;;;;;;
;;; some utils

(define-condition illegal-lambda-list (error)
  ((lambda-list :accessor lambda-list-of :initarg :lambda-list)))

(defun illegal-lambda-list (lambda-list)
  (error 'illegal-lambda-list :lambda-list lambda-list))

(defun parse-lambda-list (lambda-list visitor &key macro)
  ;; TODO finish macro lambda list parsing
  (declare (optimize (speed 3))
           (type list lambda-list)
           (type (or symbol function) visitor))
  (let ((args lambda-list))
    (labels
        ((fail ()
           (illegal-lambda-list lambda-list))
         (ensure-list (list)
           (if (listp list)
               list
               (list list)))
         (process-&whole ()
           (assert (eq (first args) '&whole))
           (pop args)
           (unless macro
             (fail))
           (let ((whole (pop args)))
             (unless whole
               (fail))
             (funcall visitor '&whole whole whole))
           (case (first args)
             (&key          (entering-&key))
             (&rest         (process-&rest))
             (&optional     (entering-&optional))
             (&body         (process-&body))
             (&environment  (process-&environment))
             ((&whole &aux &allow-other-keys) (fail))
             (t             (process-required))))
         (process-&body ()
           (assert (eq (first args) '&body))
           (pop args)
           (unless macro
             (fail))
           (let ((body (pop args)))
             (unless (null args)
               (fail))
             (unless body
               (fail))
             (funcall visitor '&body body body)))
         (process-&environment ()
           (assert (eq (first args) '&environment))
           (pop args)
           (unless macro
             (fail))
           (let ((env (pop args)))
             (unless env
               (fail))
             (funcall visitor '&environment env env))
           (case (first args)
             (&key          (entering-&key))
             (&rest         (process-&rest))
             (&optional     (entering-&optional))
             (&body         (process-&body))
             (&aux          (process-&aux))
             ((&whole &environment &allow-other-keys) (fail))
             (t             (process-required))))
         (process-required ()
           (unless args
             (done))
           (case (first args)
             (&key          (entering-&key))
             (&rest         (process-&rest))
             (&optional     (entering-&optional))
             (&body         (process-&body))
             (&environment  (process-&environment))
             ((&whole &allow-other-keys) (fail))
             (&aux          (entering-&aux))
             (t
              (let ((arg (pop args)))
                (funcall visitor nil arg arg))
              (process-required))))
         (process-&rest ()
           (assert (eq (first args) '&rest))
           (pop args)
           (let ((rest (pop args)))
             (unless rest
               (fail))
             (funcall visitor '&rest rest rest))
           (unless args
             (done))
           (case (first args)
             (&key               (entering-&key))
             (&environment       (process-&environment))
             ((&whole &optional &rest &body &allow-other-keys) (fail))
             (&aux               (entering-&aux))
             (t                  (fail))))
         (entering-&optional ()
           (assert (eq (first args) '&optional))
           (pop args)
           (process-&optional))
         (process-&optional ()
           (unless args
             (done))
           (case (first args)
             (&key               (entering-&key))
             (&rest              (process-&rest))
             (&body              (process-&body))
             ((&whole &optional &environment &allow-other-keys) (fail))
             (&aux               (entering-&aux))
             (t
              (let ((arg (ensure-list (pop args))))
                (funcall visitor '&optional (first arg) arg))
              (process-&optional))))
         (entering-&key ()
           (assert (eq (first args) '&key))
           (pop args)
           (process-&key))
         (process-&key ()
           (unless args
             (done))
           (case (first args)
             (&allow-other-keys       (funcall visitor
'&allow-other-keys nil nil))
             ((&key &optional &whole &environment &body) (fail))
             (&aux                    (entering-&aux))
             (t
              (let ((arg (ensure-list (pop args))))
                (funcall visitor '&key (first arg) arg))
              (process-&key))))
         (entering-&aux ()
           (assert (eq (first args) '&aux))
           (pop args)
           (process-&aux))
         (process-&aux ()
           (unless args
             (done))
           (case (first args)
             ((&whole &optional &key &environment &allow-other-keys
&aux &body) (fail))
             (t
              (let ((arg (ensure-list (pop args))))
                (funcall visitor '&aux (first arg) arg))
              (process-&aux))))
         (done ()
           (return-from parse-lambda-list (values))))
      (when args
        (case (first args)
          (&whole (process-&whole))
          (t      (process-required)))))))

(defun lambda-list-to-funcall-list (args)
  (let ((result (list))
        (rest-variable-name nil))
    (parse-lambda-list args
                       (lambda (kind name entry)
                         (declare (ignore entry))
                         (case kind
                           (&key
                            (push (intern (symbol-name (first
(ensure-list name)))
                                          #.(find-package "KEYWORD")) result)
                            (push name result))
                           (&allow-other-keys)
                           (&rest (setf rest-variable-name name))
                           (t
                            (push name result)))))
    (values (nreverse result)
            rest-variable-name)))

(defun lambda-list-to-funcall-expression (function args)
  (multiple-value-bind (arg-list rest-variable)
      (lambda-list-to-funcall-list args)
    (if rest-variable
        `(apply ,function , at arg-list ,rest-variable)
        `(funcall ,function , at arg-list))))

(defun lambda-list-to-value-list-expression (args)
  `(list ,@(let ((result (list)))
             (parse-lambda-list args
                                (lambda (kind name entry)
                                  (declare (ignore entry))
                                  (case kind
                                    (&allow-other-keys)
                                    (t (push `(cons ',name ,name) result)))))
             (nreverse result))))

(defun lambda-list-to-variable-name-list (args &key macro include-specials)
  (let ((result (list))
        (rest-variable-name nil)
        (whole-variable-name nil)
        (env-variable-name nil))
    (parse-lambda-list args
                       (lambda (kind name entry)
                         (declare (ignore entry))
                         (case kind
                           (&allow-other-keys )
                           (&environment      (setf env-variable-name name)
                                              (when include-specials
                                                (push name result)))
                           (&whole            (setf whole-variable-name name)
                                              (when include-specials
                                                (push name result)))
                           ((&rest &body)     (setf rest-variable-name name)
                                              (when include-specials
                                                (push name result)))
                           (t                 (push name result))))
                       :macro macro)
    (values (nreverse result)
            rest-variable-name
            whole-variable-name
            env-variable-name)))
-------------- next part --------------
A non-text attachment was scrubbed...
Name: bind-fix.patch
Type: text/x-patch
Size: 6465 bytes
Desc: not available
URL: <https://mailman.common-lisp.net/pipermail/metabang-bind-devel/attachments/20080512/d118e643/attachment.bin>

From attila.lendvai at gmail.com  Tue May 27 10:51:51 2008
From: attila.lendvai at gmail.com (Attila Lendvai)
Date: Tue, 27 May 2008 12:51:51 +0200
Subject: [Metabang-bind-devel] Re: fix and bug report
In-Reply-To: <b54b34af0805121338o44431dd8w8e22668b9391ab4b@mail.gmail.com>
References: <b54b34af0805121338o44431dd8w8e22668b9391ab4b@mail.gmail.com>
Message-ID: <b54b34af0805270351w3dd9c975peb10af9accbaffd0@mail.gmail.com>

> please find a patch attached with a fix for a bug  that (bind () 1 2)
> expands to 1.

Gary, could you please push this fix?

darcs pull http://common-lisp.net/project/cl-dwim/darcs/metabang-bind/

-- 
 attila