(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)))
(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)))
(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)))
;; 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*)
+ ;; TODO
+ (eq s *the-class-sequence*)))
\f
;;; Some necessary methods for FORWARD-REFERENCED-CLASS
(defmethod class-direct-slots ((class forward-referenced-class)) ())