From: Nikodemus Siivola Date: Fri, 3 Sep 2010 13:01:32 +0000 (+0000) Subject: 1.0.42.28: package locks to guard against DEFMACRO -> DEFUN and vice-versa X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=7448b6225fa43ea6a61391990b173c09505ba45d;p=sbcl.git 1.0.42.28: package locks to guard against DEFMACRO -> DEFUN and vice-versa * Fixes lp#576637. * PROCLAIM-AS-FUN-NAME is called quite often at compile time, but actually does something we care about only rarely -- assert the lock only when something changes, so that (WITHOUT-PACKAGE-LOCKS (DEFUN LOCKED:FOO ...)) keeps working for the common case. * Similar logic in %DEFMACRO. * Some tests adjusted. --- diff --git a/NEWS b/NEWS index ad3cac1..9335ee2 100644 --- a/NEWS +++ b/NEWS @@ -37,6 +37,8 @@ changes relative to sbcl-1.0.42 * bug fix: the compiler threw an error when trying to compile a local function (labels or flet) known to take a specialized complex argument. (not in launchpad, reported by sykopomp in #lispgames) + * bug fix: package-locks failed to protect against compile-time effects of + DEFUN when the symbol previously had a macro definition. (lp#576637) changes in sbcl-1.0.42 relative to sbcl-1.0.41 diff --git a/src/code/defmacro.lisp b/src/code/defmacro.lisp index c43a723..a408ec9 100644 --- a/src/code/defmacro.lisp +++ b/src/code/defmacro.lisp @@ -61,41 +61,43 @@ ;; the functional value." ,@(unless set-p '((declare (ignore lambda-list debug-name)))) - (ecase (info :function :kind name) - ((nil)) - (:function - ;; (remhash name *free-funs*) - (undefine-fun-name name) - (style-warn - "~S is being redefined as a macro when it was ~ - previously ~(~A~) to be a function." - name - (info :function :where-from name))) - (:macro) - (:special-form - (error "The special form ~S can't be redefined as a macro." - 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/ ~ + (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 ~ + 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) + + ;; 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 e67f1a2..c0d9422 100644 --- a/src/compiler/info-functions.lisp +++ b/src/compiler/info-functions.lisp @@ -41,15 +41,28 @@ ;; legal name? (check-fun-name name) - ;; scrubbing old data I: possible collision with old definition - (when (fboundp name) - (ecase (info :function :kind name) - (:function) ; happy case - ((nil)) ; another happy case - (:macro ; maybe-not-so-good case - (compiler-style-warn "~S was previously defined as a macro." name) - (setf (info :function :where-from name) :assumed) - (clear-info :function :macro-function name)))) + + ;; KLUDGE: This can happen when eg. compiling a NAMED-LAMBDA, and isn't + ;; guarded against elsewhere -- so we want to assert package locks here. The + ;; reason we do it only when stomping on existing stuff is because we want + ;; to keep + ;; (WITHOUT-PACKAGE-LOCKS (DEFUN LOCKED:FOO ...)) + ;; viable, which requires no compile-time violations in the harmless cases. + (with-single-package-locked-error () + (flet ((assert-it () + (assert-symbol-home-package-unlocked name "proclaiming ~S as a function"))) + + (let ((kind (info :function :kind name))) + ;; scrubbing old data I: possible collision with a macro + (when (and (fboundp name) (eq :macro kind)) + (assert-it) + (compiler-style-warn "~S was previously defined as a macro." name) + (setf (info :function :where-from name) :assumed) + (clear-info :function :macro-function name)) + + (unless (eq :function kind) + (assert-it) + (setf (info :function :kind name) :function))))) ;; scrubbing old data II: dangling forward references ;; @@ -58,11 +71,9 @@ ;; in EVAL-WHEN (:COMPILE) inside something like DEFSTRUCT, in which ;; case it's reasonable style. Either way, NAME is no longer a free ;; function.) - (when (boundp '*free-funs*) ; when compiling + (when (boundp '*free-funs*) ; when compiling (remhash name *free-funs*)) - ;; recording the ordinary case - (setf (info :function :kind name) :function) (note-if-setf-fun-and-macro name) (values)) diff --git a/src/compiler/proclaim.lisp b/src/compiler/proclaim.lisp index ed78315..6e7fc38 100644 --- a/src/compiler/proclaim.lisp +++ b/src/compiler/proclaim.lisp @@ -226,29 +226,29 @@ (error "not a function type: ~S" (first args))) (dolist (name (rest args)) (with-single-package-locked-error - (:symbol name "globally declaring the ftype of ~A")) - (when (eq (info :function :where-from name) :declared) - (let ((old-type (info :function :type name))) - (when (type/= ctype old-type) - ;; FIXME: changing to FTYPE-PROCLAMATION-MISMATCH - ;; broke late-proclaim.lisp. - (style-warn - "~@" - name (type-specifier ctype) (type-specifier old-type))))) + name (type-specifier ctype) (type-specifier old-type))))) - ;; Now references to this function shouldn't be warned - ;; about as undefined, since even if we haven't seen a - ;; definition yet, we know one is planned. - ;; - ;; Other consequences of we-know-you're-a-function-now - ;; are appropriate too, e.g. any MACRO-FUNCTION goes away. - (proclaim-as-fun-name name) - (note-name-defined name :function) + ;; Now references to this function shouldn't be warned + ;; about as undefined, since even if we haven't seen a + ;; definition yet, we know one is planned. + ;; + ;; Other consequences of we-know-you're-a-function-now + ;; are appropriate too, e.g. any MACRO-FUNCTION goes away. + (proclaim-as-fun-name name) + (note-name-defined name :function) - ;; the actual type declaration - (setf (info :function :type name) ctype - (info :function :where-from name) :declared))) + ;; the actual type declaration + (setf (info :function :type name) ctype + (info :function :where-from name) :declared)))) (push raw-form *queued-proclaims*))) (freeze-type (dolist (type args) diff --git a/tests/package-locks.impure.lisp b/tests/package-locks.impure.lisp index 18e8bba..c9d9b7f 100644 --- a/tests/package-locks.impure.lisp +++ b/tests/package-locks.impure.lisp @@ -190,10 +190,10 @@ (unintern (or (find-symbol *interned* :test) (error "bugo")) :test) (delete-package :test-delete) - ;; defining or undefining as a function - (defun test:unused () 'foo) - (setf (fdefinition 'test:unused) (lambda () 'bar)) - (setf (symbol-function 'test:unused) (lambda () 'quux)) + ;; redefining or undefining as a function + (defun test:function () 'foo) + (setf (fdefinition 'test:function) (lambda () 'bar)) + (setf (symbol-function 'test:function) (lambda () 'quux)) (tmp-fmakunbound 'test:function) ;; defining or undefining as a macro or compiler macro @@ -332,29 +332,33 @@ ;;; Unlocked. No errors nowhere. (reset-test nil) -(dolist (form (append *legal-forms* *illegal-forms*)) - (with-error-info ("~Unlocked form: ~S~%" form) - (eval form))) +(with-test (:name :unlocked-package) + (dolist (form (append *legal-forms* *illegal-forms*)) + (with-error-info ("~Unlocked form: ~S~%" form) + (eval form)))) ;;; Locked. Errors for all illegal forms, none for legal. (reset-test t) -(dolist (form *legal-forms*) - (with-error-info ("locked legal form: ~S~%" form) - (eval form))) +(with-test (:name :locked-package/legal-forms) + (dolist (form *legal-forms*) + (with-error-info ("locked legal form: ~S~%" form) + (eval form)))) -(dolist (form (append *illegal-runtime-forms* *illegal-double-forms*)) - (with-error-info ("locked illegal runtime form: ~S~%" form) - (let ((fun (compile nil `(lambda () ,form)))) - (assert (raises-error? (funcall fun) sb-ext:package-lock-violation))) - (assert (raises-error? (eval form) sb-ext:package-lock-violation)))) - -(dolist (pair *illegal-lexical-forms-alist*) - (let ((form (cdr pair))) - (with-error-info ("compile locked illegal lexical form: ~S~%" form) +(with-test (:name :locked-package/illegal-runtime-forms) + (dolist (form (append *illegal-runtime-forms* *illegal-double-forms*)) + (with-error-info ("locked illegal runtime form: ~S~%" form) (let ((fun (compile nil `(lambda () ,form)))) - (assert (raises-error? (funcall fun) program-error))) - (assert (raises-error? (eval form) program-error))))) + (assert (raises-error? (funcall fun) sb-ext:package-lock-violation))) + (assert (raises-error? (eval form) sb-ext:package-lock-violation))))) + +(with-test (:name :locked-package/illegal-lexical-forms) + (dolist (pair *illegal-lexical-forms-alist*) + (let ((form (cdr pair))) + (with-error-info ("compile locked illegal lexical form: ~S~%" form) + (let ((fun (compile nil `(lambda () ,form)))) + (assert (raises-error? (funcall fun) program-error))) + (assert (raises-error? (eval form) program-error)))))) ;;; Locked, WITHOUT-PACKAGE-LOCKS (reset-test t) @@ -451,6 +455,7 @@ ;;;; See that trace on functions in locked packages doesn't break ;;;; anything. (assert (trace test:function :break t)) +(untrace test:function) ;;;; No bogus violations from defclass with accessors in a locked ;;;; package. Reported by by Francois-Rene Rideau. @@ -489,4 +494,14 @@ (assert (equal (loop :for *print-base* :from 2 :to 3 :collect *print-base*) '(2 3))) +;;; Package lock for DEFMACRO -> DEFUN and vice-versa. +(reset-test t) +(with-test (:name :bug-576637) + (assert (raises-error? (eval `(defun test:macro (x) x)) + sb-ext:package-lock-violation)) + (assert (eq 'test:macro (eval `(test:macro)))) + (assert (raises-error? (eval `(defmacro test:function (x) x)) + sb-ext:package-lock-violation)) + (assert (eq 'test:function (eval `(test:function))))) + ;;; WOOT! Done. diff --git a/tests/run-program.impure.lisp b/tests/run-program.impure.lisp index b6b38cf..4bba18e 100644 --- a/tests/run-program.impure.lisp +++ b/tests/run-program.impure.lisp @@ -84,8 +84,8 @@ (defun read-linish (stream) (with-output-to-string (s) (loop for c = (read-char stream) - while (and c (not (eq #\newline c)) (not (eq #\return c))) - do (write-char c s)))) + while (and c (not (eq #\newline c)) (not (eq #\return c))) + do (write-char c s)))) (defun assert-ed (command response) (when command @@ -100,7 +100,7 @@ (unwind-protect (with-test (:name :run-program-ed) (assert-ed nil "4") - (assert-ed ".s/bar/baz/g" "") + (assert-ed ".s/bar/baz/g" #-sunos "" #+sunos nil) (assert-ed "w" "4") (assert-ed "q" nil) (process-wait *ed*) diff --git a/version.lisp-expr b/version.lisp-expr index 90437cf..2fba010 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.42.27" +"1.0.42.28"