From 76272c4ebd1570eec4f2e323723be3272e8ea3c7 Mon Sep 17 00:00:00 2001
From: gerd <gerd>
Date: Wed, 7 May 2003 17:14:24 +0000
Subject: [PATCH] 	Add a deftransform for extracting slot vectors.  This
 can be done 	because redefinitions from funcallable instances to instances 
 aren't required to work, and cannot be made to work.

	* src/pcl/low.lisp (fsc-instance-wrapper, fsc-instance-slots)
	(fsc-instance-hash): Moved here from fin.lisp.
	(pcl::pcl-instance-p) <deftransform>: Use info-standard-class-p
	and info-funcallable-standard-class-p.
	(pcl::slot-vector-or-nil) <deftransform>: New.
	(slot-vector-or-nil): New function.

	* src/pcl/info.lisp (info-std-class-p): Removed.
	(info-standard-class-p, info-funcallable-standard-class-p):
	New functions.

	* src/pcl/fin.lisp (fsc-instance-wrapper, fsc-instance-slots)
	(fsc-instance-hash): Moved to low.lisp.

	* src/pcl/vector.lisp (pv-binding1): Use slot-vector-or-nil
	instead of get-slots-or-nil.
---
 pcl/fin.lisp    | 17 +---------
 pcl/info.lisp   | 24 +++++++-------
 pcl/low.lisp    | 85 +++++++++++++++++++++++++++++++++++++++----------
 pcl/vector.lisp |  4 +--
 4 files changed, 84 insertions(+), 46 deletions(-)

diff --git a/pcl/fin.lisp b/pcl/fin.lisp
index 05ce22ce3..38e9d89c2 100644
--- a/pcl/fin.lisp
+++ b/pcl/fin.lisp
@@ -25,7 +25,7 @@
 ;;; *************************************************************************
 
 (file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/fin.lisp,v 1.21 2003/05/04 13:11:21 gerd Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/fin.lisp,v 1.22 2003/05/07 17:14:24 gerd Rel $")
 ;;;
 
   ;;   
@@ -150,18 +150,3 @@ explicitly marked saying who wrote it.
   (assert (funcallable-instance-p fin))
   (setf (kernel:funcallable-instance-function fin) new-value))
 
-
-;;;; Slightly Higher-Level stuff built on the implementation-dependent stuff.
-;;;
-
-(defmacro fsc-instance-p (fin)
-  `(funcallable-instance-p ,fin))
-
-(defmacro fsc-instance-wrapper (fin)
-  `(kernel:%funcallable-instance-layout ,fin))
-
-(defmacro fsc-instance-slots (fin)
-  `(kernel:%funcallable-instance-info ,fin 0))
-
-(defmacro fsc-instance-hash (fin)
-  `(kernel:%funcallable-instance-info ,fin 2))
diff --git a/pcl/info.lisp b/pcl/info.lisp
index 99a60b7f4..0b547236b 100644
--- a/pcl/info.lisp
+++ b/pcl/info.lisp
@@ -36,7 +36,7 @@
 ;;; GF is actually non-accessor GF.  Clean this up.
 ;;; (setf symbol-value) should be handled like (setf fdefinition)
 
-(file-comment "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/info.lisp,v 1.4 2003/05/04 13:11:21 gerd Exp $")
+(file-comment "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/info.lisp,v 1.5 2003/05/07 17:14:24 gerd Exp $")
 
 (in-package "PCL")
 
@@ -233,18 +233,18 @@
 	  (slot-definition-type slotd)))))
 
 ;;;
-;;; Return T if CLASS-NAME names a STD-CLASS, that is, either a
-;;; STANDARD-CLASS or FUNCALLABLE-STANDARD-CLASS in normal MOP spaak.
+;;; Test if a class names a STANDARD-CLASS or FUNCALLABLE-STANDARD-CLASS.
 ;;;
