(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
(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)
(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))
: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)))
(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))
(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*)))
\f
;;; Some necessary methods for FORWARD-REFERENCED-CLASS
(defmethod class-direct-slots ((class forward-referenced-class)) ())
projects / sbcl.git / blobdiff