Changeset 12940


Ignore:
Timestamp:
Oct 9, 2009, 2:46:02 PM (10 years ago)
Author:
gz
Message:

From working-0711 branch: more extensive compile-time checking involving methods/gfs: warn about incongruent lambda lists, duplicate gf defs, required keyword args (from defgeneric), and invalid keyword args in gf calls. Also fix to keep method source files in env function info so dup method warnings can cite the right file.

Location:
trunk/source
Files:
8 edited

Legend:

Unmodified
Added
Removed
  • trunk/source/compiler/nx-basic.lisp

    r12861 r12940  
    584584    (setq env (lexenv.parent-env env))))
    585585
    586 (defun report-compile-time-argument-mismatch (condition stream)
     586(defun report-compile-time-argument-mismatch (condition stream &aux (type (compiler-warning-warning-type condition)))
    587587  (destructuring-bind (callee reason args spread-p)
    588588      (compiler-warning-args condition)
     
    591591            callee
    592592            args)
    593     (case (car reason)
     593    (ecase (car reason)
    594594      (:toomany
    595595       (destructuring-bind (provided max)
     
    606606       (destructuring-bind (badguy goodguys)
    607607           (cdr reason)
    608          (format stream "the keyword argument~:[ ~s is~;s~{ ~s~^~#[~; and~:;,~]~} are~] not one of ~s, which are recognized~&  by "
    609                  (consp badguy) badguy goodguys))))
     608         (format stream "the keyword argument~:[ ~s is~;s~{ ~s~^~#[~; and~:;,~]~} are~] not one of ~:s, which are recognized by "
     609                 (consp badguy) badguy goodguys)))
     610      (:unknown-gf-keywords
     611         (let ((badguys (cadr reason)))
     612           (when (and (consp badguys) (null (%cdr badguys))) (setq badguys (car badguys)))
     613           (format stream "the keyword argument~:[ ~s is~;s~{ ~s~^~#[~; and~:;,~]~} are~] not recognized by "
     614
     615                   (consp badguys) badguys))))
    610616    (format stream
    611             (ecase (compiler-warning-warning-type condition)       
     617            (ecase type
    612618              (:ftype-mismatch "the FTYPE declaration of ~s")
    613619              (:global-mismatch "the current global definition of ~s")
    614620              (:environment-mismatch "the definition of ~s visible in the current compilation unit.")
    615               (:lexical-mismatch "the lexically visible definition of ~s"))
     621              (:lexical-mismatch "the lexically visible definition of ~s")
     622              ;; This can happen when compiling without compilation unit:
     623              (:deferred-mismatch "~s"))
    616624            callee)))
    617625
     
    620628    (:unused . "Unused lexical variable ~S")
    621629    (:ignore . "Variable ~S not ignored.")
    622     (:undefined-function . "Undefined function ~S") ;; (not reported if defined later)
    623     (:undefined-type . "Undefined type ~S")         ;; (not reported if defined later)
     630    (:undefined-function . "Undefined function ~S") ;; (deferred)
     631    (:undefined-type . "Undefined type ~S")         ;; (deferred)
    624632    (:unknown-type-in-declaration . "Unknown or invalid type ~S, declaration ignored")
    625633    (:bad-declaration . "Unknown or invalid declaration ~S")
     
    633641    (:lexical-mismatch . report-compile-time-argument-mismatch)   
    634642    (:ftype-mismatch . report-compile-time-argument-mismatch)
     643    (:deferred-mismatch . report-compile-time-argument-mismatch)
    635644    (:type . "Type declarations violated in ~S")
    636645    (:type-conflict . "Conflicting type declarations for ~S")
    637646    (:special-fbinding . "Attempt to bind compiler special name: ~s. Result undefined.")
    638647    (:lambda . "Suspicious lambda-list: ~s")
     648    (:incongruent-gf-lambda-list . "Lambda list of generic function ~s is incongruent with previously defined methods")
     649    (:incongruent-method-lambda-list . "Lambda list of ~s is incongruent with previous definition of ~s")
     650    (:gf-keys-not-accepted . "~s does not accept keywords ~s required by the generic functions")
    639651    (:result-ignored . "Function result ignored in call to ~s")
    640652    (:duplicate-definition . report-compile-time-duplicate-definition)
  • trunk/source/compiler/nx.lisp

    r12500 r12940  
    199199  '((:undefined-function . undefined-function-reference)
    200200    (:undefined-type . undefined-type-reference)
     201    (:deferred-mismatch . undefined-keyword-reference)
    201202    (:invalid-type . invalid-type-warning)
    202203    (:global-mismatch . invalid-arguments-global)
  • trunk/source/compiler/nx0.lisp

    r12861 r12940  
    20972097
    20982098(defun innermost-lfun-bits-keyvect (def)
    2099   (declare (notinline innermost-lfun-bits-keyvect))
    21002099  (let* ((inner-def (closure-function (find-unencapsulated-definition def)))
    21012100         (bits (lfun-bits inner-def))
    21022101         (keys (lfun-keyvect inner-def)))
    21032102    (declare (fixnum bits))
     2103    #+no
    21042104    (when (and (eq (ash 1 $lfbits-gfn-bit)
    21052105                   (logand bits (logior (ash 1 $lfbits-gfn-bit)
     
    21102110    (values bits keys)))
    21112111
     2112(defun def-info-bits-keyvect (info)
     2113  (let ((bits (def-info.lfbits info)))
     2114    (when (and (eq (def-info.function-type info) 'defgeneric)
     2115               (logbitp $lfbits-keys-bit bits)
     2116               (not (logbitp $lfbits-aok-bit bits))
     2117               #-BOOTSTRAPPED (fboundp 'def-info-method.keyvect)
     2118               (loop for m in (def-info.methods info)
     2119                     thereis (null (def-info-method.keyvect m))))
     2120      ;; Some method has &aok, don't bother checking keywords.
     2121      (setq bits (logior bits (ash 1 $lfbits-aok-bit))))
     2122    (values bits (def-info.keyvect info))))
     2123
    21122124
    21132125(defun nx1-check-call-args (def arglist spread-p)
    2114   (let* ((deftype (if (functionp def)
    2115                     :global-mismatch
    2116                     (if (istruct-typep def 'afunc)
    2117                       :lexical-mismatch
    2118                       :environment-mismatch)))
    2119          (reason nil))
    2120     (multiple-value-bind (bits keyvect)
    2121                          (case deftype
    2122                            (:global-mismatch (innermost-lfun-bits-keyvect def))
    2123                            (:environment-mismatch
    2124                               (values (def-info.lfbits (cdr def)) (def-info.keyvect (cdr def))))
    2125                            (t (let* ((lambda-form (afunc-lambdaform def)))
    2126                                 (if (lambda-expression-p lambda-form)
    2127                                   (encode-lambda-list (cadr lambda-form))))))
    2128       (setq reason (nx1-check-call-bits bits keyvect arglist spread-p))
    2129       (when reason
    2130         (values deftype reason)))))
    2131 
    2132 (defun nx1-check-call-bits (bits keyvect arglist spread-p)
    2133   (when bits
    2134     (unless (typep bits 'fixnum) (error "Bug: Bad bits ~s!" bits))
    2135     (let* ((env *nx-lexical-environment*)
    2136            (nargs (length arglist))
    2137            (minargs (if spread-p (1- nargs) nargs))
    2138            (required (ldb $lfbits-numreq bits))
    2139            (max (if (logtest (logior (ash 1 $lfbits-rest-bit) (ash 1 $lfbits-restv-bit) (ash 1 $lfbits-keys-bit)) bits)
    2140                   nil
    2141                   (+ required (ldb $lfbits-numopt bits)))))
    2142       ;; If the (apparent) number of args in the call doesn't
    2143       ;; match the definition, complain.  If "spread-p" is true,
    2144       ;; we can only be sure of the case when more than the
    2145       ;; required number of args have been supplied.
    2146       (or (and (not spread-p)
    2147                (< minargs required)
    2148                `(:toofew ,minargs ,required))
    2149           (and max
    2150                (> minargs max)
    2151                (list :toomany nargs max))
    2152           (nx1-find-bogus-keywords arglist spread-p bits keyvect env)))))
    2153 
    2154 (defun nx1-find-bogus-keywords (args spread-p bits keyvect env)
    2155   (declare (fixnum bits))
    2156   (when (logbitp $lfbits-aok-bit bits)
    2157     (setq keyvect nil))                 ; only check for even length tail
    2158   (when (and (logbitp $lfbits-keys-bit bits)
    2159              (not spread-p))     ; Can't be sure, last argform may contain :allow-other-keys
    2160     (do* ((bad-keys nil)
    2161           (key-values (nthcdr (+ (ldb $lfbits-numreq bits)  (ldb $lfbits-numopt bits)) args))
    2162           (key-args key-values  (cddr key-args)))
    2163          ((null key-args)
    2164           (when (and keyvect bad-keys)
    2165             (list :unknown-keyword
    2166                   (if (cdr bad-keys) (nreverse bad-keys) (%car bad-keys))
    2167                   (coerce keyvect 'list))))
    2168       (unless (cdr key-args)
    2169         (return (list :odd-keywords key-values)))
    2170       (when keyvect
    2171         (let* ((keyword (%car key-args)))
    2172           (unless (nx-form-constant-p keyword env)
    2173             (return nil))
    2174           (setq keyword (nx-form-constant-value keyword env))
    2175           (if (eq keyword :allow-other-keys)
    2176             (setq keyvect nil)
    2177             (unless (position keyword keyvect)
    2178               (push keyword bad-keys))))))))
     2126  (multiple-value-bind (bits keyvect)
     2127      (etypecase def
     2128        (function (innermost-lfun-bits-keyvect def))
     2129        (afunc (let ((lambda-form (afunc-lambdaform def)))
     2130                 (and (lambda-expression-p lambda-form)
     2131                      (encode-lambda-list (cadr lambda-form) t))))
     2132        (cons (def-info-bits-keyvect (cdr def))))
     2133    (when bits
     2134      (multiple-value-bind (reason defer-p)
     2135          (or (nx1-check-call-bits bits arglist spread-p) ;; never deferred
     2136              (nx1-check-call-keywords def bits keyvect arglist spread-p))
     2137        (when reason
     2138          #-BOOTSTRAPPED (unless (find-class 'undefined-keyword-reference nil)
     2139                           (return-from nx1-check-call-args nil))
     2140          (values (if defer-p
     2141                    :deferred-mismatch
     2142                    (typecase def
     2143                      (function :global-mismatch)
     2144                      (afunc :lexical-mismatch)
     2145                      (t :environment-mismatch)))
     2146                  reason))))))
     2147
     2148(defun nx1-check-call-bits (bits arglist spread-p)
     2149  (let* ((nargs (length arglist))
     2150         (minargs (if spread-p (1- nargs) nargs))
     2151         (required (ldb $lfbits-numreq bits))
     2152         (max (if (logtest (logior (ash 1 $lfbits-rest-bit) (ash 1 $lfbits-restv-bit) (ash 1 $lfbits-keys-bit)) bits)
     2153                nil
     2154                (+ required (ldb $lfbits-numopt bits)))))
     2155    ;; If the (apparent) number of args in the call doesn't
     2156    ;; match the definition, complain.  If "spread-p" is true,
     2157    ;; we can only be sure of the case when more than the
     2158    ;; required number of args have been supplied.
     2159    (or (and (not spread-p)
     2160             (< minargs required)
     2161             `(:toofew ,minargs ,required))
     2162        (and max
     2163             (> minargs max)
     2164             `(:toomany ,nargs ,max)))))
     2165
     2166(defun nx1-check-call-keywords (def bits keyvect args spread-p &aux (env *nx-lexical-environment*))
     2167  ;; Ok, if generic function, bits and keyvect are for the generic function itself.
     2168  ;; Still, since all congruent, can check whether have variable numargs
     2169  (unless (and (logbitp $lfbits-keys-bit bits)
     2170               (not spread-p)) ; last argform may contain :allow-other-keys
     2171    (return-from nx1-check-call-keywords nil))
     2172  (let* ((bad-keys nil)
     2173         (key-args (nthcdr (+ (ldb $lfbits-numreq bits) (ldb $lfbits-numopt bits)) args))
     2174         (generic-p (or (generic-function-p def)
     2175                        (and (consp def)
     2176                             (eq (def-info.function-type (cdr def)) 'defgeneric)))))
     2177    (when (oddp (length key-args))
     2178      (return-from nx1-check-call-keywords (list :odd-keywords key-args)))
     2179    (when (logbitp $lfbits-aok-bit bits)
     2180      (return-from nx1-check-call-keywords nil))
     2181    (loop for key-form in key-args by #'cddr
     2182          do (unless (nx-form-constant-p key-form env) ;; could be :aok
     2183               (return-from nx1-check-call-keywords nil))
     2184          do (let ((key (nx-form-constant-value key-form env)))
     2185               (when (eq key :allow-other-keys)
     2186                 (return-from nx1-check-call-keywords nil))
     2187               (unless (or (find key keyvect)
     2188                          (and generic-p (nx1-valid-gf-keyword-p def key)))
     2189                 (push key bad-keys))))
     2190    (when bad-keys
     2191      (if generic-p
     2192        (values (list :unknown-gf-keywords bad-keys) t)
     2193        (list :unknown-keyword (if (cdr bad-keys) (nreverse bad-keys) (%car bad-keys)) keyvect)))))
     2194
     2195(defun nx1-valid-gf-keyword-p (def key)
     2196  ;; Can assume has $lfbits-keys-bit and not $lfbits-aok-bit
     2197  (if (consp def)
     2198    (let ((definfo (cdr def)))
     2199      (assert (eq (def-info.function-type definfo) 'defgeneric))
     2200      (loop for m in (def-info.methods definfo)
     2201            as keyvect = (def-info-method.keyvect m)
     2202            thereis (or (null keyvect) (find key keyvect))))
     2203    (let ((gf (find-unencapsulated-definition def)))
     2204      (or (find key (%defgeneric-keys gf))
     2205          (loop for m in (%gf-methods gf)
     2206                thereis (let* ((func (%inner-method-function m))
     2207                               (mbits (lfun-bits func)))
     2208                          (or (and (logbitp $lfbits-aok-bit mbits)
     2209                                   ;; If no &rest, then either don't use the keyword in which case
     2210                                   ;; it's good to warn; or it's used via next-method, we'll approve
     2211                                   ;; it when we get to that method.
     2212                                   (logbitp $lfbits-rest-bit mbits))
     2213                              (find key (lfun-keyvect func)))))))))
    21792214
    21802215;;; we can save some space by going through subprims to call "builtin"
  • trunk/source/level-1/l1-clos-boot.lisp

    r12761 r12940  
    360360        (when aokp (setq bits (%ilogior (%ilsl $lfbits-aok-bit 1) bits)))
    361361        (if return-keys?
    362           (values bits (apply #'vector (nreverse key-list)))
     362          (values bits (and keyp (apply #'vector (nreverse key-list))))
    363363          bits)))))
    364364
  • trunk/source/level-1/l1-error-system.lisp

    r12821 r12940  
    8484(define-condition invalid-arguments (style-warning) ())
    8585(define-condition invalid-arguments-global (style-warning) ())
     86(define-condition undefined-keyword-reference (undefined-reference invalid-arguments) ())
    8687
    8788(define-condition simple-error (simple-condition error) ())
  • trunk/source/level-1/l1-readloop.lisp

    r12550 r12940  
    421421
    422422
    423 (defun %cons-def-info (type &optional lfbits keyvect lambda specializers qualifiers)
     423(defun %cons-def-info (type &optional lfbits keyvect data specializers qualifiers)
    424424  (ecase type
    425425    (defun nil)
    426     (defmacro (setq lambda '(macro) lfbits nil)) ;; some code assumes lfbits=nil
    427     (defgeneric (setq lambda (list :methods)))
    428     (defmethod (setq lambda (list :methods (cons qualifiers specializers))))
    429     (deftype (setq lambda '(type) lfbits (cons nil *loading-file-source-file*))))
    430   (vector lfbits keyvect *loading-file-source-file* lambda))
     426    (defmacro (setq data '(macro) lfbits nil)) ;; some code assumes lfbits=nil
     427    (defgeneric (setq data (list :methods) lfbits (logior (ash 1 $lfbits-gfn-bit) lfbits)))
     428    (defmethod (setq data (list :methods
     429                                (%cons-def-info-method lfbits keyvect qualifiers specializers))
     430                     lfbits (logandc2 lfbits (ash 1 $lfbits-aok-bit))
     431                     keyvect nil))
     432    (deftype (setq data '(type) lfbits (cons nil *loading-file-source-file*))))
     433  (vector lfbits keyvect *loading-file-source-file* data))
    431434
    432435(defun def-info.lfbits (def-info)
     
    451454         (and (eq (car data) :methods) (%cdr data)))))
    452455
    453 (defun def-info-with-new-methods (def-info new-methods)
    454   (if (eq new-methods (def-info.methods def-info))
     456(defun %cons-def-info-method (lfbits keyvect qualifiers specializers)
     457  (cons (cons (and keyvect
     458                   (if (logbitp $lfbits-aok-bit lfbits)
     459                     (and (not (logbitp $lfbits-rest-bit lfbits))
     460                          (list keyvect))
     461                     keyvect))
     462              *loading-file-source-file*)
     463        (cons qualifiers specializers)))
     464
     465(defun def-info-method.keyvect (def-info-method)
     466  (let ((kv (caar def-info-method)))
     467    (if (listp kv)
     468      (values (car kv) t)
     469      (values kv  nil))))
     470
     471(defun def-info-method.file (def-info-method)
     472  (cdar def-info-method))
     473
     474(defun def-info-with-new-methods (def-info new-bits new-methods)
     475  (if (and (eq new-methods (def-info.methods def-info))
     476           (eql new-bits (def-info.lfbits def-info)))
    455477    def-info
    456     (let ((new (copy-seq def-info)))
     478    (let ((new (copy-seq def-info))
     479          (old-bits (svref def-info 0)))
     480      (setf (svref new 0) (if (consp old-bits) (cons new-bits (cdr old-bits)) old-bits))
    457481      (setf (svref new 3) (cons :methods new-methods))
    458482      new)))
     
    520544        :deftype-type (def-info.deftype-type def-info)))
    521545
     546(defun combine-gf-def-infos (name old-info new-info)
     547  (let* ((old-bits (def-info.lfbits old-info))
     548         (new-bits (def-info.lfbits new-info))
     549         (old-methods (def-info.methods old-info))
     550         (new-methods (def-info.methods new-info)))
     551    (when (and (logbitp $lfbits-gfn-bit old-bits) (logbitp $lfbits-gfn-bit new-bits))
     552      (when *compiler-warn-on-duplicate-definitions*
     553        (nx1-whine :duplicate-definition
     554                   name
     555                   (def-info.file old-info)
     556                   (def-info.file new-info)))
     557      (return-from combine-gf-def-infos new-info))
     558    (unless (congruent-lfbits-p old-bits new-bits)
     559      (if (logbitp $lfbits-gfn-bit new-bits)
     560        ;; A defgeneric, incongruent with previously defined methods
     561        (nx1-whine :incongruent-gf-lambda-list name)
     562        ;; A defmethod incongruent with previously defined explicit or implicit generic
     563        (nx1-whine :incongruent-method-lambda-list
     564                   (if new-methods `(:method ,@(cadar new-methods) ,name ,(cddar new-methods)) name)
     565                   name))
     566      ;; Perhaps once this happens, should just mark it somehow to not complain again
     567      (return-from combine-gf-def-infos
     568        (if (logbitp $lfbits-gfn-bit old-bits) old-info new-info)))
     569    (loop for new-method in new-methods
     570          as old = (member (cdr new-method) old-methods :test #'equal :key #'cdr)
     571          do (when old
     572               (when *compiler-warn-on-duplicate-definitions*
     573                 (nx1-whine :duplicate-definition
     574                            `(:method ,@(cadr new-method) ,name ,(cddr new-method))
     575                            (def-info-method.file (car old))
     576                            (def-info-method.file new-method)))
     577               (setq old-methods (remove (car old) old-methods :test #'eq)))
     578          do (push new-method old-methods))
     579    (cond ((logbitp $lfbits-gfn-bit new-bits)
     580           ;; If adding a defgeneric, use its info.
     581           (setq old-info new-info old-bits new-bits))
     582          ((not (logbitp $lfbits-gfn-bit old-bits))
     583           ;; If no defgeneric (yet?) just remember whether any method has &key
     584           (setq old-bits (logior old-bits (logand new-bits (ash 1 $lfbits-keys-bit))))))
     585    ;; Check that all methods implement defgeneric keys
     586    (let ((gfkeys (and (logbitp $lfbits-gfn-bit old-bits) (def-info.keyvect old-info))))
     587      (when (> (length gfkeys) 0)
     588        (loop for minfo in old-methods
     589              do (multiple-value-bind (mkeys aok) (def-info-method.keyvect minfo)
     590                   (when (and mkeys
     591                              (not aok)
     592                              (setq mkeys (loop for gk across gfkeys
     593                                                unless (find gk mkeys) collect gk)))
     594                     (nx1-whine :gf-keys-not-accepted
     595                                `(:method ,@(cadr minfo) ,name ,(cddr minfo))
     596                                mkeys))))))
     597    (def-info-with-new-methods old-info old-bits old-methods)))
     598
    522599(defun combine-definition-infos (name old-info new-info)
    523   (let ((old-type (def-info.function-type old-info))  ;; defmacro
    524         (old-deftype (def-info.deftype old-info))      ;; nil
    525         (new-type (def-info.function-type new-info))  ;; nil
    526         (new-deftype (def-info.deftype new-info)))   ;; (nil . file)
     600  (let ((old-type (def-info.function-type old-info))
     601        (old-deftype (def-info.deftype old-info))
     602        (new-type (def-info.function-type new-info))
     603        (new-deftype (def-info.deftype new-info)))
    527604    (cond ((and (eq old-type 'defgeneric) (eq new-type 'defgeneric))
    528            ;; TODO: Check compatibility of lfbits...
    529            ;; TODO: check that all methods implement defgeneric keys
    530            (let ((old-methods (def-info.methods old-info))
    531                  (new-methods (def-info.methods new-info)))
    532              (loop for new-method in new-methods
    533                    do (if (member new-method old-methods :test #'equal)
    534                         (when *compiler-warn-on-duplicate-definitions*
    535                           (nx1-whine :duplicate-definition
    536                                      `(method ,@(car new-method) ,name ,(cdr new-method))
    537                                      (def-info.file old-info)
    538                                      (def-info.file new-info)))
    539                         (push new-method old-methods)))
    540              (setq new-info (def-info-with-new-methods old-info old-methods))))
     605           (setq new-info (combine-gf-def-infos name old-info new-info)))
    541606          ((or (eq (or old-type 'defun) (or new-type 'defun))
    542607               (eq (or old-type 'defgeneric) (or new-type 'defgeneric)))
  • trunk/source/level-1/sysutils.lisp

    r12500 r12940  
    563563    (undefined-type-reference (verify-deferred-type-warning w))
    564564    (undefined-function-reference (verify-deferred-function-warning w))
     565    (undefined-keyword-reference (verify-deferred-keyword-warning w))
    565566    (compiler-warning nil)))
    566567
     
    595596
    596597
     598(defun deferred-function-def (name)
     599  (let* ((defs (deferred-warnings.defs *outstanding-deferred-warnings*))
     600         (def (or (let ((cell (gethash name defs)))
     601                    (and cell (def-info.function-p (cdr cell)) cell))
     602                 (let* ((global (fboundp name)))
     603                   (and (typep global 'function) global)))))
     604    def))
     605
     606(defun check-deferred-call-args (w def wargs)
     607  (destructuring-bind (arglist spread-p) wargs
     608    (multiple-value-bind (deftype reason) (nx1-check-call-args def arglist spread-p)
     609      (when deftype
     610        (when (eq deftype :deferred-mismatch)
     611          (setq deftype (if (consp def) :environment-mismatch :global-mismatch)))
     612        (make-condition
     613         'invalid-arguments
     614         :function-name (compiler-warning-function-name w)
     615         :source-note (compiler-warning-source-note w)
     616         :warning-type deftype
     617         :args (list (car (compiler-warning-args w)) reason arglist spread-p))))))
     618
    597619(defun verify-deferred-function-warning (w)
    598620  (let* ((args (compiler-warning-args w))
    599621         (wfname (car args))
    600          (defs (deferred-warnings.defs *outstanding-deferred-warnings*))
    601          (def (or (let ((cell (gethash wfname defs)))
    602                    (and cell (def-info.function-p (cdr cell)) cell))
    603                  (let* ((global (fboundp wfname)))
    604                    (and (typep global 'function) global)))))
     622         (def (deferred-function-def wfname)))
    605623    (cond ((null def) w)
    606624          ((or (typep def 'function)
     
    609627           ;; Check args in call to forward-referenced function.
    610628           (when (cdr args)
    611              (destructuring-bind (arglist spread-p) (cdr args)
    612                (multiple-value-bind (deftype reason)
    613                    (nx1-check-call-args def arglist spread-p)
    614                  (when deftype
    615                    (let* ((w2 (make-condition
    616                                'invalid-arguments
    617                                :function-name (compiler-warning-function-name w)
    618                                :source-note (compiler-warning-source-note w)
    619                                :warning-type deftype
    620                                :args (list (car args) reason arglist spread-p))))
    621                      w2))))))
     629             (check-deferred-call-args w def (cdr args))))
    622630          ((def-info.macro-p (cdr def))
    623631           (let* ((w2 (make-condition
     
    628636                       :args (list (car args)))))
    629637             w2)))))
     638
     639(defun verify-deferred-keyword-warning (w)
     640  (let* ((args (compiler-warning-args w))
     641         (wfname (car args))
     642         (def (deferred-function-def wfname)))
     643    (when def
     644      (check-deferred-call-args w def (cddr args)))))
    630645
    631646
  • trunk/source/lib/macros.lisp

    r12889 r12940  
    18111811      (append ll '(&allow-other-keys)))))
    18121812
    1813 (defun encode-gf-lambda-list (lambda-list)
    1814   (let* ((bits (encode-lambda-list lambda-list)))
    1815     (declare (fixnum bits))
    1816     (if (logbitp $lfbits-keys-bit bits)
    1817       (logior bits (ash 1 $lfbits-aok-bit))
    1818       bits)))
    1819 
    18201813(defmacro defmethod (name &rest args &environment env)
    18211814  (multiple-value-bind (function-form specializers-form qualifiers lambda-list documentation specializers)
     
    18241817       (eval-when (:compile-toplevel)
    18251818         (record-function-info ',(maybe-setf-function-name name)
    1826                                ',(%cons-def-info 'defmethod (encode-gf-lambda-list lambda-list) nil nil
    1827                                                  specializers qualifiers)
     1819                               ',(multiple-value-bind (bits keyvect) (encode-lambda-list lambda-list t)
     1820                                   (%cons-def-info 'defmethod bits keyvect nil specializers qualifiers))
    18281821                               ,env))
    18291822       (compiler-let ((*nx-method-warning-name* '(,name ,@qualifiers ,specializers)))
     
    21262119         (eval-when (:compile-toplevel)
    21272120           (record-function-info ',(maybe-setf-function-name function-name)
    2128                                  ',(%cons-def-info 'defgeneric (encode-gf-lambda-list lambda-list))
     2121                                 ',(multiple-value-bind (bits keyvect) (encode-lambda-list lambda-list t)
     2122                                     (%cons-def-info 'defgeneric bits keyvect))
    21292123                                 ,env))
    21302124         (let ((,gf (%defgeneric
Note: See TracChangeset for help on using the changeset viewer.