From d994238bcba6f8c695a33d55ad6259ffeb41a0c7 Mon Sep 17 00:00:00 2001
From: ram <ram>
Date: Mon, 8 Feb 1993 22:08:13 +0000
Subject: [PATCH] Updated find-free-function accessor hackery to work with
 CLASS ACCESSOR-FOR and still support the old value for bootstrapping. Qualify
 KERNEL:%COMPILER-DEFSTRUCT because it's shadowed.

---
 compiler/ir1tran.lisp | 50 +++++++++++++++++++++++++++++++++----------
 1 file changed, 39 insertions(+), 11 deletions(-)

diff --git a/compiler/ir1tran.lisp b/compiler/ir1tran.lisp
index 56f2b06f9..292489153 100644
--- a/compiler/ir1tran.lisp
+++ b/compiler/ir1tran.lisp
@@ -7,7 +7,7 @@
 ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/ir1tran.lisp,v 1.83.1.2 1993/01/23 14:42:04 ram Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/ir1tran.lisp,v 1.83.1.3 1993/02/08 22:08:13 ram Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -141,12 +141,33 @@
 		     :where-from where)))
 
 
-;;; Find-Slot-Accessor  --  Internal
+;;; Find-Structure-Slot-Accessor  --  Internal
 ;;;
 ;;;    Return a Slot-Accessor structure usable for referencing the slot
-;;; accessor Name.  Info is the structure definition.
-;;;
-(defun find-slot-accessor (info name)
+;;; accessor Name.  Class is the structure class.
+;;;
+(defun find-structure-slot-accessor (class name)
+  (declare (type class class))
+  (let* ((info (layout-info
+		(or (info type compiler-layout (class-name class))
+		    (class-layout class))))
+	 (accessor (if (listp name) (cadr name) name))
+	 (slot (find accessor (kernel:dd-slots info)
+		     :key #'kernel:dsd-accessor))
+	 (type (kernel:dd-name info))
+	 (slot-type (kernel:dsd-type slot)))
+    (assert slot () "Can't find slot ~S." type)
+    (make-slot-accessor
+     :name name
+     :type (specifier-type
+	    (if (listp name)
+		`(function (,slot-type ,type) ,slot-type)
+		`(function (,type) ,slot-type)))
+     :for class
+     :slot slot)))
+
+#+ns-boot
+(defun find-old-slot-accessor (info name)
   (declare (type defstruct-description info))
   (let* ((accessor (if (listp name) (cadr name) name))
 	 (slot (find accessor (dd-slots info)
@@ -193,9 +214,15 @@
 					    :inlinep inlinep
 					    :type (info function type name))
 		     (let ((info (info function accessor-for name)))
-		       (if info
-			   (find-slot-accessor info name)
-			   (find-free-really-function name))))))))))
+		       (etypecase info
+			 (null
+			  (find-free-really-function name))
+			 (structure-class
+			  (find-structure-slot-accessor info name))
+			 #+ns-boot
+			 (defstruct-description
+			  (find-old-slot-accessor info name)))))))))))
+
 
 ;;; Find-Lexically-Apparent-Function  --  Internal
 ;;;
@@ -2601,9 +2628,10 @@
 ;;; *FREE-FUNCTIONS* to keep things in synch.  %%COMPILER-DEFSTRUCT is also
 ;;; called at load-time.
 ;;;
-(def-ir1-translator %compiler-defstruct ((info) start cont :kind :function)
+(def-ir1-translator kernel:%compiler-defstruct
+		    ((info) start cont :kind :function)
   (let* ((info (eval info)))
-    (%%compiler-defstruct info)
+    (kernel:%%compiler-defstruct info)
     (dolist (slot (dd-slots info))
       (let ((fun (dsd-accessor slot)))
 	(remhash fun *free-functions*)
@@ -2611,7 +2639,7 @@
 	  (remhash `(setf ,fun) *free-functions*))))
     (remhash (dd-predicate info) *free-functions*)
     (remhash (dd-copier info) *free-functions*)
-    (ir1-convert start cont `(%%compiler-defstruct ',info))))
+    (ir1-convert start cont `(kernel:%%compiler-defstruct ',info))))
 
 
 ;;;; Let and Let*:
-- 
GitLab