From 5229e2dcf8081e1edd309c875392bc9a208be3a9 Mon Sep 17 00:00:00 2001
From: ram <ram>
Date: Fri, 12 Oct 1990 01:26:49 +0000
Subject: [PATCH] Many changes for more robust redefinition of DEFfoos to
 DEFbars. We give a note if we see a function related thing for a SETF name
 that has a SETF macro as well.  This NOTE-IF-SETF-FUNCTION-AND-MACRO also is
 used in ir1tran. Changed DEFINE-FUNCTION-NAME to call the above, and also to
 check for redefining a slot accessor or alien operator. Added
 UNDEFINE-FUNCTION-NAME.  Added UNDEFINE-STRUCTURE, which uses the previous. 
 Structures are undefined whenever we change a structure or its supertypes, or
 whenever we redefine an accessor as some other kind of function.  This causes
 a warning. Changed DEFSTRUCT to make the accessors WHERE-FROM :DECLARED
 rather than :DEFINED, since the stronger claim seems reasonable. Made
 %%COMPILER-DEFSTRUCT flame if we try to define a primitive type and warn if
 we redefine a DEFTYPE.

---
 compiler/proclaim.lisp | 179 ++++++++++++++++++++++++++++++++---------
 1 file changed, 139 insertions(+), 40 deletions(-)

diff --git a/compiler/proclaim.lisp b/compiler/proclaim.lisp
index 0799798a6..807f7895e 100644
--- a/compiler/proclaim.lisp
+++ b/compiler/proclaim.lisp
@@ -64,9 +64,6 @@
 ;;; specifiers are just passed through untouched.  If something is wrong, we
 ;;; use Compiler-Error, aborting compilation to the last recovery point.
 ;;;
-;;; [Eventually this should go into the code sources, since it is used in
-;;; various random places such as the function type parsing.]
-;;;
 (proclaim '(function parse-lambda-list (list)
 		     (values list list boolean t boolean list boolean list)))
 (defun parse-lambda-list (list)
@@ -142,18 +139,53 @@
      (compiler-error "Illegal function name: ~S." name))))
 
 
+;;; NOTE-IF-SETF-FUNCTION-AND-MACRO  --  Interface
+;;;
+;;;    Called to do something about SETF functions that overlap with setf
+;;; macros.  Perhaps we should interact with the user to see if the macro
+;;; should be blown away, but for now just give a warning.  Due to the weak
+;;; semantics of the (SETF FUNCTION) name, we can't assume that they aren't
+;;; just naming a function (SETF FOO) for the heck of it.  Name is already
+;;; known to be well-formed.
+;;;
+(defun note-if-setf-function-and-macro (name)
+  (when (consp name)
+    (when (or (info setf inverse name)
+	      (info setf expander name))
+      (compiler-warning
+       "Defining as a SETF function a name that already has a SETF macro:~
+       ~%  ~S"
+       name)))
+  (undefined-value))
+
+
 ;;; 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.
+;;;    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. 
+;;; -- Check for conflicting setf macros.
 ;;;
 (proclaim '(function define-function-name (t) void))
 (defun define-function-name (name)
   (check-function-name name)
   (ecase (info function kind name)
-    (:function)
-    (:special-from
-     (compiler-error "~S names a special form, so cannot be a function." 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"
+	  (dd-name for) name)
+	 (undefine-structure for)
+	 (setf (info function kind name) :function)))
+     (when (info function alien-operator name)
+       (compiler-warning "Redefining alien operator as normal function:~%  ~S"
+			 name)
+       (setf (info function alien-operator name) nil)
+       (setf (info function source-transform name) nil)))
     (:macro
      (compiler-warning "~S previously defined as a macro." name)
      (setf (info function kind name) :function)
@@ -161,9 +193,34 @@
      (clear-info function macro-function name))
     ((nil)
      (setf (info function kind name) :function)))
+  
+
+  (note-if-setf-function-and-macro name)
   name)
 
 
