X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fstd-class.lisp;h=41b439009d258a0f492023543ea53ea8642dbdfa;hb=3fe0010d2777b41e01ea9b4a0f894cfa40f7df1b;hp=3a6b3b98fa752e7c4c01ec06dd00d8500c17e103;hpb=760349abe9068fe4e5e3c03013f3533b64602a93;p=sbcl.git

diff --git a/src/pcl/std-class.lisp b/src/pcl/std-class.lisp
index 3a6b3b9..41b4390 100644
--- a/src/pcl/std-class.lisp
+++ b/src/pcl/std-class.lisp
@@ -349,15 +349,17 @@
 (defun ensure-class-values (class initargs)
   (let (metaclass metaclassp reversed-plist)
     (doplist (key val) initargs
-        (cond ((eq key :metaclass)
-               (setf metaclass val
-                     metaclassp key))
-              (t
-               (when (eq key :direct-superclasses)
-                 (setf val (mapcar #'fix-super val)))
-               (setf reversed-plist (list* val key reversed-plist)))))
+      (cond ((eq key :metaclass)
+	     (setf metaclass val
+		   metaclassp key))
+	    (t
+	     (when (eq key :direct-superclasses)
+	       (setf val (mapcar #'fix-super val)))
+	     (setf reversed-plist (list* val key reversed-plist)))))
     (values (cond (metaclassp
-                   (find-class metaclass))
+		   (if (classp metaclass)
+		       metaclass
+		       (find-class metaclass)))
                   ((or (null class) (forward-referenced-class-p class))
                    *the-class-standard-class*)
                   (t
@@ -648,15 +650,8 @@
 (defun make-defstruct-allocation-function (class)
   (let ((dd (get-structure-dd (class-name class))))
     (lambda ()
-      (let ((instance (%make-instance (dd-length dd)))
-	    (raw-index (dd-raw-index dd)))
-	(setf (%instance-layout instance)
-	      (sb-kernel::compiler-layout-or-lose (dd-name dd)))
-	(when raw-index
-	  (setf (%instance-ref instance raw-index)
-		(make-array (dd-raw-length dd)
-			    :element-type '(unsigned-byte 32))))
-	instance))))
+      (sb-kernel::%make-instance-with-layout
+       (sb-kernel::compiler-layout-or-lose (dd-name dd))))))
 
 (defmethod shared-initialize :after
     ((class structure-class)
@@ -744,20 +739,26 @@
 
 (defun fix-slot-accessors (class dslotds add/remove)
   (flet ((fix (gfspec name r/w)
-           (let ((gf (if (fboundp gfspec)
-                         (without-package-locks 
-                           (ensure-generic-function gfspec))
-                         (ensure-generic-function 
-                          gfspec :lambda-list (case r/w 
-                                                (r '(object)) 
-                                                (w '(new-value object)))))))
-             (case r/w
-               (r (if (eq add/remove 'add)
-                      (add-reader-method class gf name)
-                      (remove-reader-method class gf)))
-               (w (if (eq add/remove 'add)
-                      (add-writer-method class gf name)
-                      (remove-writer-method class gf)))))))
+           (let ((gf (cond ((eq add/remove 'add)
+                            (if (fboundp gfspec)
+                                (without-package-locks 
+                                  (ensure-generic-function gfspec))
+                                (ensure-generic-function 
+                                 gfspec :lambda-list (case r/w
+                                                       (r '(object))
+                                                       (w '(new-value object))))))
+                           ((generic-function-p (and (fboundp gfspec)
+                                                     (fdefinition gfspec)))
+                            (without-package-locks
+                              (ensure-generic-function gfspec))))))
+             (when gf
+               (case r/w
+                 (r (if (eq add/remove 'add)
+                        (add-reader-method class gf name)
+                        (remove-reader-method class gf)))
+                 (w (if (eq add/remove 'add)
+                        (add-writer-method class gf name)
+                        (remove-writer-method class gf))))))))
     (dolist (dslotd dslotds)
       (let ((slot-name (slot-definition-name dslotd)))
         (dolist (r (slot-definition-readers dslotd)) 
@@ -943,13 +944,21 @@
          :class class
          initargs))
 
+;;; I (CSR) am not sure, but I believe that the particular order of
+;;; slots is quite important: it is ideal to attempt to have a
+;;; constant slot location for the same notional slots as much as
+;;; possible, so that clever discriminating functions (ONE-INDEX et
+;;; al.) have a chance of working.  The below at least walks through
+;;; the slots predictably, but maybe it would be good to compute some
+;;; kind of optimal slot layout by looking at locations of slots in
+;;; superclasses?
 (defmethod compute-slots ((class std-class))
   ;; As specified, we must call COMPUTE-EFFECTIVE-SLOT-DEFINITION once
   ;; for each different slot name we find in our superclasses. Each
   ;; call receives the class and a list of the dslotds with that name.
   ;; The list is in most-specific-first order.
   (let ((name-dslotds-alist ()))
-    (dolist (c (class-precedence-list class))
+    (dolist (c (reverse (class-precedence-list class)))
       (dolist (slot (class-direct-slots c))
 	(let* ((name (slot-definition-name slot))
 	       (entry (assq name name-dslotds-alist)))
@@ -959,8 +968,8 @@
     (mapcar (lambda (direct)
 	      (compute-effective-slot-definition class
 						 (car direct)
-						 (nreverse (cdr direct))))
-	    name-dslotds-alist)))
+						 (cdr direct)))
+	    (nreverse name-dslotds-alist))))
 
 (defmethod compute-slots ((class standard-class))
   (call-next-method))
@@ -1489,8 +1498,12 @@
 (defmethod class-default-initargs	((class built-in-class)) ())
 
 (defmethod validate-superclass ((c class) (s built-in-class))
-  (or (eq s *the-class-t*)
-      (eq s *the-class-stream*)))
+  (or (eq s *the-class-t*) (eq s *the-class-stream*)
+      ;; FIXME: bad things happen if someone tries to mix in both
+      ;; FILE-STREAM and STRING-STREAM (as they have the same
+      ;; layout-depthoid).  Is there any way we can provide a useful
+      ;; error message?  -- CSR, 2005-05-03
+      (eq s *the-class-file-stream*) (eq s *the-class-string-stream*)))
 
 ;;; Some necessary methods for FORWARD-REFERENCED-CLASS
 (defmethod class-direct-slots ((class forward-referenced-class)) ())