* 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.
* 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
;; 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)
;; 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
;;
;; 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))
(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
- "~@<new FTYPE proclamation for ~S~@:_ ~S~@:_~
+ (: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
+ "~@<new FTYPE proclamation for ~S~@:_ ~S~@:_~
does not match the old FTYPE proclamation:~@:_ ~S~@:>"
- 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)
(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
;;; 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)
;;;; 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.
(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.
(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
(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*)
;;; 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"
projects / sbcl.git / commitdiff