From: stassats <sta...@us...> - 2014-08-30 16:21:29
|
The branch "master" has been updated in SBCL: via ed063cafbe5a720f30188b996b8ed5e9a8261bf1 (commit) from 5f9606c3343972f0c8b143d8b5a8503661a5f00f (commit) - Log ----------------------------------------------------------------- commit ed063cafbe5a720f30188b996b8ed5e9a8261bf1 Author: Stas Boukarev <sta...@gm...> Date: Sat Aug 30 20:18:11 2014 +0400 Fix binding order of supplied-p parameters in macro lambda lists. It was done at once before all other bindings were processed, while it should be just after the binding to which supplied-p is related is bound. Fixes lp#721135. --- NEWS | 4 ++++ src/code/parse-defmacro.lisp | 34 ++++++++++++++++++---------------- src/code/target-alieneval.lisp | 2 +- tests/lambda-list.pure.lisp | 26 ++++++++++++++++++++++++++ 4 files changed, 49 insertions(+), 17 deletions(-) diff --git a/NEWS b/NEWS index 9187b06..c26fe2c 100644 --- a/NEWS +++ b/NEWS @@ -1,4 +1,8 @@ ;;;; -*- coding: utf-8; fill-column: 78 -*- +changes relative to sbcl-1.2.3: + * bug fix: Wrong binding order of supplied-p parameters in macro lambda lists. + (lp#721135) + changes in sbcl-1.2.3 relative to sbcl-1.2.2: * enhancement: DOCUMENTATION works on instances of FUNCALLABLE-STANDARD-CLASS diff --git a/src/code/parse-defmacro.lisp b/src/code/parse-defmacro.lisp index 5a42651..1222928 100644 --- a/src/code/parse-defmacro.lisp +++ b/src/code/parse-defmacro.lisp @@ -378,22 +378,24 @@ (defun push-optional-binding (value-var init-form suppliedp-name &key is-supplied-p path name context error-fun) - (unless suppliedp-name - (setq suppliedp-name (gensym "SUPPLIEDP-"))) - (push-let-binding suppliedp-name is-supplied-p :system t) - (cond ((consp value-var) - (let ((whole-thing (gensym "OPTIONAL-SUBLIST-"))) - (push-sublist-binding whole-thing - `(if ,suppliedp-name ,path ,init-form) - value-var name context error-fun) - (parse-defmacro-lambda-list value-var whole-thing name - context - :error-fun error-fun - :sublist t))) - ((symbolp value-var) - (push-let-binding value-var path :when suppliedp-name :else init-form)) - (t - (error "illegal optional variable name: ~S" value-var)))) + (let ((sym (gensym "SUPPLIEDP-"))) + (push-let-binding sym is-supplied-p :system t) + (cond ((consp value-var) + (let ((whole-thing (gensym "OPTIONAL-SUBLIST-"))) + (push-sublist-binding whole-thing + `(if ,sym ,path ,init-form) + value-var name context error-fun) + (parse-defmacro-lambda-list value-var whole-thing name + context + :error-fun error-fun + :sublist t))) + ((symbolp value-var) + (push-let-binding value-var path :when sym :else init-form)) + (t + (error "Illegal optional variable name: ~S" value-var))) + ;; Shouldn't be bound during the initform evaluation + (when suppliedp-name + (push-let-binding suppliedp-name sym)))) (defun defmacro-error (problem context name) (error "illegal or ill-formed ~A argument in ~A~@[ ~S~]" diff --git a/src/code/target-alieneval.lisp b/src/code/target-alieneval.lisp index 4328505..388b1a8 100644 --- a/src/code/target-alieneval.lisp +++ b/src/code/target-alieneval.lisp @@ -120,7 +120,7 @@ This is SETFable." (dolist (binding (reverse bindings)) (/show binding) (destructuring-bind - (symbol type &optional (opt1 nil opt1p) (opt2 nil opt2p)) + (symbol type &optional opt1 (opt2 nil opt2p)) binding (/show symbol type opt1 opt2) (let* ((alien-type (parse-alien-type type env)) diff --git a/tests/lambda-list.pure.lisp b/tests/lambda-list.pure.lisp index 3dd39db..4357a2a 100644 --- a/tests/lambda-list.pure.lisp +++ b/tests/lambda-list.pure.lisp @@ -46,3 +46,29 @@ (error-p (&optional foo &optional bar)) (error-p (&rest foo &rest bar)) (error-p (&rest foo &optional bar)))) + +(with-test (:name :supplied-p-order) + (let ((* 10)) + (assert (eql ((lambda (&key (x * *)) () x)) 10)) + (assert (eql ((lambda (&key (y * *) (x *)) () x) :y 1) t)) + (assert (eql ((lambda (&key (x *) (y * *)) () x) :y 1) 10)) + + (assert (eql (destructuring-bind (&key (x * *)) () x) 10)) + (assert (eql (destructuring-bind (&key (y * *) (x *)) '(:y 1) x) t)) + (assert (eql (destructuring-bind (&key (x *) (y * *)) '(:y 1) x) 10)) + + (assert (eql ((lambda (&optional (x * *)) () x)) 10)) + (assert (eql ((lambda (&optional (y * *) (x *)) () x) 1) t)) + (assert (eql ((lambda (&optional (x *) (y * *)) () x)) 10)) + + (assert (eql (destructuring-bind (&optional (x * *)) () x) 10)) + (assert (eql (destructuring-bind (&optional (y * *) (x *)) '(1) x) t)) + (assert (eql (destructuring-bind (&optional (x *) (y * *)) () x) 10)))) + +(with-test (:name :supplied-p-order) + (assert-no-signal + (compile nil (lambda () + (destructuring-bind (&optional (x nil xp)) '() + (declare (ignore x xp)) + nil))) + warning)) ----------------------------------------------------------------------- hooks/post-receive -- SBCL |