-;;; Structure classes are defined at compile-time, see the EVAL in
-;;; EXPAND-DEFCLASS.  If it's a structure, the class must be defined,
-;;; and be a structure class.
-;;;
-(defun info-std-class-p (class-name)
-  (let ((class (find-class class-name nil)))
-    (if class
-	(std-class-p class)
-	(class-info class-name))))
+(macrolet ((defpred (name metaclass)
+	     `(defun ,name (class-name)
+		(let ((class (find-class class-name nil)))
+		  (if class
+		      (typep class ',metaclass)
+		      (let* ((info (class-info class-name))
+			     (meta (and info (class-info-metaclass info))))
+			(eq meta ',metaclass)))))))
+  (defpred info-funcallable-standard-class-p funcallable-standard-class)
+  (defpred info-standard-class-p standard-class))
 
 
 ;;; **************
diff --git a/pcl/low.lisp b/pcl/low.lisp
index 1f7a36bf2..62aa373fb 100644
--- a/pcl/low.lisp
+++ b/pcl/low.lisp
@@ -26,7 +26,7 @@
 ;;;
 
 (file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/low.lisp,v 1.24 2003/05/04 13:11:21 gerd Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/low.lisp,v 1.25 2003/05/07 17:14:24 gerd Exp $")
 
 ;;; 
 ;;; This file contains optimized low-level constructs for PCL.
@@ -167,14 +167,36 @@ the compiler as completely as possible.  Currently this means that
 
 ;;;; STD-INSTANCE
 
-;;; Under CMU17 conditional, STD-INSTANCE-P is only used to discriminate
-;;; between functions (including FINs) and normal instances, so we can return
-;;; true on structures also.  A few uses of (or std-instance-p fsc-instance-p)
+;;; STD-INSTANCE-P is only used to discriminate between functions
+;;; (including FINs) and normal instances, so we can return true on
+;;; structures also.  A few uses of (or std-instance-p fsc-instance-p)
 ;;; are changed to pcl-instance-p.
 ;;;
 (defmacro std-instance-p (x)
   `(kernel:%instancep ,x))
 
+(defmacro std-instance-slots (x)
+  `(kernel:%instance-ref ,x 1))
+
+(defmacro std-instance-hash (x)
+  `(kernel:%instance-ref ,x 2))
+
+(defmacro std-instance-wrapper (x)
+  `(kernel:%instance-layout ,x))
+
+(defmacro fsc-instance-p (fin)
+  `(funcallable-instance-p ,fin))
+
+(defmacro fsc-instance-wrapper (fin)
+  `(kernel:%funcallable-instance-layout ,fin))
+
+(defmacro fsc-instance-slots (fin)
+  `(kernel:%funcallable-instance-info ,fin 0))
+
+(defmacro fsc-instance-hash (fin)
+  `(kernel:%funcallable-instance-info ,fin 2))
+
+
 ;;; PCL-INSTANCE-P is implemented via a compiler transform so that the
 ;;; test can be optimised away when the result is known, such as is
 ;;; typically the case during slot access within methods, see
@@ -186,20 +208,56 @@ the compiler as completely as possible.  Currently this means that
   (movable foldable flushable explicit-check))
 
 (deftransform pcl::pcl-instance-p ((object))
-  (let* ((object-type (continuation-type object))
+  (let* ((ctype (continuation-type object))
 	 (standard-object (specifier-type 'standard-object)))
-    (cond ((csubtypep object-type standard-object)
+    (cond ((csubtypep ctype standard-object)
 	   t)
-	  ((not (types-intersect object-type standard-object))
+	  ((not (types-intersect ctype standard-object))
 	   nil)
-	  ((and (kernel::standard-class-p object-type)
-		(pcl::info-std-class-p (kernel:%class-name object-type)))
+	  ((and (kernel::standard-class-p ctype)
+		(let ((class-name (kernel:%class-name ctype)))
+		  (or (pcl::info-standard-class-p class-name)
+		      (pcl::info-funcallable-standard-class-p class-name))))
 	   t)
 	  (t
 	   `(typep (kernel:layout-of object) 'pcl::wrapper)))))
 
+(defknown pcl::slot-vector-or-nil (t)
+  (or null simple-vector)
+  (movable foldable flushable))
+
+(deftransform pcl::slot-vector-or-nil ((object))
+  (let ((ctype (continuation-type object))
+	(funcallable-standard-object
+	 (specifier-type 'mop:funcallable-standard-object))
+	(standard-object (specifier-type 'standard-object)))
+    (cond ((or (csubtypep ctype funcallable-standard-object)
+	       (and (kernel::standard-class-p ctype)
+		    (pcl::info-funcallable-standard-class-p
+		     (kernel:%class-name ctype))))
+	   (print "funcallable")
+	   '(kernel:%funcallable-instance-info object 0))
+	  ((or (csubtypep ctype standard-object)
+	       (and (kernel::standard-class-p ctype)
+		    (pcl::info-standard-class-p (kernel:%class-name ctype))))
+	   (print "instance")
+	   '(kernel:%instance-ref object 1))
+	  (t
+	   (print "give-up")
+	   `(when (pcl::pcl-instance-p object)
+	      (if (pcl::std-instance-p object)
+		  (pcl::std-instance-slots object)
+		  (pcl::fsc-instance-slots object)))))))
+
 (in-package "PCL")
 
+;;; Definition for interpreted code.
+(defun slot-vector-or-nil (obj)
+  (when (pcl-instance-p obj)
+    (if (std-instance-p obj)
+	(std-instance-slots obj)
+	(fsc-instance-slots obj))))
+
 ;;; Definition for interpreted code.
 (defun pcl-instance-p (x)
   (typep (kernel:layout-of x) 'wrapper))
@@ -225,13 +283,6 @@ the compiler as completely as possible.  Currently this means that
   (hash-code (get-instance-hash-code) :type fixnum))
 
 
-;;; Both of these operations "work" on structures, which allows the above
-;;; weakening of std-instance-p.
-;;;
-(defmacro std-instance-slots (x) `(kernel:%instance-ref ,x 1))
-(defmacro std-instance-hash (x) `(kernel:%instance-ref ,x 2))
-(defmacro std-instance-wrapper (x) `(kernel:%instance-layout ,x))
-
 (defmacro built-in-or-structure-wrapper (x) `(kernel:layout-of ,x))
 
 (defmacro get-wrapper (inst)
@@ -397,6 +448,7 @@ the compiler as completely as possible.  Currently this means that
 
 (in-package "PCL")
 
+#+bootable-pcl
 (defun early-pcl-init ()
   ;; defsys
   (setq *the-pcl-package* (find-package "PCL"))
@@ -410,6 +462,7 @@ the compiler as completely as possible.  Currently this means that
   ;; invoke the compiler.
   (setq *cold-boot-state* t))
 
+#+bootable-pcl
 (defun final-pcl-init ()
   (setq *cold-boot-state* nil)
   (setq *compile-lambda-silent-p* t)
diff --git a/pcl/vector.lisp b/pcl/vector.lisp
index b0d3daa9b..fd2ea8540 100644
--- a/pcl/vector.lisp
+++ b/pcl/vector.lisp
@@ -26,7 +26,7 @@
 ;;;
 
 (file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/vector.lisp,v 1.28 2003/05/04 13:11:20 gerd Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/vector.lisp,v 1.29 2003/05/07 17:14:24 gerd Rel $")
 
 (in-package :pcl)
 
@@ -716,7 +716,7 @@
   (multiple-value-bind (bindings vars)
     (loop for v in slot-vars and p in pv-parameters
 	  when v
-	    collect `(,v (get-slots-or-nil ,p)) into bindings
+	    collect `(,v (slot-vector-or-nil ,p)) into bindings
 	    and collect v into vars
 	  finally
 	    (return (values bindings vars)))
-- 
GitLab