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

diff --git a/src/pcl/slots-boot.lisp b/src/pcl/slots-boot.lisp
index 7fdd212..9fc23ba 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))
@@ -105,8 +97,8 @@
 
 (defun make-structure-slot-boundp-function (slotd)
   (let* ((reader (slot-definition-internal-reader-function slotd))
-	 (fun #'(lambda (object)
-		  (not (eq (funcall reader object) +slot-unbound+)))))
+	 (fun (lambda (object)
+		(not (eq (funcall reader object) +slot-unbound+)))))
     (declare (type function reader))
     fun))
 
@@ -137,79 +129,85 @@
 
 (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)
-					     index)
-			      +slot-unbound+)))
-		 #'(lambda (instance)
-		     (not (eq (%instance-ref (std-instance-slots instance)
-					     index)
-			      +slot-unbound+)))))
-     (cons   #'(lambda (instance)
-		 (declare (ignore instance))
-		 (not (eq (cdr index) +slot-unbound+)))))
+		 (lambda (instance)
+		   (not (eq (clos-slots-ref (fsc-instance-slots instance)
+					    index)
+			    +slot-unbound+)))
+		 (lambda (instance)
+		   (not (eq (clos-slots-ref (std-instance-slots instance)
+					    index)
+			    +slot-unbound+)))))
+     (cons (lambda (instance)
+	     (declare (ignore instance))
+	     (not (eq (cdr index) +slot-unbound+)))))
    `(boundp ,slot-name)))
 
 (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))
-  #'(lambda (nv class object slotd)
-      (declare (ignore class slotd))
-      (funcall function nv object)))
+  (lambda (nv class object slotd)
+    (declare (ignore class slotd))
+    (funcall function nv object)))
 
 (defun make-optimized-structure-slot-boundp-using-class-method-function (function)
   (declare (type function function))
-  #'(lambda (class object slotd)
-      (declare (ignore class slotd))
-      (not (eq (funcall function object) +slot-unbound+))))
+  (lambda (class object slotd)
+    (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,52 +284,60 @@
   (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)
-  (list* ':method-spec `(internal-reader-method ,class-name ,slot-name)
+  (list* :method-spec `(internal-reader-method ,class-name ,slot-name)
 	 (make-method-function
 	  (lambda (instance)
 	    (let ((wrapper (get-instance-wrapper-or-nil instance)))
 	      (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)))))))
 
@@ -342,10 +352,10 @@
 			 (instance-read-internal
 			  .pv. instance-slots 1
 			  (slot-value instance slot-name))))))))
-    (setf (getf (getf initargs ':plist) ':slot-name-lists)
+    (setf (getf (getf initargs :plist) :slot-name-lists)
 	  (list (list nil slot-name)))
-    (setf (getf (getf initargs ':plist) ':pv-table-symbol) pv-table-symbol)
-    (list* ':method-spec `(reader-method ,class-name ,slot-name)
+    (setf (getf (getf initargs :plist) :pv-table-symbol) pv-table-symbol)
+    (list* :method-spec `(reader-method ,class-name ,slot-name)
 	   initargs)))
 
 (defun make-std-writer-method-function (class-name slot-name)
@@ -359,10 +369,10 @@
 			 (instance-write-internal
 			  .pv. instance-slots 1 nv
 			  (setf (slot-value instance slot-name) nv))))))))
-    (setf (getf (getf initargs ':plist) ':slot-name-lists)
+    (setf (getf (getf initargs :plist) :slot-name-lists)
 	  (list nil (list nil slot-name)))
-    (setf (getf (getf initargs ':plist) ':pv-table-symbol) pv-table-symbol)
-    (list* ':method-spec `(writer-method ,class-name ,slot-name)
+    (setf (getf (getf initargs :plist) :pv-table-symbol) pv-table-symbol)
+    (list* :method-spec `(writer-method ,class-name ,slot-name)
 	   initargs)))
 
 (defun make-std-boundp-method-function (class-name slot-name)
@@ -376,10 +386,10 @@
 			  (instance-boundp-internal
 			   .pv. instance-slots 1
 			   (slot-boundp instance slot-name))))))))
-    (setf (getf (getf initargs ':plist) ':slot-name-lists)
+    (setf (getf (getf initargs :plist) :slot-name-lists)
 	  (list (list nil slot-name)))
-    (setf (getf (getf initargs ':plist) ':pv-table-symbol) pv-table-symbol)
-    (list* ':method-spec `(boundp-method ,class-name ,slot-name)
+    (setf (getf (getf initargs :plist) :pv-table-symbol) pv-table-symbol)
+    (list* :method-spec `(boundp-method ,class-name ,slot-name)
 	   initargs)))
 
 (defun initialize-internal-slot-gfs (slot-name &optional type)
@@ -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)