(defun load-defgeneric (fun-name lambda-list source-location &rest initargs)
(when (fboundp fun-name)
- (style-warn "redefining ~S in DEFGENERIC" fun-name)
(let ((fun (fdefinition fun-name)))
+ (warn 'sb-kernel:redefinition-with-defgeneric :name fun-name
+ :old fun :new-location source-location)
(when (generic-function-p fun)
(loop for method in (generic-function-initial-methods fun)
do (remove-method fun method))
;; another binding it won't have a %CLASS
;; declaration anymore, and this won't get
;; executed.
- (pushnew var parameters-setqd))))
+ (pushnew var parameters-setqd :test #'eq))))
form)
((and (eq (car form) 'function)
(cond ((eq (cadr form) 'call-next-method)
(generic-function-methods gf)
(find-method gf qualifiers specializers nil))))
(when method
- (style-warn "redefining ~S~{ ~S~} ~S in DEFMETHOD"
- gf-spec qualifiers specializers))))
+ (style-warn 'sb-kernel:redefinition-with-defmethod
+ :generic-function gf-spec :old-method method
+ :qualifiers qualifiers :specializers specializers
+ :new-location source-location))))
(let ((method (apply #'add-named-method
gf-spec qualifiers specializers lambda-list
:definition-source source-location
(when (or allow-other-keys-p old-allowp)
'(&allow-other-keys)))))
*))))
-
-(defun defgeneric-declaration (spec lambda-list)
- `(ftype ,(ftype-declaration-from-lambda-list lambda-list spec) ,spec))
\f
;;;; early generic function support
(aver (= (symbol-value (intern (format nil "*SM-~A-INDEX*" s)))
(!bootstrap-slot-index 'standard-reader-method s)
(!bootstrap-slot-index 'standard-writer-method s)
- (!bootstrap-slot-index 'standard-boundp-method s))))
+ (!bootstrap-slot-index 'standard-boundp-method s)
+ (!bootstrap-slot-index 'global-reader-method s)
+ (!bootstrap-slot-index 'global-writer-method s)
+ (!bootstrap-slot-index 'global-boundp-method s))))
+
+(define-symbol-macro *standard-method-classes*
+ (list *the-class-standard-method* *the-class-standard-reader-method*
+ *the-class-standard-writer-method* *the-class-standard-boundp-method*
+ *the-class-global-reader-method* *the-class-global-writer-method*
+ *the-class-global-boundp-method*))
(defun safe-method-specializers (method)
- (let ((standard-method-classes
- (list *the-class-standard-method*
- *the-class-standard-reader-method*
- *the-class-standard-writer-method*
- *the-class-standard-boundp-method*))
+ (let ((standard-method-classes *standard-method-classes*)
(class (class-of method)))
(if (member class standard-method-classes)
(clos-slots-ref (get-slots method) *sm-specializers-index*)
(and (typep mf '%method-function)
(%method-function-fast-function mf))))
(defun safe-method-function (method)
- (let ((standard-method-classes
- (list *the-class-standard-method*
- *the-class-standard-reader-method*
- *the-class-standard-writer-method*
- *the-class-standard-boundp-method*))
+ (let ((standard-method-classes *standard-method-classes*)
(class (class-of method)))
(if (member class standard-method-classes)
(clos-slots-ref (get-slots method) *sm-%function-index*)
(method-function method))))
(defun safe-method-qualifiers (method)
- (let ((standard-method-classes
- (list *the-class-standard-method*
- *the-class-standard-reader-method*
- *the-class-standard-writer-method*
- *the-class-standard-boundp-method*))
+ (let ((standard-method-classes *standard-method-classes*)
(class (class-of method)))
(if (member class standard-method-classes)
(clos-slots-ref (get-slots method) *sm-qualifiers-index*)
(package (symbol-package symbol)))
(and (or (eq package *pcl-package*)
(memq package (package-use-list *pcl-package*)))
+ (not (eq package #.(find-package "CL")))
;; FIXME: this test will eventually be
;; superseded by the *internal-pcl...* test,
;; above. While we are in a process of
(let ((arg-info (make-arg-info)))
(setf (early-gf-arg-info fin) arg-info)
(when lambda-list-p
- (proclaim (defgeneric-declaration spec lambda-list))
+ (setf (info :function :type spec)
+ (specifier-type
+ (ftype-declaration-from-lambda-list lambda-list spec))
+ (info :function :where-from spec) :defined-method)
(if argument-precedence-order
(set-arg-info fin
:lambda-list lambda-list
(prog1
(apply #'reinitialize-instance existing all-keys)
(when lambda-list-p
- (proclaim (defgeneric-declaration fun-name lambda-list)))))
+ (setf (info :function :type fun-name)
+ (specifier-type
+ (ftype-declaration-from-lambda-list lambda-list fun-name))
+ (info :function :where-from fun-name) :defined-method))))
(defun real-ensure-gf-using-class--null
(existing
(apply #'make-instance generic-function-class
:name fun-name all-keys))
(when lambda-list-p
- (proclaim (defgeneric-declaration fun-name lambda-list)))))
+ (setf (info :function :type fun-name)
+ (specifier-type
+ (ftype-declaration-from-lambda-list lambda-list fun-name))
+ (info :function :where-from fun-name) :defined-method))))
\f
(defun safe-gf-arg-info (generic-function)
(if (eq (class-of generic-function) *the-class-standard-generic-function*)