Skip to content
Snippets Groups Projects
Commit bd3d965b authored by rtoy's avatar rtoy
Browse files

Make CMUCL signal a cerror if we try to redefine a slot accessor. If

continued, the accessor is redefined.  Previously, a warning was
printed and the structure was (mostly) undefined.

compiler/proclaim.lisp:
o Add new function NOTE-IF-ACCESSOR to check if we're redefining a
  slot accessor.  If so, signal a cerror, and redefine if continued.
o Adjust DEFINE-FUNCTION-NAME to call NOTE-IF-ACCESSOR.

compiler/main.lisp:
o Make COMPILE-FIX-FUNCTION-NAME call NOTE-IF-ACCESSOR to catch
  attempts to redefine a slot-accessor.

code/macros.lisp:
o Move call to C::DEFINE-FUNCTION-NAME to the top of C::%%DEFUN before
  we set the fdefinition.   This allows us to give up before modifying
  anything if we choose not to redefine the slot accessor.
parent b39d3a62
No related branches found
No related tags found
No related merge requests found
...@@ -5,7 +5,7 @@ ...@@ -5,7 +5,7 @@
;;; Carnegie Mellon University, and has been placed in the public domain. ;;; Carnegie Mellon University, and has been placed in the public domain.
;;; ;;;
(ext:file-comment (ext:file-comment
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/macros.lisp,v 1.113 2009/06/18 17:34:58 rtoy Rel $") "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/macros.lisp,v 1.114 2010/03/18 16:43:11 rtoy Exp $")
;;; ;;;
;;; ********************************************************************** ;;; **********************************************************************
;;; ;;;
...@@ -351,12 +351,12 @@ ...@@ -351,12 +351,12 @@
;;; Similar to %Defmacro, ... ;;; Similar to %Defmacro, ...
;;; ;;;
(defun c::%%defun (name def doc &optional inline-expansion) (defun c::%%defun (name def doc &optional inline-expansion)
(c::define-function-name name)
(setf (fdefinition name) def) (setf (fdefinition name) def)
(when doc (when doc
(if (and (consp name) (eq (first name) 'setf)) (if (and (consp name) (eq (first name) 'setf))
(setf (documentation (second name) 'setf) doc) (setf (documentation (second name) 'setf) doc)
(setf (documentation name 'function) doc))) (setf (documentation name 'function) doc)))
(c::define-function-name name)
(when (eq (info function where-from name) :assumed) (when (eq (info function where-from name) :assumed)
(setf (info function where-from name) :defined) (setf (info function where-from name) :defined)
(when (info function assumed-type name) (when (info function assumed-type name)
......
...@@ -5,7 +5,7 @@ ...@@ -5,7 +5,7 @@
;;; Carnegie Mellon University, and has been placed in the public domain. ;;; Carnegie Mellon University, and has been placed in the public domain.
;;; ;;;
(ext:file-comment (ext:file-comment
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/main.lisp,v 1.151 2010/03/16 14:13:24 rtoy Exp $") "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/main.lisp,v 1.152 2010/03/18 16:43:12 rtoy Exp $")
;;; ;;;
;;; ********************************************************************** ;;; **********************************************************************
;;; ;;;
...@@ -1919,6 +1919,7 @@ in the user USER-INFO slot of STREAM-SOURCE-LOCATIONs.") ...@@ -1919,6 +1919,7 @@ in the user USER-INFO slot of STREAM-SOURCE-LOCATIONs.")
(defun compile-fix-function-name (lambda name) (defun compile-fix-function-name (lambda name)
(declare (type clambda lambda) (type (or symbol cons) name)) (declare (type clambda lambda) (type (or symbol cons) name))
(when name (when name
(note-if-accessor name)
(let ((fun (ref-leaf (let ((fun (ref-leaf
(continuation-next (continuation-next
(node-cont (lambda-bind lambda)))))) (node-cont (lambda-bind lambda))))))
......
...@@ -5,7 +5,7 @@ ...@@ -5,7 +5,7 @@
;;; Carnegie Mellon University, and has been placed in the public domain. ;;; Carnegie Mellon University, and has been placed in the public domain.
;;; ;;;
(ext:file-comment (ext:file-comment
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/proclaim.lisp,v 1.44 2007/11/14 10:04:35 cshapiro Rel $") "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/proclaim.lisp,v 1.45 2010/03/18 16:43:12 rtoy Exp $")
;;; ;;;
;;; ********************************************************************** ;;; **********************************************************************
;;; ;;;
...@@ -224,28 +224,35 @@ ...@@ -224,28 +224,35 @@
name))) name)))
(undefined-value)) (undefined-value))
;;; Note-If-Accessor -- Interface
;;;
;;; Check if Name is also the name of a slot accessor for some
;;; structure. If it is, we signal an continuable error. If we
;;; continue, assume the user knows what he's doing and redefine the
;;; function.
(defun note-if-accessor (name)
(let ((for (info function accessor-for name)))
(when for
(cerror "Assume redefinition is compatible and allow it"
"Redefining slot accessor ~S for structure type ~S"
name (%class-name for))
;;(undefine-structure for)
(setf (info function kind name) :function))))
;;; Define-Function-Name -- Interface ;;; Define-Function-Name -- Interface
;;; ;;;
;;; Check the legality of a function name that is being introduced. ;;; Check the legality of a function name that is being introduced.
;;; -- If it names a macro, then give a warning and blast the macro ;;; -- If it names a macro, then give a warning and blast the macro
;;; information. ;;; information.
;;; -- If it is a structure slot accessor, give a warning and blast the ;;; -- If it is a structure slot accessor, give a continuable error
;;; structure. ;;; and allow redefinition if continued.
;;; -- Check for conflicting setf macros. ;;; -- Check for conflicting setf macros.
;;; ;;;
(defun define-function-name (name) (defun define-function-name (name)
(check-function-name name) (check-function-name name)
(ecase (info function kind name) (ecase (info function kind name)
(:function (:function
(let ((for (info function accessor-for name))) (note-if-accessor name))
(when for
(compiler-warning
"Undefining structure type:~% ~S~@
so that this slot accessor can be redefined:~% ~S"
(%class-name for) name)
(undefine-structure for)
(setf (info function kind name) :function))))
(:macro (:macro
(compiler-warning "~S previously defined as a macro." name) (compiler-warning "~S previously defined as a macro." name)
(setf (info function kind name) :function) (setf (info function kind name) :function)
......
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment