From dc2326e77a416c5bc56172af466aeec190e02db8 Mon Sep 17 00:00:00 2001
From: ram <ram>
Date: Mon, 30 Aug 1993 15:10:20 +0000
Subject: [PATCH] Added support for  non-hierarchical "structures" when
 defining default accessor closures.  Changed UNDEFINE-STRUCTURE to take a
 class, since that's how compiler/proclaim is calling it.

---
 code/defstruct.lisp | 98 ++++++++++++++++++++++++++++-----------------
 1 file changed, 62 insertions(+), 36 deletions(-)

diff --git a/code/defstruct.lisp b/code/defstruct.lisp
index fbb13250f..db7c866d7 100644
--- a/code/defstruct.lisp
+++ b/code/defstruct.lisp
@@ -7,7 +7,7 @@
 ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/defstruct.lisp,v 1.53 1993/08/22 22:21:00 wlott Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/defstruct.lisp,v 1.54 1993/08/30 15:10:20 ram Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -1058,26 +1058,50 @@
 ;;; (not raw.)
 ;;;
 (defun structure-slot-accessor (layout dsd)
-  #'(lambda (structure)
-      (declare (optimize (speed 3) (safety 0)))
-      (unless (typep-to-layout structure layout)
-	(error "Structure for accessor ~S is not a ~S:~% ~S"
-	       (dsd-accessor dsd) (class-name (layout-class layout))
-	       structure))
-      (%instance-ref structure (dsd-index dsd))))
+  (let ((class (layout-class layout)))
+    (if (typep class 'basic-structure-class)
+	#'(lambda (structure)
+	    (declare (optimize (speed 3) (safety 0)))
+	    (unless (typep-to-layout structure layout)
+	      (error "Structure for accessor ~S is not a ~S:~% ~S"
+		     (dsd-accessor dsd) (class-name (layout-class layout))
+		     structure))
+	    (%instance-ref structure (dsd-index dsd)))
+	#'(lambda (structure)
+	    (declare (optimize (speed 3) (safety 0)))
+	    (unless (%typep structure class)
+	      (error "Structure for accessor ~S is not a ~S:~% ~S"
+		     (dsd-accessor dsd) class
+		     structure))
+	    (%instance-ref structure (dsd-index dsd))))))
 ;;;
 (defun structure-slot-setter (layout dsd)
-  #'(lambda (new-value structure)
-      (declare (optimize (speed 3) (safety 0)))
-      (unless (typep-to-layout structure layout)
-	(error "Structure for setter ~S is not a ~S:~% ~S"
-	       `(setf ,(dsd-accessor dsd)) (class-name (layout-class layout))
-	       structure))
-      (unless (typep new-value (dsd-type dsd))
-	(error "New-Value for setter ~S is not a ~S:~% ~S."
-	       `(setf ,(dsd-accessor dsd)) (dsd-type dsd)
-	       new-value))
-      (setf (%instance-ref structure (dsd-index dsd)) new-value)))
+  (let ((class (layout-class layout)))
+    (if (typep class 'basic-structure-class)
+	#'(lambda (new-value structure)
+	    (declare (optimize (speed 3) (safety 0)))
+	    (unless (typep-to-layout structure layout)
+	      (error "Structure for setter ~S is not a ~S:~% ~S"
+		     `(setf ,(dsd-accessor dsd))
+		     (class-name (layout-class layout))
+		     structure))
+	    (unless (%typep new-value (dsd-type dsd))
+	      (error "New-Value for setter ~S is not a ~S:~% ~S."
+		     `(setf ,(dsd-accessor dsd)) (dsd-type dsd)
+		     new-value))
+	    (setf (%instance-ref structure (dsd-index dsd)) new-value))
+	#'(lambda (new-value structure)
+	    (declare (optimize (speed 3) (safety 0)))
+	    (unless (%typep structure class)
+	      (error "Structure for setter ~S is not a ~S:~% ~S"
+		     `(setf ,(dsd-accessor dsd))
+		     (class-name class)
+		     structure))
+	    (unless (%typep new-value (dsd-type dsd))
+	      (error "New-Value for setter ~S is not a ~S:~% ~S."
+		     `(setf ,(dsd-accessor dsd)) (dsd-type dsd)
+		     new-value))
+	    (setf (%instance-ref structure (dsd-index dsd)) new-value)))))
 
 
 ;;; %Defstruct  --  Internal
@@ -1277,25 +1301,26 @@
 
 ;;; UNDEFINE-STRUCTURE  --  Interface
 ;;;
-;;;    Blow away all the compiler info for the structure described by Info.
+;;;    Blow away all the compiler info for the structure CLASS.
 ;;; Iterate over this type, clearing the compiler structure
 ;;; type info, and undefining all the associated functions.
 ;;; 
-(defun undefine-structure (info)
-  (when (defstruct-description-p info)
-    (let ((type (dd-name info)))
-      (setf (info type compiler-layout type) nil)
-      (undefine-function-name (dd-copier info))
-      (undefine-function-name (dd-predicate info))
-      (dolist (slot (dd-slots info))
-	(let ((fun (dsd-accessor slot)))
-	  (undefine-function-name fun)
-	  (unless (dsd-read-only slot)
-	    (undefine-function-name `(setf ,fun))))))
-    ;;
-    ;; Clear out the SPECIFIER-TYPE cache so that subsequent references are
-    ;; unknown types.
-    (values-specifier-type-cache-clear))
+(defun undefine-structure (class)
+  (let ((info (layout-info (class-layout class))))
+    (when (defstruct-description-p info)
+      (let ((type (dd-name info)))
+	(setf (info type compiler-layout type) nil)
+	(undefine-function-name (dd-copier info))
+	(undefine-function-name (dd-predicate info))
+	(dolist (slot (dd-slots info))
+	  (let ((fun (dsd-accessor slot)))
+	    (undefine-function-name fun)
+	    (unless (dsd-read-only slot)
+	      (undefine-function-name `(setf ,fun))))))
+      ;;
+      ;; Clear out the SPECIFIER-TYPE cache so that subsequent references are
+      ;; unknown types.
+      (values-specifier-type-cache-clear)))
   (undefined-value))
 
 
@@ -1366,7 +1391,8 @@
 		 (not (eq layout old-layout)))
 	(collect ((subs))
 	  (do-hash (class layout (class-subclasses class))
-	    (undefine-structure (layout-info layout))
+	    (declare (ignore layout))
+	    (undefine-structure class)
 	    (subs (class-proper-name class)))
 	  (when (subs)
 	    (warn "Removing old subclasses of ~S:~%  ~S"
-- 
GitLab