[Metabang-bind-devel] fix and bug report
Attila Lendvai
attila.lendvai at gmail.com
Mon May 12 20:38:45 UTC 2008
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>
More information about the metabang-bind-devel
mailing list