From bd3d965b46a90fbb2260fe4251a9ba8badfa0f4d Mon Sep 17 00:00:00 2001 From: rtoy <rtoy> Date: Thu, 18 Mar 2010 16:43:12 +0000 Subject: [PATCH] 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. --- code/macros.lisp | 4 ++-- compiler/main.lisp | 3 ++- compiler/proclaim.lisp | 29 ++++++++++++++++++----------- 3 files changed, 22 insertions(+), 14 deletions(-) diff --git a/code/macros.lisp b/code/macros.lisp index 2a7f74c25..475f6ee8b 100644 --- a/code/macros.lisp +++ b/code/macros.lisp @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (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 @@ ;;; Similar to %Defmacro, ... ;;; (defun c::%%defun (name def doc &optional inline-expansion) + (c::define-function-name name) (setf (fdefinition name) def) (when doc (if (and (consp name) (eq (first name) 'setf)) (setf (documentation (second name) 'setf) doc) (setf (documentation name 'function) doc))) - (c::define-function-name name) (when (eq (info function where-from name) :assumed) (setf (info function where-from name) :defined) (when (info function assumed-type name) diff --git a/compiler/main.lisp b/compiler/main.lisp index 7afaff77c..7e2ef3a8a 100644 --- a/compiler/main.lisp +++ b/compiler/main.lisp @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (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.") (defun compile-fix-function-name (lambda name) (declare (type clambda lambda) (type (or symbol cons) name)) (when name + (note-if-accessor name) (let ((fun (ref-leaf (continuation-next (node-cont (lambda-bind lambda)))))) diff --git a/compiler/proclaim.lisp b/compiler/proclaim.lisp index b32ae70d0..8217e21e6 100644 --- a/compiler/proclaim.lisp +++ b/compiler/proclaim.lisp @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (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 @@ name))) (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 ;;; ;;; Check the legality of a function name that is being introduced. ;;; -- If it names a macro, then give a warning and blast the macro ;;; information. -;;; -- If it is a structure slot accessor, give a warning and blast the -;;; structure. +;;; -- If it is a structure slot accessor, give a continuable error +;;; and allow redefinition if continued. ;;; -- Check for conflicting setf macros. ;;; (defun define-function-name (name) (check-function-name name) (ecase (info function kind name) (:function - (let ((for (info function accessor-for 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)))) + (note-if-accessor name)) (:macro (compiler-warning "~S previously defined as a macro." name) (setf (info function kind name) :function) -- GitLab