CMUCL commit: src (3 files)

[Raymond Toy]

    Date: Thursday, March 18, 2010 @ 12:43:12
  Author: rtoy
    Path: /project/cmucl/cvsroot/src

Modified: code/macros.lisp compiler/main.lisp compiler/proclaim.lisp

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(-)


Index: src/code/macros.lisp
diff -u src/code/macros.lisp:1.113 src/code/macros.lisp:1.114
--- src/code/macros.lisp:1.113	Thu Jun 18 13:34:58 2009
+++ src/code/macros.lisp	Thu Mar 18 12:43:11 2010
@@ -5,7 +5,7 @@
 ;;; Carnegie Mellon University, and has been placed in the public domain.
 ;;;
 (ext:file-comment
-  "$Header: /project/cmucl/cvsroot/src/code/macros.lisp,v 1.113 2009-06-18 17:34:58 rtoy Rel $")
+  "$Header: /project/cmucl/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)
Index: src/compiler/main.lisp
diff -u src/compiler/main.lisp:1.151 src/compiler/main.lisp:1.152
--- src/compiler/main.lisp:1.151	Tue Mar 16 10:13:24 2010
+++ src/compiler/main.lisp	Thu Mar 18 12:43:12 2010
@@ -5,7 +5,7 @@
 ;;; Carnegie Mellon University, and has been placed in the public domain.
 ;;;
 (ext:file-comment
-  "$Header: /project/cmucl/cvsroot/src/compiler/main.lisp,v 1.151 2010-03-16 14:13:24 rtoy Exp $")
+  "$Header: /project/cmucl/cvsroot/src/compiler/main.lisp,v 1.152 2010-03-18 16:43:12 rtoy Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -1919,6 +1919,7 @@
 (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))))))
Index: src/compiler/proclaim.lisp
diff -u src/compiler/proclaim.lisp:1.44 src/compiler/proclaim.lisp:1.45
--- src/compiler/proclaim.lisp:1.44	Wed Nov 14 05:04:35 2007
+++ src/compiler/proclaim.lisp	Thu Mar 18 12:43:12 2010
@@ -5,7 +5,7 @@
 ;;; Carnegie Mellon University, and has been placed in the public domain.
 ;;;
 (ext:file-comment
-  "$Header: /project/cmucl/cvsroot/src/compiler/proclaim.lisp,v 1.44 2007-11-14 10:04:35 cshapiro Rel $")
+  "$Header: /project/cmucl/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)