X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fdefclass.lisp;h=09bf800ef4b0dc2ec38cb42aa595cb93709465f6;hb=f705c517d8606a9a72edd11a96725f9c4e4be93d;hp=4226df53b8e52ca55b2917748c83a779a6c36269;hpb=2ef330d818799fe54587bdcb4c626b397ca15266;p=sbcl.git

diff --git a/src/pcl/defclass.lisp b/src/pcl/defclass.lisp
index 4226df5..09bf800 100644
--- a/src/pcl/defclass.lisp
+++ b/src/pcl/defclass.lisp
@@ -98,29 +98,20 @@
                                         mclass
                                         *the-class-structure-class*))))))
           (let ((defclass-form
-		  `(progn
-		     ,@(mapcar (lambda (x)
-				 `(declaim (ftype (function (t) t) ,x)))
-			       *readers-for-this-defclass*)
-		     ,@(mapcar (lambda (x)
-				 `(declaim (ftype (function (t t) t) ,x)))
-			       *writers-for-this-defclass*)
-                     ,@(mapcar (lambda (x)
-                                 `(declaim (ftype (function (t) t)
-                                                  ,(slot-reader-name x)
-                                                  ,(slot-boundp-name x))
-                                           (ftype (function (t t) t)
-                                                  ,(slot-writer-name x))))
-                               *slot-names-for-this-defclass*)
-		     (let ,(mapcar #'cdr *initfunctions-for-this-defclass*)
-		       (load-defclass ',name
-				      ',metaclass
-				      ',supers
-				      (list ,@canonical-slots)
-				      (list ,@(apply #'append
-						     (when defstruct-p
-						       '(:from-defclass-p t))
-						     other-initargs)))))))
+		    `(progn
+		      (let ,(mapcar #'cdr *initfunctions-for-this-defclass*)
+			(%compiler-defclass ',name
+					    ',*readers-for-this-defclass*
+					    ',*writers-for-this-defclass*
+					    ',*slot-names-for-this-defclass*)
+			(load-defclass ',name
+				       ',metaclass
+				       ',supers
+				       (list ,@canonical-slots)
+				       (list ,@(apply #'append
+						      (when defstruct-p
+							'(:from-defclass-p t))
+						      other-initargs)))))))
             (if defstruct-p
 		(progn
 		  ;; FIXME: (YUK!) Why do we do this? Because in order
@@ -140,7 +131,8 @@
 				      (and (not (eq name 'structure-object))
 					   *the-class-structure-object*)))
 			 (defstruct-form (make-structure-class-defstruct-form
-					  name (class-direct-slots (find-class name)) include)))
+					  name (class-direct-slots (find-class name))
+					  include)))
 		    `(progn
 		      (eval-when (:compile-toplevel :load-toplevel :execute)
 			,defstruct-form) ; really compile the defstruct-form
@@ -158,8 +150,22 @@
 		   ;; full-blown class, so the "a class of this name is
 		   ;; coming" note we write here would be irrelevant.
 		   (eval-when (:compile-toplevel)
-		     (preinform-compiler-about-class-type ',name))
-		   ,defclass-form))))))))
+		     (%compiler-defclass ',name
+					 ',*readers-for-this-defclass*
+					 ',*writers-for-this-defclass*
+					 ',*slot-names-for-this-defclass*))
+		   (eval-when (:load-toplevel :execute)
+		     ,defclass-form)))))))))
+
+(defun %compiler-defclass (name readers writers slot-names)
+  (with-single-package-locked-error (:symbol name "defining ~A as a class")
+    (preinform-compiler-about-class-type name)
+    (proclaim `(ftype (function (t) t)
+		,@readers
+		,@(mapcar #'slot-reader-name slot-names)
+		,@(mapcar #'slot-boundp-name slot-names)))
+    (proclaim `(ftype (function (t t) t)
+		,@writers ,@(mapcar #'slot-writer-name slot-names)))))
 
 (defun make-initfunction (initform)
   (cond ((or (eq initform t)
@@ -209,7 +215,7 @@
 		  :format-control
 		  "~@<in DEFCLASS ~S, the slot specification ~S is invalid; ~
                    the probable intended meaning may be achieved by ~
-                   specifiying ~S instead."
+                   specifiying ~S instead.~>"
 		  :format-arguments
 		  (list class-name spec
 			`(,(car spec) :initform ,(cadr spec)))))