+;;; UNDEFINE-FUNCTION-NAME  --  Interface
+;;;
+;;;    Make Name no longer be a function name: clear everything back to the
+;;; default.
+;;;
+(defun undefine-function-name (name)
+  (when name
+    (macrolet ((frob (type &optional val)
+		 `(unless (eq (info function ,type name) ,val)
+		    (setf (info function ,type name) ,val))))
+      (frob type (specifier-type 'function))
+      (frob where-from :assumed)
+      (frob inlinep)
+      (frob kind)
+      (frob accessor-for)
+      (frob inline-expansion)
+      (frob alien-operator)
+      (frob source-transform)
+      (frob assumed-type)))
+  (undefined-value))
+
+
 ;;; Process-Optimize-Declaration  --  Interface
 ;;;
 ;;;    Return a new cookie containing the policy information represented by the
@@ -270,6 +327,53 @@
 (setf (symbol-function 'proclaim) #'%proclaim)
 
 
+;;; UNDEFINE-STRUCTURE  --  Interface
+;;;
+;;;    Blow away all the compiler info for the structure described by Info.
+;;; This recursively descends the inheritance hierarchy.
+;;; 
+(defun undefine-structure (info)
+  (declare (type defstruct-description info))
+  (let ((name (dd-name info)))
+    (setf (info type kind name) nil)
+    (setf (info type structure-info name) nil)
+    (undefine-function-name (dd-copier info))
+    (undefine-function-name (dd-predicate info))
+    
+    (dolist (include (dd-includes info))
+      (let ((iinfo (info type structure-info include)))
+	(when iinfo
+	  (setf (dd-included-by iinfo)
+		(delete name (dd-included-by iinfo)))))))
+
+  (dolist (included (dd-included-by info))
+    (let ((iinfo (info type structure-info included)))
+      (when iinfo
+	(undefine-structure iinfo))))
+      
+  (dolist (slot (dd-slots info))
+    (let ((fun (dsd-accessor slot)))
+      (undefine-function-name fun)
+      (unless (dsd-read-only slot)
+	(undefine-function-name `(setf ,fun)))))
+
+  (undefined-value))
+
+
+;;; DEFINE-DEFSTRUCT-NAME  --  Internal
+;;;
+;;;    Like DEFINE-FUNCTION-NAME, but we also set the kind to :DECLARED and
+;;; blow away any ASSUMED-TYPE.
+;;;
+(defun define-defstruct-name (name)
+  (when name
+    (define-function-name name)
+    (setf (info function where-from name) :declared)
+    (when (info function assumed-type name)
+      (setf (info function assumed-type name) nil)))
+  (undefined-value))
+
+  
 ;;; %%Compiler-Defstruct  --  Interface
 ;;;
 ;;;    This function updates the global compiler information to represent the
@@ -277,51 +381,46 @@
 ;;;
 (defun %%compiler-defstruct (info)
   (declare (type defstruct-description info))
-
   (let ((name (dd-name info)))
-    (dolist (inc (dd-includes info))
-      (let ((info (info type structure-info inc)))
-	(unless info
-	  (error "Structure type ~S is included by ~S but not defined."
-		 inc name))
-	(pushnew name (dd-included-by info))))
+    (ecase (info type kind name)
+      ((nil :structure))
+      (:primitive
+       (compiler-error "Illegal to redefine standard type ~S." name))
+      (:defined
+       (compiler-warning "Redefining DEFTYPE type to be a DEFSTRUCT: ~S."
+			 name)
+       (setf (info type expander name) nil)))
 
     (let ((old (info type structure-info name)))
       (when old
-	(setf (dd-included-by info) (dd-included-by old))))
+	(setf (dd-included-by info) (copy-list (dd-included-by old)))
+	(undefine-structure old))
+      (dolist (inc (dd-includes info))
+	(let ((info (info type structure-info inc)))
+	  (unless info
+	    (error "Structure type ~S is included by ~S but not defined."
+		   inc name))
+	  (pushnew name (dd-included-by info)))))
 
     (setf (info type kind name) :structure)
     (setf (info type structure-info name) info)
-    (when (info type expander name)
-      (setf (info type expander name) nil))
-    (%note-type-defined name))
-
-  ;;; ### Should declare arg/result types. 
-  (let ((copier (dd-copier info)))
-    (when copier
-      (define-function-name copier)
-      (setf (info function where-from copier) :defined)))
+    (%note-type-defined name)
+    
+    (let ((copier (dd-copier info)))
+      (when copier
+	(%proclaim `(ftype (function (,name) ,name) ,copier)))))
 
   ;;; ### Should make a known type predicate.
-  (let ((predicate (dd-predicate info)))
-    (when predicate
-      (define-function-name predicate)
-      (setf (info function where-from predicate) :defined)))
+  (define-defstruct-name (dd-predicate info))
 
   (dolist (slot (dd-slots info))
-    (let ((fun (dsd-accessor slot)))
-      (define-function-name fun)
+    (let* ((fun (dsd-accessor slot))
+	   (setf-fun `(setf ,fun)))
+      (define-defstruct-name fun)
       (setf (info function accessor-for fun) info)
-      ;;
-      ;; ### Bootstrap hack...
-      ;; This blows away any inverse that has been loaded into the bootstrap
-      ;; environment.  Probably this should be more general (expanders, etc.),
-      ;; and also perhaps done on other functions.
-      (when (info setf inverse fun)
-	(setf (info setf inverse fun) nil))
-      
       (unless (dsd-read-only slot)
-	(setf (info function accessor-for `(setf ,fun)) info))))
+	(define-defstruct-name setf-fun)
+	(setf (info function accessor-for setf-fun) info))))
   (undefined-value))
 
 (setf (symbol-function '%compiler-defstruct) #'%%compiler-defstruct)
-- 
GitLab