(constantly (make-member-type :members (list (specializer-object specl))))))
(defun real-load-defclass (name metaclass-name supers slots other
- readers writers slot-names source-location)
+ readers writers slot-names source-location safe-p)
(with-single-package-locked-error (:symbol name "defining ~S as a class")
(%compiler-defclass name readers writers slot-names)
(let ((res (apply #'ensure-class name :metaclass metaclass-name
:direct-superclasses supers
:direct-slots slots
:definition-source source-location
+ 'safe-p safe-p
other)))
res)))
(values defstruct-form constructor reader-names writer-names)))
(defun make-defstruct-allocation-function (class)
- (let ((dd (get-structure-dd (class-name class))))
+ ;; FIXME: Why don't we go class->layout->info == dd
+ (let ((dd (find-defstruct-description (class-name class))))
(lambda ()
(sb-kernel::%make-instance-with-layout
(sb-kernel::compiler-layout-or-lose (dd-name dd))))))
(fix-slot-accessors class dslotds 'remove))
(defun fix-slot-accessors (class dslotds add/remove)
- (flet ((fix (gfspec name r/w)
+ (flet ((fix (gfspec name r/w doc)
(let ((gf (cond ((eq add/remove 'add)
(or (find-generic-function gfspec nil)
(ensure-generic-function
(when gf
(case r/w
(r (if (eq add/remove 'add)
- (add-reader-method class gf name)
+ (add-reader-method class gf name doc)
(remove-reader-method class gf)))
(w (if (eq add/remove 'add)
- (add-writer-method class gf name)
+ (add-writer-method class gf name doc)
(remove-writer-method class gf))))))))
(dolist (dslotd dslotds)
- (let ((slot-name (slot-definition-name dslotd)))
+ (let ((slot-name (slot-definition-name dslotd))
+ (slot-doc (%slot-definition-documentation dslotd)))
(dolist (r (slot-definition-readers dslotd))
- (fix r slot-name 'r))
+ (fix r slot-name 'r slot-doc))
(dolist (w (slot-definition-writers dslotd))
- (fix w slot-name 'w))))))
+ (fix w slot-name 'w slot-doc))))))
\f
(defun add-direct-subclasses (class supers)
(dolist (super supers)
(setf slots eslotds
(wrapper-instance-slots-layout nwrapper) nlayout
(wrapper-class-slots nwrapper) nwrapper-class-slots
- (wrapper-no-of-instance-slots nwrapper) nslots
+ (layout-length nwrapper) nslots
wrapper nwrapper)
(do* ((slots (slot-value class 'slots) (cdr slots))
(dupes nil))
(allocation nil)
(allocation-class nil)
(type t)
+ (type-check-function nil)
(documentation nil)
(documentationp nil)
(namep nil)
allocation-class (slot-definition-class slotd)
allocp t))
(setq initargs (append (slot-definition-initargs slotd) initargs))
+ (let ((fun (slot-definition-type-check-function slotd)))
+ (when fun
+ (setf type-check-function
+ (if type-check-function
+ (let ((old-function type-check-function))
+ (lambda (value)
+ (funcall old-function value)
+ (funcall fun value)))
+ fun))))
(let ((slotd-type (slot-definition-type slotd)))
(setq type (cond
((eq type t) slotd-type)
:allocation allocation
:allocation-class allocation-class
:type type
+ 'type-check-function type-check-function
:class class
:documentation documentation)))
(declare (ignore direct-slot initargs))
(find-class 'standard-reader-method))
-(defmethod add-reader-method ((class slot-class) generic-function slot-name)
+(defmethod add-reader-method ((class slot-class) generic-function slot-name slot-documentation)
(add-method generic-function
(make-a-method 'standard-reader-method
()
(list (or (class-name class) 'object))
(list class)
(make-reader-method-function class slot-name)
- "automatically generated reader method"
+ (or slot-documentation "automatically generated reader method")
:slot-name slot-name
:object-class class
:method-class-function #'reader-method-class)))
(declare (ignore direct-slot initargs))
(find-class 'standard-writer-method))
-(defmethod add-writer-method ((class slot-class) generic-function slot-name)
+(defmethod add-writer-method ((class slot-class) generic-function slot-name slot-documentation)
(add-method generic-function
(make-a-method 'standard-writer-method
()
(list 'new-value (or (class-name class) 'object))
(list *the-class-t* class)
(make-writer-method-function class slot-name)
- "automatically generated writer method"
+ (or slot-documentation "automatically generated writer method")
:slot-name slot-name
:object-class class
:method-class-function #'writer-method-class)))
-(defmethod add-boundp-method ((class slot-class) generic-function slot-name)
+(defmethod add-boundp-method ((class slot-class) generic-function slot-name slot-documentation)
(add-method generic-function
(make-a-method (constantly (find-class 'standard-boundp-method))
class
(list (or (class-name class) 'object))
(list class)
(make-boundp-method-function class slot-name)
- "automatically generated boundp method"
+ (or slot-documentation "automatically generated boundp method")
slot-name)))
(defmethod remove-reader-method ((class slot-class) generic-function)
(let ((method (get-method generic-function () (list class) nil)))
(when method (remove-method generic-function method))))
\f
-;;; MAKE-READER-METHOD-FUNCTION and MAKE-WRITE-METHOD function are NOT
-;;; part of the standard protocol. They are however useful, PCL makes
-;;; use of them internally and documents them for PCL users.
+;;; MAKE-READER-METHOD-FUNCTION and MAKE-WRITER-METHOD-FUNCTION
+;;; function are NOT part of the standard protocol. They are however
+;;; useful; PCL makes use of them internally and documents them for
+;;; PCL users. (FIXME: but SBCL certainly doesn't)
;;;
;;; *** This needs work to make type testing by the writer functions which
;;; *** do type testing faster. The idea would be to have one constructor
;;; *** defined for this metaclass a chance to run.
(defmethod make-reader-method-function ((class slot-class) slot-name)
- (make-std-reader-method-function (class-name class) slot-name))
+ (make-std-reader-method-function class slot-name))
(defmethod make-writer-method-function ((class slot-class) slot-name)
- (make-std-writer-method-function (class-name class) slot-name))
+ (make-std-writer-method-function class slot-name))
(defmethod make-boundp-method-function ((class slot-class) slot-name)
- (make-std-boundp-method-function (class-name class) slot-name))
+ (make-std-boundp-method-function class slot-name))
\f
(defmethod compatible-meta-class-change-p (class proto-new-class)
(eq (class-of class) (class-of proto-new-class)))
;; good style. There has to be a better way! -- CSR,
;; 2002-10-29
(eq (layout-invalid owrapper) t))
- (let ((nwrapper (make-wrapper (wrapper-no-of-instance-slots owrapper)
+ (let ((nwrapper (make-wrapper (layout-length owrapper)
class)))
(setf (wrapper-instance-slots-layout nwrapper)
(wrapper-instance-slots-layout owrapper))
;;; through the UPDATE-INSTANCE-FOR-REDEFINED-CLASS mechanism.
(defmethod make-instances-obsolete ((class std-class))
(let* ((owrapper (class-wrapper class))
- (nwrapper (make-wrapper (wrapper-no-of-instance-slots owrapper)
+ (nwrapper (make-wrapper (layout-length owrapper)
class)))
(unless (class-finalized-p class)
(if (class-has-a-forward-referenced-superclass-p class)
;; 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*)))
+ (eq s *the-class-file-stream*) (eq s *the-class-string-stream*)
+ ;; This probably shouldn't be mixed in with certain other
+ ;; classes, too, but it seems to work both with STANDARD-OBJECT
+ ;; and FUNCALLABLE-STANDARD-OBJECT
+ (eq s *the-class-sequence*)))
\f
;;; Some necessary methods for FORWARD-REFERENCED-CLASS
(defmethod class-direct-slots ((class forward-referenced-class)) ())
projects / sbcl.git / blobdiff