From cb5d2f3f14259fe781729eeb10487b1a8a7ab622 Mon Sep 17 00:00:00 2001
From: ram <ram>
Date: Wed, 17 Oct 1990 04:15:38 +0000
Subject: [PATCH] Yet more structure redefinition hacks.  Mostly rewrote
 UNDEFINE-STRUCTURE to be less obscure.  Made it clear the SPECIFIER-TYPE
 cache so that subsequent references will be noticed as unknown.  In
 DEFINE-DEFSTRUCT-NAME, quietly blow away any existing ACCESSOR-FOR. This is
 necessary now that we don't always undefine a structure before redefining it,
 but it may also help with some of the spurious undefining that was happening.
  Broke off redefinition hackery into CHECK-FOR-STRUCTURE-REDEFINITION.  This
 function checks for incompatible redefinition, and only undefines the
 structure if the redefinition is incompatible.

---
 compiler/proclaim.lisp | 109 +++++++++++++++++++++++++++--------------
 1 file changed, 71 insertions(+), 38 deletions(-)

diff --git a/compiler/proclaim.lisp b/compiler/proclaim.lisp
index 9cf9ccfb9..1dca1518e 100644
--- a/compiler/proclaim.lisp
+++ b/compiler/proclaim.lisp
@@ -334,59 +334,102 @@
 ;;; 
 (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))
+  (let* ((name (dd-name info))
+	 (all-types (cons name (dd-included-by info))))
+    ;;
+    ;; Iterate over this type and all subtypes, clearing the compiler structure
+    ;; type info, and undefining all the associated functions.
+    (dolist (type all-types)
+      (let ((this-info (info type structure-info type)))
+	(setf (info type kind type) nil)
+	(setf (info type structure-info type) nil)
+	(undefine-function-name (dd-copier this-info))
+	(undefine-function-name (dd-predicate this-info))
+	(dolist (slot (dd-slots this-info))
+	  (let ((fun (dsd-accessor slot)))
+	    (undefine-function-name fun)
+	    (unless (dsd-read-only slot)
+	      (undefine-function-name `(setf ,fun)))))))
     ;;
-    ;; Update the INCLUDED-BY list, copying the DD and included list so that we
-    ;; don't clobber the type in the compiler's Lisp.
+    ;; Iterate over all types that include this type, removing this type and
+    ;; all subtypes from the list of subtypes of the included type.  We copy
+    ;; the DD and included list so that we don't clobber the type in the
+    ;; compiler's Lisp.
     (dolist (include (dd-includes info))
-      (let ((iinfo (info type structure-info include)))
-	(when iinfo
-	  (let ((new (copy-defstruct-description iinfo)))
-	    (setf (dd-included-by new) (remove name (dd-included-by new)))
-	    (setf (info type structure-info include) new))))))
-
-  (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)))))
-
+      (let ((new (copy-defstruct-description
+		  (info type structure-info include))))
+	(setf (dd-included-by new)
+	      (set-difference (dd-included-by new) all-types))
+	(setf (info type structure-info include) new))))
+  ;;
+  ;; Clear out the SPECIFIER-TYPE cache so that subsequent references are
+  ;; unknown types.
+  (values-specifier-type-cache-clear)
   (undefined-value))
 
 
 ;;; DEFINE-DEFSTRUCT-NAME  --  Internal
 ;;;
 ;;;    Like DEFINE-FUNCTION-NAME, but we also set the kind to :DECLARED and
-;;; blow away any ASSUMED-TYPE.
+;;; blow away any ASSUMED-TYPE.  Also, if the thing is a slot accessor
+;;; currently, quietly unaccessorize it.
 ;;;
 (defun define-defstruct-name (name)
   (when name
+    (when (info function accessor-for name)
+      (setf (info function accessor-for name) nil))
     (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))
 
-  
+
+;;; CHECK-FOR-STRUCTURE-REDEFINITION  --  Internal
+;;;
+;;;    Called when we process a DEFSTRUCT for a type that is already defined
+;;; for a structure.  We check for incompatible redefinition and undefine the
+;;; old structure if so.  We ignore the structures that DEFSTRUCT is built out
+;;; of, since they have to be hackishly defined in type-boot.  If the structure
+;;; is not incompatibly redefined, then we copy the old INCLUDED-BY into the
+;;; new structure.
+;;;
+(defun check-for-structure-redefinition (info)
+  (declare (type defstruct-description info))
+  (let* ((name (dd-name info))
+	 (old (info type structure-info name)))
+    (cond ((member name
+		   '(defstruct-description defstruct-slot-description)))
+	  ((and (equal (dd-includes old) (dd-includes info))
+		(equalp (dd-slots old) (dd-slots info)))
+	   (setf (dd-included-by info) (dd-included-by old)))
+	  (t
+	   (compiler-warning
+	    "Incompatibly redefining structure ~S.~@
+	    Removing the old definition~:[.~;~:* and these subtypes:~%  ~S~]"
+	    name (dd-included-by old))
+	   (undefine-structure old))))
+  (undefined-value))
+
+	   
 ;;; %%Compiler-Defstruct  --  Interface
 ;;;
 ;;;    This function updates the global compiler information to represent the
-;;; definition of the the structure described by Info.
+;;; definition of the the structure described by Info.  In addition to defining
+;;; all the functions and slots, we also update the INCLUDED-BY info in the
+;;; compiler's environment.  Note that at the first time the DEFSTRUCT is
+;;; loaded, STRUCTURE-INFO is EQ to DEFINED-STRUCTURE-INFO, so the name will
+;;; already be in INCLUDED-BY.  When we do update this info, we copy the
+;;; defstruct description so that the type definition in the compiler's Lisp
+;;; isn't trashed.
 ;;;
 (defun %%compiler-defstruct (info)
   (declare (type defstruct-description info))
   (let ((name (dd-name info)))
     (ecase (info type kind name)
-      ((nil :structure))
+      ((nil))
+      (:structure
+       (check-for-structure-redefinition info))
       (:primitive
        (compiler-error "Illegal to redefine standard type ~S." name))
       (:defined
@@ -394,21 +437,11 @@
 			 name)
        (setf (info type expander name) nil)))
 
-    (let ((old (info type structure-info name)))
-      (when 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))
-	;;
-	;; Note that NAME will already be in INCLUDED-BY at the first time the
-	;; DEFSTRUCT is loaded, since STRUCTURE-INFO is then EQ to
-	;; DEFINED-STRUCTURE-INFO, so %DEFSTRUCT has already added NAME to the
-	;; list.  The purpose of the copying is for the compiler's info
-	;; on compiling a new definition.
 	(unless (member name (dd-included-by info))
 	  (let ((new (copy-defstruct-description info)))
 	    (setf (info type structure-info inc) new)
-- 
GitLab