X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fslots-boot.lisp;h=59908e9f60b4a355977caefa3332a7b1c7b12ba7;hb=683874b497a99cd2c11b6c5d9b47e2785b1ede5f;hp=7fdd212e5f322982f1fcee66146ecedc2afca9f5;hpb=2716573f357f204c5f546d1d34d285dd24ff43a1;p=sbcl.git

diff --git a/src/pcl/slots-boot.lisp b/src/pcl/slots-boot.lisp
index 7fdd212..59908e9 100644
--- a/src/pcl/slots-boot.lisp
+++ b/src/pcl/slots-boot.lisp
@@ -84,20 +84,12 @@
 	`(let ,bindings ,form)
 	form)))
 
-;;; FIXME: Why is this defined in two different places? And what does
-;;; it mean anyway? And can we just eliminate it completely (replacing
-;;; it with NIL, then hand-eliminating any resulting dead code)?
-(defconstant +optimize-slot-boundp+ nil)
-
 (defmacro accessor-slot-boundp (object slot-name)
   (unless (constantp slot-name)
     (error "~S requires its slot-name argument to be a constant"
 	   'accessor-slot-boundp))
-  (let* ((slot-name (eval slot-name))
-	 (sym (slot-boundp-symbol slot-name)))
-    (if (not +optimize-slot-boundp+)
-	`(slot-boundp-normal ,object ',slot-name)
-	`(asv-funcall ,sym ,slot-name boundp ,object))))
+  (let ((slot-name (eval slot-name)))
+    `(slot-boundp-normal ,object ',slot-name)))
 
 (defun structure-slot-boundp (object)
   (declare (ignore object))
@@ -137,51 +129,55 @@
 
 (defun make-optimized-std-reader-method-function (fsc-p slot-name index)
   (declare #.*optimize-speed*)
-  (set-function-name
+  (set-fun-name
    (etypecase index
      (fixnum (if fsc-p
-		 #'(lambda (instance)
-		     (let ((value (%instance-ref (fsc-instance-slots instance) index)))
-		       (if (eq value +slot-unbound+)
-			   (slot-unbound (class-of instance) instance slot-name)
-			   value)))
-		 #'(lambda (instance)
-		     (let ((value (%instance-ref (std-instance-slots instance) index)))
-		       (if (eq value +slot-unbound+)
-			   (slot-unbound (class-of instance) instance slot-name)
-			   value)))))
-     (cons   #'(lambda (instance)
-		 (let ((value (cdr index)))
-		   (if (eq value +slot-unbound+)
-		       (slot-unbound (class-of instance) instance slot-name)
-		       value)))))
+		 (lambda (instance)
+		   (let ((value (clos-slots-ref (fsc-instance-slots instance)
+						index)))
+		     (if (eq value +slot-unbound+)
+			 (slot-unbound (class-of instance) instance slot-name)
+			 value)))
+		 (lambda (instance)
+		   (let ((value (clos-slots-ref (std-instance-slots instance)
+					      index)))
+		     (if (eq value +slot-unbound+)
+			 (slot-unbound (class-of instance) instance slot-name)
+			 value)))))
+     (cons   (lambda (instance)
+	       (let ((value (cdr index)))
+		 (if (eq value +slot-unbound+)
+		     (slot-unbound (class-of instance) instance slot-name)
+		     value)))))
    `(reader ,slot-name)))
 
 (defun make-optimized-std-writer-method-function (fsc-p slot-name index)
   (declare #.*optimize-speed*)
-  (set-function-name
+  (set-fun-name
    (etypecase index
      (fixnum (if fsc-p
-		 #'(lambda (nv instance)
-		     (setf (%instance-ref (fsc-instance-slots instance) index) nv))
-		 #'(lambda (nv instance)
-		     (setf (%instance-ref (std-instance-slots instance) index) nv))))
-     (cons   #'(lambda (nv instance)
-		 (declare (ignore instance))
-		 (setf (cdr index) nv))))
+		 (lambda (nv instance)
+		   (setf (clos-slots-ref (fsc-instance-slots instance) index)
+			 nv))
+		 (lambda (nv instance)
+		   (setf (clos-slots-ref (std-instance-slots instance) index)
+			 nv))))
+     (cons   (lambda (nv instance)
+	       (declare (ignore instance))
+	       (setf (cdr index) nv))))
    `(writer ,slot-name)))
 
 (defun make-optimized-std-boundp-method-function (fsc-p slot-name index)
   (declare #.*optimize-speed*)
-  (set-function-name
+  (set-fun-name
    (etypecase index
      (fixnum (if fsc-p
 		 #'(lambda (instance)
-		     (not (eq (%instance-ref (fsc-instance-slots instance)
+		     (not (eq (clos-slots-ref (fsc-instance-slots instance)
 					     index)
 			      +slot-unbound+)))
 		 #'(lambda (instance)
-		     (not (eq (%instance-ref (std-instance-slots instance)
+		     (not (eq (clos-slots-ref (std-instance-slots instance)
 					     index)
 			      +slot-unbound+)))))
      (cons   #'(lambda (instance)
@@ -191,11 +187,11 @@
 
 (defun make-optimized-structure-slot-value-using-class-method-function (function)
   (declare (type function function))
-  #'(lambda (class object slotd)
-      (let ((value (funcall function object)))
-	(if (eq value +slot-unbound+)
-	    (slot-unbound class object (slot-definition-name slotd))
-	    value))))
+  (lambda (class object slotd)
+    (let ((value (funcall function object)))
+      (if (eq value +slot-unbound+)
+	  (slot-unbound class object (slot-definition-name slotd))
+	  value))))
 
 (defun make-optimized-structure-setf-slot-value-using-class-method-function (function)
   (declare (type function function))
@@ -209,7 +205,9 @@
       (declare (ignore class slotd))
       (not (eq (funcall function object) +slot-unbound+))))
 
-(defun get-optimized-std-slot-value-using-class-method-function (class slotd name)
+(defun get-optimized-std-slot-value-using-class-method-function (class
+								 slotd
+								 name)
   (if (structure-class-p class)
       (ecase name
 	(reader (make-optimized-structure-slot-value-using-class-method-function
@@ -239,26 +237,28 @@
   (declare #.*optimize-speed*)
   (etypecase index
     (fixnum (if fsc-p
-		#'(lambda (class instance slotd)
-		    (declare (ignore slotd))
-		    (unless (fsc-instance-p instance) (error "not fsc"))
-		    (let ((value (%instance-ref (fsc-instance-slots instance) index)))
-		      (if (eq value +slot-unbound+)
-			  (slot-unbound class instance slot-name)
-			  value)))
-		#'(lambda (class instance slotd)
-		    (declare (ignore slotd))
-		    (unless (std-instance-p instance) (error "not std"))
-		    (let ((value (%instance-ref (std-instance-slots instance) index)))
-		      (if (eq value +slot-unbound+)
-			  (slot-unbound class instance slot-name)
-			  value)))))
-    (cons   #'(lambda (class instance slotd)
-		(declare (ignore slotd))
-		(let ((value (cdr index)))
-		  (if (eq value +slot-unbound+)
-		      (slot-unbound class instance slot-name)
-		      value))))))
+		(lambda (class instance slotd)
+		  (declare (ignore slotd))
+		  (unless (fsc-instance-p instance) (error "not fsc"))
+		  (let ((value (clos-slots-ref (fsc-instance-slots instance)
+					       index)))
+		    (if (eq value +slot-unbound+)
+			(slot-unbound class instance slot-name)
+			value)))
+		(lambda (class instance slotd)
+		  (declare (ignore slotd))
+		  (unless (std-instance-p instance) (error "not std"))
+		  (let ((value (clos-slots-ref (std-instance-slots instance)
+					       index)))
+		    (if (eq value +slot-unbound+)
+			(slot-unbound class instance slot-name)
+			value)))))
+    (cons   (lambda (class instance slotd)
+	      (declare (ignore slotd))
+	      (let ((value (cdr index)))
+		(if (eq value +slot-unbound+)
+		    (slot-unbound class instance slot-name)
+		    value))))))
 
 (defun make-optimized-std-setf-slot-value-using-class-method-function
     (fsc-p slot-name index)
@@ -266,15 +266,17 @@
   (declare (ignore slot-name))
   (etypecase index
     (fixnum (if fsc-p
-		#'(lambda (nv class instance slotd)
-		    (declare (ignore class slotd))
-		    (setf (%instance-ref (fsc-instance-slots instance) index) nv))
-		#'(lambda (nv class instance slotd)
-		    (declare (ignore class slotd))
-		    (setf (%instance-ref (std-instance-slots instance) index) nv))))
-    (cons   #'(lambda (nv class instance slotd)
-		(declare (ignore class instance slotd))
-		(setf (cdr index) nv)))))
+		(lambda (nv class instance slotd)
+		  (declare (ignore class slotd))
+		  (setf (clos-slots-ref (fsc-instance-slots instance) index)
+			nv))
+		(lambda (nv class instance slotd)
+		  (declare (ignore class slotd))
+		  (setf (clos-slots-ref (std-instance-slots instance) index)
+			nv))))
+    (cons  (lambda (nv class instance slotd)
+	     (declare (ignore class instance slotd))
+	     (setf (cdr index) nv)))))
 
 (defun make-optimized-std-slot-boundp-using-class-method-function
     (fsc-p slot-name index)
@@ -282,28 +284,29 @@
   (declare (ignore slot-name))
   (etypecase index
     (fixnum (if fsc-p
-		#'(lambda (class instance slotd)
-		    (declare (ignore class slotd))
-		    (not (eq (%instance-ref (fsc-instance-slots instance)
-					    index)
-			     +slot-unbound+ )))
-		#'(lambda (class instance slotd)
-		    (declare (ignore class slotd))
-		    (not (eq (%instance-ref (std-instance-slots instance)
-					    index)
-			     +slot-unbound+ )))))
-    (cons   #'(lambda (class instance slotd)
-		(declare (ignore class instance slotd))
-		(not (eq (cdr index) +slot-unbound+))))))
+		(lambda (class instance slotd)
+		  (declare (ignore class slotd))
+		  (not (eq (clos-slots-ref (fsc-instance-slots instance) index)
+			   +slot-unbound+)))
+		(lambda (class instance slotd)
+		  (declare (ignore class slotd))
+		  (not (eq (clos-slots-ref (std-instance-slots instance) index)
+			   +slot-unbound+)))))
+    (cons   (lambda (class instance slotd)
+	      (declare (ignore class instance slotd))
+	      (not (eq (cdr index) +slot-unbound+))))))
 
 (defun get-accessor-from-svuc-method-function (class slotd sdfun name)
   (macrolet ((emf-funcall (emf &rest args)
 	       `(invoke-effective-method-function ,emf nil ,@args)))
-    (set-function-name
+    (set-fun-name
      (case name
-       (reader #'(lambda (instance) (emf-funcall sdfun class instance slotd)))
-       (writer #'(lambda (nv instance) (emf-funcall sdfun nv class instance slotd)))
-       (boundp #'(lambda (instance) (emf-funcall sdfun class instance slotd))))
+       (reader (lambda (instance)
+		 (emf-funcall sdfun class instance slotd)))
+       (writer (lambda (nv instance)
+		 (emf-funcall sdfun nv class instance slotd)))
+       (boundp (lambda (instance)
+		 (emf-funcall sdfun class instance slotd))))
      `(,name ,(class-name class) ,(slot-definition-name slotd)))))
 
 (defun make-internal-reader-method-function (class-name slot-name)
@@ -314,20 +317,27 @@
 	      (if wrapper
 		  (let* ((class (wrapper-class* wrapper))
 			 (index (or (instance-slot-index wrapper slot-name)
-				    (assq slot-name (wrapper-class-slots wrapper)))))
+				    (assq slot-name
+					  (wrapper-class-slots wrapper)))))
 		    (typecase index
 		      (fixnum 	
-		       (let ((value (%instance-ref (get-slots instance) index)))
+		       (let ((value (clos-slots-ref (get-slots instance)
+						    index)))
 			 (if (eq value +slot-unbound+)
-			     (slot-unbound (class-of instance) instance slot-name)
+			     (slot-unbound (class-of instance)
+					   instance
+					   slot-name)
 			     value)))
 		      (cons
 		       (let ((value (cdr index)))
 			 (if (eq value +slot-unbound+)
-			     (slot-unbound (class-of instance) instance slot-name)
+			     (slot-unbound (class-of instance)
+					   instance
+					   slot-name)
 			     value)))
 		      (t
-		       (error "The wrapper for class ~S does not have the slot ~S"
+		       (error "~@<The wrapper for class ~S does not have ~
+                               the slot ~S~@:>"
 			      class slot-name))))
 		  (slot-value instance slot-name)))))))
 
@@ -393,12 +403,6 @@
 	   (gf (ensure-generic-function name)))
       (unless (generic-function-methods gf)
 	(add-writer-method *the-class-slot-object* gf slot-name))))
-  (when (and +optimize-slot-boundp+
-	     (or (null type) (eq type 'boundp)))
-    (let* ((name (slot-boundp-symbol slot-name))
-	   (gf (ensure-generic-function name)))
-      (unless (generic-function-methods gf)
-	(add-boundp-method *the-class-slot-object* gf slot-name))))
   nil)
 
 (defun initialize-internal-slot-gfs* (readers writers boundps)