;;; where this information came from:
;;; :ASSUMED = from uses of the object
;;; :DEFINED = from examination of the definition
+;;; :DEFINED-METHOD = implicit, incremental declaration by CLOS.
;;; :DECLARED = from a declaration
-;;; :DEFINED trumps :ASSUMED, and :DECLARED trumps :DEFINED.
+;;; :DEFINED trumps :ASSUMED, :DEFINED-METHOD trumps :DEFINED,
+;;; and :DECLARED trumps :DEFINED-METHOD.
;;; :DEFINED and :ASSUMED are useful for issuing compile-time warnings,
-;;; and :DECLARED is useful for ANSIly specializing code which
-;;; implements the function, or which uses the function's return values.
+;;; :DEFINED-METHOD and :DECLARED are useful for ANSIly specializing
+;;; code which implements the function, or which uses the function's
+;;; return values.
(define-info-type
:class :function
:type :where-from
- :type-spec (member :declared :assumed :defined)
+ :type-spec (member :declared :defined-method :assumed :defined)
:default
;; Again (as in DEFINE-INFO-TYPE :CLASS :FUNCTION :TYPE :KIND) it's
;; not clear how to generalize the FBOUNDP expression to the
(setf (info :function :type source-name) defined-ftype)
(setf (info :function :assumed-type source-name) nil))
(setf (info :function :where-from source-name) :defined))
- (:declared
+ ((:declared :defined-method)
(let ((declared-ftype (info :function :type source-name)))
(unless (defined-ftype-matches-declared-ftype-p
defined-ftype declared-ftype)
(eq (defined-fun-inlinep fun) :notinline)
(eq (info :function :inlinep name) :notinline))))
+;; This will get redefined in PCL boot.
+(declaim (notinline update-info-for-gf))
+(defun maybe-update-info-for-gf (name)
+ (declare (ignorable name))
+ (values))
+
;;; Return a GLOBAL-VAR structure usable for referencing the global
;;; function NAME.
(defun find-global-fun (name latep)
:%source-name name
:type (if (and (not latep)
(or *derive-function-types*
- (eq where :declared)
+ (member where '(:declared :defined-method))
(and (member name *fun-names-in-this-file*
:test #'equal)
(not (fun-lexically-notinline-p name)))))
- (info :function :type name)
+ (progn
+ (maybe-update-info-for-gf name)
+ (info :function :type name))
(specifier-type 'function))
:defined-type (if (eq where :defined)
(info :function :type name)
;; :DECLARED, from a declaration.
;; :ASSUMED, from uses of the object.
;; :DEFINED, from examination of the definition.
+ ;; :DEFINED-METHOD, implicit, piecemeal declarations from CLOS.
;; FIXME: This should be a named type. (LEAF-WHERE-FROM? Or
;; perhaps just WHERE-FROM, since it's not just used in LEAF,
;; but also in various DEFINE-INFO-TYPEs in globaldb.lisp,
;; and very likely elsewhere too.)
- (where-from :assumed :type (member :declared :assumed :defined))
+ (where-from :assumed :type (member :declared :assumed :defined :defined-method))
;; list of the REF nodes for this leaf
(refs () :type list)
;; true if there was ever a REF or SET node for this leaf. This may
(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
(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*)
;; Used to make DFUN-STATE & FIN-FUNCTION updates atomic.
(%lock
:initform (sb-thread::make-spinlock :name "GF lock")
- :reader gf-lock))
+ :reader gf-lock)
+ ;; Set to true by ADD-METHOD, REMOVE-METHOD; to false by
+ ;; MAYBE-UPDATE-INFO-FOR-GF.
+ (info-needs-update
+ :initform nil
+ :accessor gf-info-needs-update))
(:metaclass funcallable-standard-class)
(:default-initargs :method-class *the-class-standard-method*
:method-combination *standard-method-combination*))
:generic-function generic-function
:method method)
(update-dfun generic-function))
+ (setf (gf-info-needs-update generic-function) t)
(map-dependents generic-function
(lambda (dep)
(update-dependent generic-function
:generic-function generic-function
:method method)
(update-dfun generic-function)
+ (setf (gf-info-needs-update generic-function) t)
(map-dependents generic-function
(lambda (dep)
(update-dependent generic-function
dep 'remove-method method)))))))
generic-function)
+
+
+;; Tell INFO about the generic function's methods' keys so that the
+;; compiler doesn't complain that the keys defined for some method are
+;; unrecognized.
+(sb-ext:without-package-locks
+ (defun sb-c::maybe-update-info-for-gf (name)
+ (let ((gf (if (fboundp name) (fdefinition name))))
+ (when (and gf (generic-function-p gf) (not (early-gf-p gf))
+ (not (eq :declared (info :function :where-from name)))
+ (gf-info-needs-update gf))
+ (let* ((methods (generic-function-methods gf))
+ (gf-lambda-list (generic-function-lambda-list gf))
+ (tfun (constantly t))
+ keysp)
+ (multiple-value-bind
+ (gf.required gf.optional gf.rest ignore gf.allowp)
+ (%split-arglist gf-lambda-list)
+ (declare (ignore ignore))
+ (setf (info :function :type name)
+ (specifier-type
+ `(function
+ (,@(mapcar tfun gf.required)
+ ,@(if gf.optional
+ `(&optional ,@(mapcar tfun gf.optional)))
+ ,@(if gf.rest
+ `(&rest t))
+ ,@(let ((all-keys
+ (mapcar
+ (lambda (x)
+ (list x t))
+ (remove-duplicates
+ (mapcan #'function-keywords methods)))))
+ (when all-keys
+ (setq keysp t)
+ `(&key ,@all-keys)))
+ ,@(if (and keysp gf.allowp)
+ `(&allow-other-keys)))
+ *))
+ (info :function :where-from name) :defined-method
+ (gf-info-needs-update gf) nil)))))
+ (values)))
\f
(defun compute-applicable-methods-function (generic-function arguments)
(values (compute-applicable-methods-using-types
(with-test (:name (no-next-method :gf-name-changed))
(new-nnm-tester 1)
(assert (= *nnm-count* 2)))
+\f
+;;; Tests the compiler's incremental rejiggering of GF types.
+(fmakunbound 'foo)
+(with-test (:name keywords-supplied-in-methods-ok-1)
+ (assert
+ (null
+ (nth-value
+ 1
+ (progn
+ (defgeneric foo (x &key))
+ (defmethod foo ((x integer) &key bar) (list x bar))
+ (compile nil '(lambda () (foo (read) :bar 10))))))))
+
+(fmakunbound 'foo)
+(with-test (:name keywords-supplied-in-methods-ok-2)
+ (assert
+ (nth-value
+ 1
+ (progn
+ (defgeneric foo (x &key))
+ (defmethod foo ((x integer) &key bar) (list x bar))
+ ;; On second thought...
+ (remove-method #'foo (find-method #'foo () '(integer)))
+ (compile nil '(lambda () (foo (read) :bar 10)))))))
;;; checkins which aren't released. (And occasionally for internal
;;; versions, especially for internal versions off the main CVS
;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"1.0.20.27"
+"1.0.20.28"
projects / sbcl.git / commitdiff