From: Richard M Kreuter Date: Tue, 23 Sep 2008 22:06:03 +0000 (+0000) Subject: 1.0.20.28: Fewer STYLE-WARNINGs for gf calls. X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=28b2447f2775779fe49fd024d8cce069060431c6;p=sbcl.git 1.0.20.28: Fewer STYLE-WARNINGs for gf calls. * Use the union of a gf's defined methods' keys in the info db, so that the compiler won't warn about unrecognized keywords supplied by methods (but will catch typos and whatnot). --- diff --git a/src/compiler/globaldb.lisp b/src/compiler/globaldb.lisp index 1fbdb7c..6c11677 100644 --- a/src/compiler/globaldb.lisp +++ b/src/compiler/globaldb.lisp @@ -953,15 +953,18 @@ ;;; 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 diff --git a/src/compiler/ir1final.lisp b/src/compiler/ir1final.lisp index 8d0e0ca..adc591a 100644 --- a/src/compiler/ir1final.lisp +++ b/src/compiler/ir1final.lisp @@ -77,7 +77,7 @@ (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) diff --git a/src/compiler/ir1tran.lisp b/src/compiler/ir1tran.lisp index e78d86b..d09ddce 100644 --- a/src/compiler/ir1tran.lisp +++ b/src/compiler/ir1tran.lisp @@ -87,6 +87,12 @@ (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) @@ -112,11 +118,13 @@ :%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) diff --git a/src/compiler/node.lisp b/src/compiler/node.lisp index 3c96b07..e0ee5cb 100644 --- a/src/compiler/node.lisp +++ b/src/compiler/node.lisp @@ -624,11 +624,12 @@ ;; :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 diff --git a/src/pcl/boot.lisp b/src/pcl/boot.lisp index e71a3bb..bedfc51 100644 --- a/src/pcl/boot.lisp +++ b/src/pcl/boot.lisp @@ -1701,9 +1701,6 @@ bootstrapping. (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)) ;;;; early generic function support @@ -2096,7 +2093,10 @@ bootstrapping. (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 @@ -2216,7 +2216,10 @@ bootstrapping. (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 @@ -2232,7 +2235,10 @@ bootstrapping. (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)))) (defun safe-gf-arg-info (generic-function) (if (eq (class-of generic-function) *the-class-standard-generic-function*) diff --git a/src/pcl/defs.lisp b/src/pcl/defs.lisp index 5bfa675..bf3dc71 100644 --- a/src/pcl/defs.lisp +++ b/src/pcl/defs.lisp @@ -360,7 +360,12 @@ ;; 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*)) diff --git a/src/pcl/methods.lisp b/src/pcl/methods.lisp index 35f2c35..79ac11b 100644 --- a/src/pcl/methods.lisp +++ b/src/pcl/methods.lisp @@ -560,6 +560,7 @@ :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 @@ -587,11 +588,54 @@ :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))) (defun compute-applicable-methods-function (generic-function arguments) (values (compute-applicable-methods-using-types diff --git a/tests/clos-1.impure.lisp b/tests/clos-1.impure.lisp index c839585..c6947e9 100644 --- a/tests/clos-1.impure.lisp +++ b/tests/clos-1.impure.lisp @@ -120,3 +120,27 @@ (with-test (:name (no-next-method :gf-name-changed)) (new-nnm-tester 1) (assert (= *nnm-count* 2))) + +;;; 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))))))) diff --git a/version.lisp-expr b/version.lisp-expr index b55ef47..0d65854 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -17,4 +17,4 @@ ;;; 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"