From: Nikodemus Siivola Date: Thu, 14 Oct 2010 19:43:23 +0000 (+0000) Subject: 1.0.43.60: plug (SETF MACRO-FUNCTION) shaped hole in package-locks X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=e5b4fe643472dff0ea751fd7ac55fcba0fd0f4f9;p=sbcl.git 1.0.43.60: plug (SETF MACRO-FUNCTION) shaped hole in package-locks The code used to clobber the macro definition before the package-lock was asserted. Also adjust package-lock in DEFMACRO to be asserted before any globaldb infos are clobbered. Fixes bug 660752. --- diff --git a/NEWS b/NEWS index 6250e21..0775db5 100644 --- a/NEWS +++ b/NEWS @@ -67,6 +67,10 @@ changes relative to sbcl-1.0.43: defined incompatibly. (lp#657499) * bug fix: existing ASDF source registries are ignored when building contribs (lp#659105) + * bug fix: short-form DEFSETF checks that the second argument is a symbol + (lp#655824, thanks to Roman Marynchak) + * bug fix: (SETF MACRO-FUNCTION) clobbered macro-definitions before + package-lock violation was detected. (lp#660752) changes in sbcl-1.0.43 relative to sbcl-1.0.42: * incompatible change: FD-STREAMS no longer participate in the serve-event diff --git a/src/code/defmacro.lisp b/src/code/defmacro.lisp index a408ec9..033cc58 100644 --- a/src/code/defmacro.lisp +++ b/src/code/defmacro.lisp @@ -60,44 +60,42 @@ ;; should deal with clearing old compiler information for ;; the functional value." ,@(unless set-p - '((declare (ignore lambda-list debug-name)))) - (with-single-package-locked-error () - (case (info :function :kind name) - (:function - (let ((where-from (info :function :where-from name))) - (when (eq :defined where-from) - (assert-symbol-home-package-unlocked name "defining ~S as a macro")) - (style-warn - "~S is being redefined as a macro when it was ~ + '((declare (ignore lambda-list debug-name doc)))) + (let ((kind (info :function :kind name))) + ;; Check for special form before package locks. + (when (eq :special-form kind) + (error "The special operator ~S can't be redefined as a macro." + name)) + (with-single-package-locked-error (:symbol name "defining ~S as a macro") + (when (eq :function kind) + (style-warn + "~S is being redefined as a macro when it was ~ previously ~(~A~) to be a function." - name where-from)) - (undefine-fun-name name)) - (:special-form - (error "The special form ~S can't be redefined as a macro." - name))) - (clear-info :function :where-from name) + name (info :function :where-from name)) + (undefine-fun-name name)) + (clear-info :function :where-from name) - ;; FIXME: It would be nice to warn about DEFMACRO of an - ;; already-defined macro, but that's slightly hard to do - ;; because in common usage DEFMACRO is defined at compile - ;; time and then redefined at load time. We'd need to make a - ;; distinction between the defined-at-compile-time state and - ;; the defined-at-load-time state to make this work. (Trying - ;; to warn about duplicate DEFTYPEs runs into the same - ;; problem.) - #+nil - (when (sb!xc:macro-function name) - ;; Someday we could check for macro arguments - ;; being incompatibly redefined. Doing this right - ;; will involve finding the old macro lambda-list - ;; and comparing it with the new one. - (style-warn "redefining ~/sb-impl::print-symbol-with-prefix/ ~ + ;; FIXME: It would be nice to warn about DEFMACRO of an + ;; already-defined macro, but that's slightly hard to do + ;; because in common usage DEFMACRO is defined at compile + ;; time and then redefined at load time. We'd need to make a + ;; distinction between the defined-at-compile-time state and + ;; the defined-at-load-time state to make this work. (Trying + ;; to warn about duplicate DEFTYPEs runs into the same + ;; problem.) + #+nil + (when (sb!xc:macro-function name) + ;; Someday we could check for macro arguments + ;; being incompatibly redefined. Doing this right + ;; will involve finding the old macro lambda-list + ;; and comparing it with the new one. + (style-warn "redefining ~/sb-impl::print-symbol-with-prefix/ ~ in DEFMACRO" name)) - (setf (sb!xc:macro-function name) definition) - ,(when set-p - `(setf (%fun-doc definition) doc - (%fun-lambda-list definition) lambda-list - (%fun-name definition) debug-name))) + (setf (sb!xc:macro-function name) definition) + ,(when set-p + `(setf (%fun-doc definition) doc + (%fun-lambda-list definition) lambda-list + (%fun-name definition) debug-name)))) name)))) (progn (def (:load-toplevel :execute) #-sb-xc-host t #+sb-xc-host nil) diff --git a/src/compiler/info-functions.lisp b/src/compiler/info-functions.lisp index c0d9422..d4cb02a 100644 --- a/src/compiler/info-functions.lisp +++ b/src/compiler/info-functions.lisp @@ -162,19 +162,20 @@ only." symbol environment)) (when (eq (info :function :kind symbol) :special-form) (error "~S names a special form." symbol)) - (setf (info :function :kind symbol) :macro) - (setf (info :function :macro-function symbol) function) - ;; This is a nice thing to have in the target SBCL, but in the - ;; cross-compilation host it's not nice to mess with - ;; (SYMBOL-FUNCTION FOO) where FOO might be a symbol in the - ;; cross-compilation host's COMMON-LISP package. - #-sb-xc-host - (setf (symbol-function symbol) - (lambda (&rest args) - (declare (ignore args)) - ;; (ANSI specification of FUNCALL says that this should be - ;; an error of type UNDEFINED-FUNCTION, not just SIMPLE-ERROR.) - (error 'undefined-function :name symbol))) + (with-single-package-locked-error (:symbol symbol "setting the macro-function of ~S") + (setf (info :function :kind symbol) :macro) + (setf (info :function :macro-function symbol) function) + ;; This is a nice thing to have in the target SBCL, but in the + ;; cross-compilation host it's not nice to mess with + ;; (SYMBOL-FUNCTION FOO) where FOO might be a symbol in the + ;; cross-compilation host's COMMON-LISP package. + #-sb-xc-host + (setf (symbol-function symbol) + (lambda (&rest args) + (declare (ignore args)) + ;; (ANSI specification of FUNCALL says that this should be + ;; an error of type UNDEFINED-FUNCTION, not just SIMPLE-ERROR.) + (error 'undefined-function :name symbol)))) function) (defun fun-locally-defined-p (name env) diff --git a/tests/compiler-test-util.lisp b/tests/compiler-test-util.lisp index a21f04f..938af5c 100644 --- a/tests/compiler-test-util.lisp +++ b/tests/compiler-test-util.lisp @@ -95,7 +95,7 @@ `(check-consing t ',form (lambda () ,form) ,times)) (defun file-compile (toplevel-forms &key load) - (let* ((lisp "compile-impure-tmp.lisp") + (let* ((lisp (merge-pathnames "file-compile-tmp.lisp")) (fasl (compile-file-pathname lisp))) (unwind-protect (progn diff --git a/tests/package-locks.impure.lisp b/tests/package-locks.impure.lisp index c9d9b7f..536dab4 100644 --- a/tests/package-locks.impure.lisp +++ b/tests/package-locks.impure.lisp @@ -14,6 +14,7 @@ (in-package :cl-user) (load "assertoid.lisp") +(load "compiler-test-util.lisp") (use-package "ASSERTOID") ;;;; Our little labrats and a few utilities @@ -504,4 +505,34 @@ sb-ext:package-lock-violation)) (assert (eq 'test:function (eval `(test:function))))) +(defpackage :macro-killing-macro-1 + (:use :cl) + (:lock t) + (:export #:to-die-for)) + +(defpackage :macro-killing-macro-2 + (:use :cl :macro-killing-macro-1)) + +(ctu:file-compile + `((in-package :macro-killing-macro-1) + (defmacro to-die-for () + :original)) + :load t) + +(ctu:file-compile + `((in-package :macro-killing-macro-2) + (defmacro to-die-for () + :replacement))) + +(with-test (:name :defmacro-killing-macro) + (assert (eq :original (macroexpand '(macro-killing-macro-1:to-die-for))))) + +(ctu:file-compile + `((in-package :macro-killing-macro-2) + (eval-when (:compile-toplevel) + (setf (macro-function 'to-die-for) (constantly :replacement2))))) + +(with-test (:name :setf-macro-function-killing-macro) + (assert (eq :original (macroexpand '(macro-killing-macro-1:to-die-for))))) + ;;; WOOT! Done. diff --git a/version.lisp-expr b/version.lisp-expr index bfc1939..8ee4fe3 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.43.59" +"1.0.43.60"