X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fdefclass.lisp;h=2c1dfeddca4803f70627cc70ca7e3e5990ffead8;hb=bd0ba0f214518e8d72ff2d44de5a1e3e4b02af2c;hp=99f2f7a3369a1c155c71cd2f7ce34c55a62ae993;hpb=63cef087068afc157283c0a05ae1f16b962303aa;p=sbcl.git

diff --git a/src/pcl/defclass.lisp b/src/pcl/defclass.lisp
index 99f2f7a..2c1dfed 100644
--- a/src/pcl/defclass.lisp
+++ b/src/pcl/defclass.lisp
@@ -48,6 +48,7 @@
 (defvar *initfunctions-for-this-defclass*)
 (defvar *readers-for-this-defclass*)
 (defvar *writers-for-this-defclass*)
+(defvar *slot-names-for-this-defclass*)
 
 ;;; Like the DEFMETHOD macro, the expansion of the DEFCLASS macro is
 ;;; fixed. DEFCLASS always expands into a call to LOAD-DEFCLASS. Until
@@ -71,17 +72,14 @@
 	      (error "The value of the :metaclass option (~S) is not a~%~
 		      legal class name."
 		     (cadr option)))
-	    (setq metaclass
-                    (case (cadr option)
-                      (cl:standard-class 'standard-class)
-                      (cl:structure-class 'structure-class)
-                      (t (cadr option))))
+	    (setq metaclass (cadr option))
 	    (setf options (remove option options))
 	    (return t))))
 
       (let ((*initfunctions-for-this-defclass* ())
             (*readers-for-this-defclass* ()) ;Truly a crock, but we got
-            (*writers-for-this-defclass* ())) ;to have it to live nicely.
+            (*writers-for-this-defclass* ()) ;to have it to live nicely.
+            (*slot-names-for-this-defclass* ()))
         (let ((canonical-slots
                 (mapcar (lambda (spec)
 			  (canonicalize-slot-specification name spec))
@@ -107,6 +105,13 @@
 		     ,@(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
@@ -117,17 +122,30 @@
 						       '(:from-defclass-p t))
 						     other-initargs)))))))
             (if defstruct-p
-		(let* ((include (or (and supers
-					 (fix-super (car supers)))
-				    (and (not (eq name 'structure-object))
-					 *the-class-structure-object*)))
-		       (defstruct-form (make-structure-class-defstruct-form
-					name slots include)))
-		  `(progn
-		     (eval-when (:compile-toplevel :load-toplevel :execute)
-		       ,defstruct-form) ; really compile the defstruct-form
-		     (eval-when (:compile-toplevel :load-toplevel :execute)
-		       ,defclass-form)))
+		(progn
+		  ;; FIXME: (YUK!) Why do we do this? Because in order
+		  ;; to make the defstruct form, we need to know what
+		  ;; the accessors for the slots are, so we need
+		  ;; already to have hooked into the CLOS machinery.
+		  ;;
+		  ;; There may be a better way to do this: it would
+		  ;; involve knowing enough about PCL to ask "what
+		  ;; will my slot names and accessors be"; failing
+		  ;; this, we currently just evaluate the whole
+		  ;; kaboodle, and then use CLASS-DIRECT-SLOTS. --
+		  ;; CSR, 2002-06-07
+		  (eval defclass-form)
+		  (let* ((include (or (and supers
+					   (fix-super (car supers)))
+				      (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)))
+		    `(progn
+		      (eval-when (:compile-toplevel :load-toplevel :execute)
+			,defstruct-form) ; really compile the defstruct-form
+		      (eval-when (:compile-toplevel :load-toplevel :execute)
+			,defclass-form))))
 		`(progn
 		   ;; By telling the type system at compile time about
 		   ;; the existence of a class named NAME, we can avoid
@@ -167,10 +185,12 @@
   (cond ((and (symbolp spec)
 	      (not (keywordp spec))
 	      (not (memq spec '(t nil))))
+         (push spec *slot-names-for-this-defclass*)
 	 `'(:name ,spec))
 	((not (consp spec))
 	 (error "~S is not a legal slot specification." spec))
 	((null (cdr spec))
+         (push (car spec) *slot-names-for-this-defclass*)
 	 `'(:name ,(car spec)))
 	((null (cddr spec))
 	 (error "In DEFCLASS ~S, the slot specification ~S is obsolete.~%~
@@ -183,6 +203,7 @@
 		(initargs ())
 		(unsupplied (list nil))
 		(initform (getf spec :initform unsupplied)))
+           (push name *slot-names-for-this-defclass*)
 	   (doplist (key val) spec
 	     (case key
 	       (:accessor (push val readers)
@@ -206,7 +227,7 @@
 	   (if (eq initform unsupplied)
 	       `(list* ,@spec)
 	       `(list* :initfunction ,(make-initfunction initform) ,@spec))))))
-						
+
 (defun canonicalize-defclass-option (class-name option)
   (declare (ignore class-name))
   (case (car option)
@@ -375,7 +396,7 @@
 	canonical-options (copy-tree canonical-options))
   (let ((ecd
 	  (make-early-class-definition name
-				       *load-truename*
+				       *load-pathname*
 				       metaclass
 				       supers
 				       canonical-slots