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