;; SB-KERNEL:INSTANCE. In an effort to sweep such
;; problems under the rug, we exclude these problem
;; cases by blacklisting them here. -- WHN 2001-01-19
- '(slot-object))
+ (list 'slot-object #+nil (find-class 'slot-object)))
'(ignorable))
((not (eq *boot-state* 'complete))
;; KLUDGE: PCL, in its wisdom, sometimes calls methods with
;; second argument.) Hopefully it only does this kind of
;; weirdness when bootstrapping.. -- WHN 20000610
'(ignorable))
+ ((typep specializer 'eql-specializer)
+ `(type (eql ,(eql-specializer-object specializer)) ,parameter))
((var-globally-special-p parameter)
;; KLUDGE: Don't declare types for global special variables
;; -- our rebinding magic for SETQ cases don't work right
;; least #.(find-class 'integer) and integer as equivalent
;; specializers with this.
(let* ((specializer (if (and (typep specializer 'class)
- (eq specializer (find-class (class-name specializer))))
+ (let ((name (class-name specializer)))
+ (and name (symbolp name)
+ (eq specializer (find-class name nil)))))
(class-name specializer)
specializer))
(kind (info :type :kind specializer)))
(class (if (or (eq *boot-state* 'complete) (not (consp method)))
(class-of method)
(early-method-class method)))
- (new-type (when (and class
- (or (not (eq *boot-state* 'complete))
- (eq (generic-function-method-combination gf)
- *standard-method-combination*)))
- (cond ((eq class *the-class-standard-reader-method*)
- 'reader)
- ((eq class *the-class-standard-writer-method*)
- 'writer)
- ((eq class *the-class-standard-boundp-method*)
- 'boundp)))))
+ (new-type
+ (when (and class
+ (or (not (eq *boot-state* 'complete))
+ (eq (generic-function-method-combination gf)
+ *standard-method-combination*)))
+ (cond ((or (eq class *the-class-standard-reader-method*)
+ (eq class *the-class-global-reader-method*))
+ 'reader)
+ ((or (eq class *the-class-standard-writer-method*)
+ (eq class *the-class-global-writer-method*))
+ 'writer)
+ ((or (eq class *the-class-standard-boundp-method*)
+ (eq class *the-class-global-boundp-method*))
+ 'boundp)))))
(setq metatypes (mapcar #'raise-metatype metatypes specializers))
(setq type (cond ((null type) new-type)
((eq type new-type) type)
(error "The :GENERIC-FUNCTION-CLASS argument (~S) was neither a~%~
class nor a symbol that names a class."
,gf-class)))
+ (unless (class-finalized-p ,gf-class)
+ (if (class-has-a-forward-referenced-superclass-p ,gf-class)
+ ;; FIXME: reference MOP documentation -- this is an
+ ;; additional requirement on our users
+ (error "The generic function class ~S is not finalizeable" ,gf-class)
+ (finalize-inheritance ,gf-class)))
(remf ,all-keys :generic-function-class)
(remf ,all-keys :environment)
(let ((combin (getf ,all-keys :method-combination '.shes-not-there.)))
arg-info)))
(defun early-make-a-method (class qualifiers arglist specializers initargs doc
- &optional slot-name)
+ &key slot-name object-class method-class-function)
(initialize-method-function initargs)
(let ((parsed ())
(unparsed ()))
;into play when there is more than one
;early method on an early gf.
- (list class ;A list to which real-make-a-method
- qualifiers ;can be applied to make a real method
- arglist ;corresponding to this early one.
- unparsed
- initargs
- doc
- slot-name))))
+ (append
+ (list class ;A list to which real-make-a-method
+ qualifiers ;can be applied to make a real method
+ arglist ;corresponding to this early one.
+ unparsed
+ initargs
+ doc)
+ (when slot-name
+ (list :slot-name slot-name :object-class object-class
+ :method-class-function method-class-function))))))
(defun real-make-a-method
(class qualifiers lambda-list specializers initargs doc
- &optional slot-name)
+ &rest args &key slot-name object-class method-class-function)
(setq specializers (parse-specializers specializers))
- (apply #'make-instance class
- :qualifiers qualifiers
- :lambda-list lambda-list
- :specializers specializers
- :documentation doc
- :slot-name slot-name
- :allow-other-keys t
- initargs))
+ (if method-class-function
+ (let* ((object-class (if (classp object-class) object-class
+ (find-class object-class)))
+ (slots (class-direct-slots object-class))
+ (slot-definition (find slot-name slots
+ :key #'slot-definition-name)))
+ (aver slot-name)
+ (aver slot-definition)
+ (let ((initargs (list* :qualifiers qualifiers :lambda-list lambda-list
+ :specializers specializers :documentation doc
+ :slot-definition slot-definition
+ :slot-name slot-name initargs)))
+ (apply #'make-instance
+ (apply method-class-function object-class slot-definition
+ initargs)
+ initargs)))
+ (apply #'make-instance class :qualifiers qualifiers
+ :lambda-list lambda-list :specializers specializers
+ :documentation doc (append args initargs))))
(defun early-method-function (early-method)
(values (cadr early-method) (caddr early-method)))
(eq class 'standard-boundp-method))))
(defun early-method-standard-accessor-slot-name (early-method)
- (seventh (fifth early-method)))
+ (eighth (fifth early-method)))
;;; Fetch the specializers of an early method. This is basically just
;;; a simple accessor except that when the second argument is t, this
(setf (fourth early-method)
(mapcar #'find-class (cadddr (fifth early-method))))))
(t
- (cadddr (fifth early-method))))
+ (fourth (fifth early-method))))
(error "~S is not an early-method." early-method)))
(defun early-method-qualifiers (early-method)
- (cadr (fifth early-method)))
+ (second (fifth early-method)))
(defun early-method-lambda-list (early-method)
- (caddr (fifth early-method)))
+ (third (fifth early-method)))
(defun early-add-named-method (generic-function-name
qualifiers
projects / sbcl.git / blobdiff