From 1a7c8506304ea72bfc80d4fdbc6952d67ed59b9a Mon Sep 17 00:00:00 2001 From: Nikodemus Siivola Date: Sun, 8 Apr 2007 12:51:34 +0000 Subject: [PATCH] 1.0.4.46: allow &environment and disallow &aux in DEFSETF lambda-lists * Reported by Samium Gromoff. * Test-cases. --- src/code/early-setf.lisp | 2 +- src/code/parse-defmacro.lisp | 11 +++++++++-- tests/setf.impure.lisp | 30 ++++++++++++++++++++++++++++++ version.lisp-expr | 2 +- 4 files changed, 41 insertions(+), 4 deletions(-) diff --git a/src/code/early-setf.lisp b/src/code/early-setf.lisp index ee7cc7d..99926ae 100644 --- a/src/code/early-setf.lisp +++ b/src/code/early-setf.lisp @@ -399,12 +399,12 @@ GET-SETF-EXPANSION directly." (multiple-value-bind (body local-decs doc) (parse-defmacro `(,lambda-list ,@store-variables) whole-var body access-fn 'defsetf + :environment env-var :anonymousp t) `(eval-when (:compile-toplevel :load-toplevel :execute) (assign-setf-macro ',access-fn (lambda (,access-form-var ,env-var) - (declare (ignore ,env-var)) (%defsetf ,access-form-var ,(length store-variables) (lambda (,whole-var) ,@local-decs diff --git a/src/code/parse-defmacro.lisp b/src/code/parse-defmacro.lisp index 225c2f7..eea2801 100644 --- a/src/code/parse-defmacro.lisp +++ b/src/code/parse-defmacro.lisp @@ -140,7 +140,10 @@ (defmacro-error (format nil "required argument after ~A" restp) context name)) - (process-sublist var "REQUIRED-" `(car ,path)) + (when (process-sublist var "REQUIRED-" `(car ,path)) + ;; Note &ENVIRONMENT from DEFSETF sublist + (aver (eq context 'defsetf)) + (setf env-arg-used t)) (setq path `(cdr ,path) minimum (1+ minimum) maximum (1+ maximum))) @@ -195,7 +198,9 @@ (&environment (cond (env-illegal (error "&ENVIRONMENT is not valid with ~S." context)) - (sublist + ;; DEFSETF explicitly allows &ENVIRONMENT, and we get + ;; it here in a sublist. + ((and sublist (neq context 'defsetf)) (error "&ENVIRONMENT is only valid at top level of ~ lambda-list.")) (env-arg-used @@ -246,6 +251,8 @@ (error "Multiple ~A in ~A lambda-list." var context)) (setq allow-other-keys-p t)) (&aux + (when (eq context 'defsetf) + (error "~A not allowed in a ~A lambda-list." var context)) (when aux-seen (error "Multiple ~A in ~A lambda-list." '&aux context)) (setq now-processing :auxs diff --git a/tests/setf.impure.lisp b/tests/setf.impure.lisp index b159173..62c7987 100644 --- a/tests/setf.impure.lisp +++ b/tests/setf.impure.lisp @@ -51,4 +51,34 @@ (setf (macro-function 'nothing-at-all nil) fun) (assert (eq fun (macro-function 'nothing-at-all nil)))) + +;;; DEFSETF accepts &ENVIRONMENT but not &AUX +(defsetf test-defsetf-env-1 (&environment env) (new) + (declare (ignore new)) + (if (macro-function 'defsetf-env-trick env) + :local + :global)) + +(defsetf test-defsetf-env-2 (local global &environment env) (new) + (declare (ignore new)) + (if (macro-function 'defsetf-env-trick env) + local + global)) + +(aver (eq :local (macrolet ((defsetf-env-trick ())) + (setf (test-defsetf-env-1) 13)))) + +(aver (eq :global (setf (test-defsetf-env-1) 13))) + +(aver (eq :local (macrolet ((defsetf-env-trick ())) + (setf (test-defsetf-env-2 :local :oops) 13)))) + +(aver (eq :global (setf (test-defsetf-env-2 :oops :global) 13))) + +(aver (eq :error + (handler-case + (eval '(defsetf test-defsetf-aux (&aux aux) (new) nil)) + (error () + :error)))) + ;;; success diff --git a/version.lisp-expr b/version.lisp-expr index 6355e03..0649a25 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -17,4 +17,4 @@ ;;; checkins which aren't released. (And occasionally for internal ;;; versions, especially for internal versions off the main CVS ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".) -"1.0.4.45" +"1.0.4.46" -- 1.7.10.4