Changeset 12585

Timestamp:

Aug 15, 2009, 7:40:54 AM (15 years ago)

Author:

gz

Message:

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. Also merged r12581 and r12583 from trunk

Location:

branches/working-0711/ccl

Files:

• compiler/nx-basic.lisp (modified) (5 diffs)
• compiler/nx.lisp (modified) (1 diff)
• compiler/nx0.lisp (modified) (3 diffs)
• compiler/nx1.lisp (modified) (3 diffs)
• level-1/l1-error-system.lisp (modified) (1 diff)
• level-1/l1-readloop.lisp (modified) (3 diffs)
• level-1/l1-typesys.lisp (modified) (1 diff)
• level-1/sysutils.lisp (modified) (4 diffs)
• lib/macros.lisp (modified) (3 diffs)

branches/working-0711/ccl/compiler/nx-basic.lisp

@@ -587 +587 @@
     (setq env (lexenv.parent-env env))))
 
-(defun report-compile-time-argument-mismatch (condition stream)
+(defun report-compile-time-argument-mismatch (condition stream &aux (type (compiler-warning-warning-type condition)))
   (destructuring-bind (callee reason args spread-p)
       (compiler-warning-args condition)
@@ -594 +594 @@
             callee
             args)
-    (case (car reason)
+    (ecase (car reason)
       (:toomany
        (destructuring-bind (provided max)
@@ -609 +609 @@
        (destructuring-bind (badguy goodguys)
            (cdr reason)
-         (format stream "the keyword argument~:[ ~s is~;s~{ ~s~^~#[~; and~:;,~]~} are~] not one of ~s, which are recognized~&  by "
-                 (consp badguy) badguy goodguys))))
+         (format stream "the keyword argument~:[ ~s is~;s~{ ~s~^~#[~; and~:;,~]~} are~] not one of ~:s, which are recognized by "
+                 (consp badguy) badguy goodguys)))
+      (:unknown-gf-keywords
+         (let ((badguys (cadr reason)))
+           (format stream "the keyword argument~:[ ~s is~;s~{ ~s~^~#[~; and~:;,~]~} are~] not recognized by "
+                   (consp badguys) badguys))))
     (format stream
-            (ecase (compiler-warning-warning-type condition)       
+            (ecase type
               (:ftype-mismatch "the FTYPE declaration of ~s")
               (:global-mismatch "the current global definition of ~s")
@@ -623 +627 @@
     (:unused . "Unused lexical variable ~S")
     (:ignore . "Variable ~S not ignored.")
-    (:undefined-function . "Undefined function ~S") ;; (not reported if defined later)
-    (:undefined-type . "Undefined type ~S")         ;; (not reported if defined later)
+    (:undefined-function . "Undefined function ~S") ;; (deferred)
+    (:undefined-type . "Undefined type ~S")         ;; (deferred)
     (:unknown-type-in-declaration . "Unknown or invalid type ~S, declaration ignored")
     (:bad-declaration . "Unknown or invalid declaration ~S")
@@ -640 +644 @@
     (:special-fbinding . "Attempt to bind compiler special name: ~s. Result undefined.")
     (:lambda . "Suspicious lambda-list: ~s")
+    (:incongruent-gf-lambda-list . "Lambda list of generic function ~s is incongruent with previously defined methods")
+    (:incongruent-method-lambda-list . "Lambda list of ~s is incongruent with previous definition of ~s")
+    (:gf-keys-not-accepted . "~s does not accept keywords ~s required by the generic functions")
     (:result-ignored . "Function result ignored in call to ~s")
     (:duplicate-definition . report-compile-time-duplicate-definition)

branches/working-0711/ccl/compiler/nx.lisp

@@ -199 +199 @@
   '((:undefined-function . undefined-function-reference)
     (:undefined-type . undefined-type-reference)
+    (:deferred-mismatch . undefined-keyword-reference)
     (:invalid-type . invalid-type-warning)
     (:global-mismatch . invalid-arguments-global)

branches/working-0711/ccl/compiler/nx0.lisp

@@ -1869 +1869 @@
 
 (defun nx1-type-intersect (form type1 type2 &optional (env *nx-lexical-environment*))
-  (let* ((ctype1 (if (typep type1 'ctype) type1 (specifier-type type1 env)))
-         (ctype2 (if (typep type2 'ctype) type2 (specifier-type type2 env)))
-         (intersection (type-intersection ctype1 ctype2)))
+  (let* ((ctype1 (if (typep type1 'ctype) type1 (values-specifier-type type1 env)))
+         (ctype2 (if (typep type2 'ctype) type2 (values-specifier-type type2 env)))
+         (intersection (if (or (values-ctype-p ctype1) (values-ctype-p ctype2))
+                         (values-type-intersection ctype1 ctype2)
+                         (type-intersection ctype1 ctype2))))
     (when (eq intersection *empty-type*)
       (let ((type1 (if (typep type1 'ctype)
@@ -2075 +2077 @@
 
 (defun innermost-lfun-bits-keyvect (def)
-  (declare (notinline innermost-lfun-bits-keyvect))
   (let* ((inner-def (closure-function (find-unencapsulated-definition def)))
          (bits (lfun-bits inner-def))
          (keys (lfun-keyvect inner-def)))
     (declare (fixnum bits))
+    #+no
     (when (and (eq (ash 1 $lfbits-gfn-bit)
                    (logand bits (logior (ash 1 $lfbits-gfn-bit)
@@ -2088 +2090 @@
     (values bits keys)))
 
+(defun def-info-bits-keyvect (info)
+  (let ((bits (def-info.lfbits info)))
+    (when (and (eq (def-info.function-type info) 'defgeneric)
+               (logbitp $lfbits-keys-bit bits)
+               (not (logbitp $lfbits-aok-bit bits))
+               (loop for m in (def-info.methods info)
+                     thereis (nth-value 1 (def-info-method.keyvect m))))
+      ;; Some method has &aok, don't bother checking keywords.
+      (setq bits (logior bits (ash 1 $lfbits-aok-bit))))
+    (values bits (def-info.keyvect info))))
+
 
 (defun nx1-check-call-args (def arglist spread-p)
-  (let* ((deftype (if (functionp def) 
-                    :global-mismatch
-                    (if (istruct-typep def 'afunc)
-                      :lexical-mismatch
-                      :environment-mismatch)))
-         (reason nil))
-    (multiple-value-bind (bits keyvect)
-                         (case deftype
-                           (:global-mismatch (innermost-lfun-bits-keyvect def))
-                           (:environment-mismatch
-                              (values (def-info.lfbits (cdr def)) (def-info.keyvect (cdr def))))
-                           (t (let* ((lambda-form (afunc-lambdaform def)))
-                                (if (lambda-expression-p lambda-form)
-                                  (encode-lambda-list (cadr lambda-form))))))
-      (setq reason (nx1-check-call-bits bits keyvect arglist spread-p))
-      (when reason
-        (values deftype reason)))))
-
-(defun nx1-check-call-bits (bits keyvect arglist spread-p)
-  (when bits
-    (unless (typep bits 'fixnum) (error "Bug: Bad bits ~s!" bits))
-    (let* ((env *nx-lexical-environment*)
-           (nargs (length arglist))
-           (minargs (if spread-p (1- nargs) nargs))
-           (required (ldb $lfbits-numreq bits))
-           (max (if (logtest (logior (ash 1 $lfbits-rest-bit) (ash 1 $lfbits-restv-bit) (ash 1 $lfbits-keys-bit)) bits)
-                  nil
-                  (+ required (ldb $lfbits-numopt bits)))))
-      ;; If the (apparent) number of args in the call doesn't
-      ;; match the definition, complain.  If "spread-p" is true,
-      ;; we can only be sure of the case when more than the
-      ;; required number of args have been supplied.
-      (or (and (not spread-p)
-               (< minargs required)
-               `(:toofew ,minargs ,required))
-          (and max
-               (> minargs max)
-               (list :toomany nargs max))
-          (nx1-find-bogus-keywords arglist spread-p bits keyvect env)))))
-
-(defun nx1-find-bogus-keywords (args spread-p bits keyvect env)
-  (declare (fixnum bits))
-  (when (logbitp $lfbits-aok-bit bits)
-    (setq keyvect nil))                 ; only check for even length tail
-  (when (and (logbitp $lfbits-keys-bit bits) 
-             (not spread-p))     ; Can't be sure, last argform may contain :allow-other-keys
-    (do* ((bad-keys nil)
-          (key-values (nthcdr (+ (ldb $lfbits-numreq bits)  (ldb $lfbits-numopt bits)) args))
-          (key-args key-values  (cddr key-args)))
-         ((null key-args)
-          (when (and keyvect bad-keys)
-            (list :unknown-keyword
-                  (if (cdr bad-keys) (nreverse bad-keys) (%car bad-keys))
-                  (coerce keyvect 'list))))
-      (unless (cdr key-args)
-        (return (list :odd-keywords key-values)))
-      (when keyvect
-        (let* ((keyword (%car key-args)))
-          (unless (nx-form-constant-p keyword env)
-            (return nil))
-          (setq keyword (nx-form-constant-value keyword env))
-          (if (eq keyword :allow-other-keys)
-            (setq keyvect nil)
-            (unless (position keyword keyvect)
-              (push keyword bad-keys))))))))
+  (multiple-value-bind (bits keyvect)
+      (etypecase def
+        (function (innermost-lfun-bits-keyvect def))
+        (afunc (let ((lambda-form (afunc-lambdaform def)))
+                 (and (lambda-expression-p lambda-form)
+                      (encode-lambda-list (cadr lambda-form) t))))
+        (cons (def-info-bits-keyvect (cdr def))))
+    (when bits
+      (multiple-value-bind (reason defer-p)
+          (or (nx1-check-call-bits bits arglist spread-p) ;; never deferred
+              (nx1-check-call-keywords def bits keyvect arglist spread-p))
+        (when reason
+          #-BOOTSTRAPPED (unless (find-class 'undefined-keyword-reference nil)
+                           (return-from nx1-check-call-args nil))
+          (values (if defer-p
+                    :deferred-mismatch
+                    (typecase def
+                      (function :global-mismatch)
+                      (afunc :lexical-mismatch)
+                      (t :environment-mismatch)))
+                  reason))))))
+
+(defun nx1-check-call-bits (bits arglist spread-p)
+  (let* ((nargs (length arglist))
+         (minargs (if spread-p (1- nargs) nargs))
+         (required (ldb $lfbits-numreq bits))
+         (max (if (logtest (logior (ash 1 $lfbits-rest-bit) (ash 1 $lfbits-restv-bit) (ash 1 $lfbits-keys-bit)) bits)
+                nil
+                (+ required (ldb $lfbits-numopt bits)))))
+    ;; If the (apparent) number of args in the call doesn't
+    ;; match the definition, complain.  If "spread-p" is true,
+    ;; we can only be sure of the case when more than the
+    ;; required number of args have been supplied.
+    (or (and (not spread-p)
+             (< minargs required)
+             `(:toofew ,minargs ,required))
+        (and max
+             (> minargs max)
+             `(:toomany ,nargs ,max)))))
+
+(defun nx1-check-call-keywords (def bits keyvect args spread-p &aux (env *nx-lexical-environment*))
+  ;; Ok, if generic function, bits and keyvect are for the generic function itself.
+  ;; Still, since all congruent, can check whether have variable numargs
+  (unless (and (logbitp $lfbits-keys-bit bits)
+               (not spread-p)) ; last argform may contain :allow-other-keys
+    (return-from nx1-check-call-keywords nil))
+  (let* ((bad-keys nil)
+         (key-args (nthcdr (+ (ldb $lfbits-numreq bits) (ldb $lfbits-numopt bits)) args))
+         (generic-p (or (generic-function-p def)
+                        (and (consp def)
+                             (eq (def-info.function-type (cdr def)) 'defgeneric)))))
+    (when (oddp (length key-args))
+      (return-from nx1-check-call-keywords (list :odd-keywords key-args)))
+    (when (logbitp $lfbits-aok-bit bits)
+      (return-from nx1-check-call-keywords nil))
+    (loop for key-form in key-args by #'cddr
+          do (unless (nx-form-constant-p key-form env) ;; could be :aok
+               (return-from nx1-check-call-keywords nil))
+          do (let ((key (nx-form-constant-value key-form env)))
+               (when (eq key :allow-other-keys)
+                 (return-from nx1-check-call-keywords nil))
+               (unless (or (find key keyvect)
+                          (and generic-p (nx1-valid-gf-keyword-p def key)))
+                 (push key bad-keys))))
+    (when bad-keys
+      (if generic-p
+        (values (list :unknown-gf-keywords bad-keys) t)
+        (list :unknown-keyword (if (cdr bad-keys) (nreverse bad-keys) (%car bad-keys)) keyvect)))))
+
+(defun nx1-valid-gf-keyword-p (def key)
+  ;; Can assume has $lfbits-keys-bit and not $lfbits-aok-bit
+  (if (consp def)
+    (let ((definfo (cdr def)))
+      (assert (eq (def-info.function-type definfo) 'defgeneric))
+      (loop for m in (def-info.methods definfo)
+            thereis (multiple-value-bind (keyvect aok) (def-info-method.keyvect m)
+                      (or aok (find key keyvect)))))
+    (let ((gf (find-unencapsulated-definition def)))
+      (or (find key (%defgeneric-keys gf))
+          (loop for m in (%gf-methods gf)
+                thereis (let* ((func (%inner-method-function m))
+                               (mbits (lfun-bits func)))
+                          (or (and (logbitp $lfbits-aok-bit mbits)
+                                   ;; If no &rest, then either don't use the keyword in which case
+                                   ;; it's good to warn; or it's used via next-method, we'll approve
+                                   ;; it when we get to that method.
+                                   (logbitp $lfbits-rest-bit mbits))
+                              (find key (lfun-keyvect func)))))))))
 
 ;;; we can save some space by going through subprims to call "builtin"

branches/working-0711/ccl/compiler/nx1.lisp

@@ -17 +17 @@
 (in-package "CCL")
 
-;;; Wimp out, but don't choke on (the (values ...) form)
 (defnx1 nx1-the the (&whole call typespec form &environment env)
   ;; Allow VALUES types here (or user-defined types that
@@ -29 +28 @@
                            (parse-unknown-type (c)
                              (nx1-whine :unknown-type-in-declaration (parse-unknown-type-specifier c))
-                             nil)
+                             *wild-type*)
                            (program-error (c)
                               (nx1-whine :invalid-type typespec c)
-                              nil))))
-             (if (null ctype)
-               '*
-               (if (typep ctype 'function-ctype)
-                 'function
-                 (nx-target-type (type-specifier (single-value-type ctype))))))))
+                             *wild-type*))))
+             (if (typep ctype 'function-ctype)
+               'function
+               (nx-target-type (type-specifier ctype))))))
     (let* ((typespec (typespec-for-the typespec))
            (*nx-form-type* typespec)
@@ -59 +56 @@
           (when (eq transformed last)
             (return)))
-        (when (and (nx-form-constant-p transformed env)
-                   (not (typep (nx-form-constant-value transformed env) typespec)))
-          (nx1-whine :type call)
-          (setq typespec t))
-        (setq typespec (nx-target-type
-                        (or (nx1-type-intersect call
-                                                typespec
-                                                (typespec-for-the (nx-form-type transformed env)))
-                            t)))
+        (if (and (nx-form-constant-p transformed env)
+                 (or (equal typespec '(values))
+                     (not (typep (nx-form-constant-value transformed env)
+                                 (single-value-type (values-specifier-type typespec))))))
+          (progn
+            (nx1-whine :type call)
+            (setq typespec '*))
+          (setq typespec (nx-target-type
+                          (or (nx1-type-intersect call
+                                                  typespec
+                                                  (typespec-for-the (nx-form-type transformed env)))
+                              '*))))
+        ;; Wimp out, but don't choke on (the (values ...) form)
+        (when (and (consp typespec) (eq (car typespec) 'values))
+          (setq typespec '*))
         (make-acode
          (%nx1-operator typed-form)

branches/working-0711/ccl/level-1/l1-error-system.lisp

@@ -84 +84 @@
 (define-condition invalid-arguments (style-warning) ())
 (define-condition invalid-arguments-global (style-warning) ())
+(define-condition undefined-keyword-reference (undefined-reference invalid-arguments) ())
 
 (define-condition simple-error (simple-condition error) ())

branches/working-0711/ccl/level-1/l1-readloop.lisp

@@ -421 +421 @@
 
 
-(defun %cons-def-info (type &optional lfbits keyvect lambda specializers qualifiers)
+(defun %cons-def-info (type &optional lfbits keyvect data specializers qualifiers)
   (ecase type
     (defun nil)
-    (defmacro (setq lambda '(macro) lfbits nil)) ;; some code assumes lfbits=nil
-    (defgeneric (setq lambda (list :methods)))
-    (defmethod (setq lambda (list :methods (cons qualifiers specializers))))
-    (deftype (setq lambda '(type) lfbits (cons nil *loading-file-source-file*))))
-  (vector lfbits keyvect *loading-file-source-file* lambda))
+    (defmacro (setq data '(macro) lfbits nil)) ;; some code assumes lfbits=nil
+    (defgeneric (setq data (list :methods) lfbits (logior (ash 1 $lfbits-gfn-bit) lfbits)))
+    (defmethod (setq data (list :methods
+                                (%cons-def-info-method lfbits keyvect qualifiers specializers))
+                     lfbits (logandc2 lfbits (ash 1 $lfbits-aok-bit))
+                     keyvect nil))
+    (deftype (setq data '(type) lfbits (cons nil *loading-file-source-file*))))
+  (vector lfbits keyvect *loading-file-source-file* data))
 
 (defun def-info.lfbits (def-info)
@@ -451 +454 @@
          (and (eq (car data) :methods) (%cdr data)))))
 
-(defun def-info-with-new-methods (def-info new-methods)
-  (if (eq new-methods (def-info.methods def-info))
+(defun %cons-def-info-method (lfbits keyvect qualifiers specializers)
+  (cons (cons (and keyvect
+                   (if (and (logbitp $lfbits-aok-bit lfbits)
+                            (logbitp $lfbits-rest-bit lfbits))
+                       (list keyvect)
+                       keyvect))
+              *loading-file-source-file*)
+        (cons qualifiers specializers)))
+
+(defun def-info-method.keyvect (def-info-method)
+  (let ((kv (caar def-info-method)))
+    (if (listp kv)
+      (values (car kv) t)
+      (values kv  nil))))
+
+(defun def-info-method.file (def-info-method)
+  (cdar def-info-method))
+
+(defun def-info-with-new-methods (def-info new-bits new-methods)
+  (if (and (eq new-methods (def-info.methods def-info))
+           (eql new-bits (def-info.lfbits def-info)))
     def-info
-    (let ((new (copy-seq def-info)))
+    (let ((new (copy-seq def-info))
+          (old-bits (svref def-info 0)))
+      (setf (svref new 0) (if (consp old-bits) (cons new-bits (cdr old-bits)) old-bits))
       (setf (svref new 3) (cons :methods new-methods))
       new)))
@@ -520 +544 @@
         :deftype-type (def-info.deftype-type def-info)))
 
+(defun combine-gf-def-infos (name old-info new-info)
+  (let* ((old-bits (def-info.lfbits old-info))
+         (new-bits (def-info.lfbits new-info))
+         (old-methods (def-info.methods old-info))
+         (new-methods (def-info.methods new-info)))
+    (when (and (logbitp $lfbits-gfn-bit old-bits) (logbitp $lfbits-gfn-bit new-bits))
+      (when *compiler-warn-on-duplicate-definitions*
+        (nx1-whine :duplicate-definition
+                   name
+                   (def-info.file old-info)
+                   (def-info.file new-info)))
+      (return-from combine-gf-def-infos new-info))
+    (unless (congruent-lfbits-p old-bits new-bits)
+      ;; Too bad don't have the actual lambda lists recorded.
+      (if (logbitp $lfbits-gfn-bit new-bits)
+        ;; A defgeneric, incongruent with previously defined methods
+        (nx1-whine :incongruent-gf-lambda-list name)
+        ;; A defmethod incongruent with previously defined explicit or implicit generic
+        (nx1-whine :incongruent-method-lambda-list
+                   (if new-methods `(:method ,@(cadar new-methods) ,name ,(cddar new-methods)) name)
+                   name))
+      ;; Perhaps once this happens, should just mark it somehow to not complain again
+      (return-from combine-gf-def-infos 
+        (if (logbitp $lfbits-gfn-bit old-bits) old-info new-info)))
+    (loop for new-method in new-methods
+          as old = (member (cdr new-method) old-methods :test #'equal :key #'cdr)
+          do (when old
+               (when *compiler-warn-on-duplicate-definitions*
+                 (nx1-whine :duplicate-definition
+                            `(:method ,@(cadr new-method) ,name ,(cddr new-method))
+                            (def-info-method.file (car old))
+                            (def-info-method.file new-method)))
+               (setq old-methods (remove (car old) old-methods :test #'eq)))
+          do (push new-method old-methods))
+    (cond ((logbitp $lfbits-gfn-bit new-bits)
+           ;; If adding a defgeneric, use its info.
+           (setq old-info new-info old-bits new-bits))
+          ((not (logbitp $lfbits-gfn-bit old-bits))
+           ;; If no defgeneric (yet?) just remember whether any method has &key
+           (setq old-bits (logior old-bits (logand new-bits (ash 1 $lfbits-keys-bit))))))
+    ;; Check that all methods implement defgeneric keys
+    (let ((gfkeys (and (logbitp $lfbits-gfn-bit old-bits) (def-info.keyvect old-info))))
+      (when (> (length gfkeys) 0)
+        (loop for minfo in old-methods
+              do (multiple-value-bind (mkeys aok) (def-info-method.keyvect minfo)
+                   (when (and (not aok)
+                              (setq mkeys (loop for gk across gfkeys
+                                                unless (find gk mkeys) collect gk)))
+                     (nx1-whine :gf-keys-not-accepted
+                                `(:method ,@(cadr minfo) ,name ,(cddr minfo))
+                                mkeys))))))
+    (def-info-with-new-methods old-info old-bits old-methods)))
+
 (defun combine-definition-infos (name old-info new-info)
-  (let ((old-type (def-info.function-type old-info))  ;; defmacro
-        (old-deftype (def-info.deftype old-info))      ;; nil
-        (new-type (def-info.function-type new-info))  ;; nil
-        (new-deftype (def-info.deftype new-info)))   ;; (nil . file)
+  (let ((old-type (def-info.function-type old-info))
+        (old-deftype (def-info.deftype old-info))
+        (new-type (def-info.function-type new-info))
+        (new-deftype (def-info.deftype new-info)))
     (cond ((and (eq old-type 'defgeneric) (eq new-type 'defgeneric))
-           ;; TODO: Check compatibility of lfbits...
-           ;; TODO: check that all methods implement defgeneric keys
-           (let ((old-methods (def-info.methods old-info))
-                 (new-methods (def-info.methods new-info)))
-             (loop for new-method in new-methods
-                   do (if (member new-method old-methods :test #'equal)
-                        (when *compiler-warn-on-duplicate-definitions*
-                          (nx1-whine :duplicate-definition
-                                     `(method ,@(car new-method) ,name ,(cdr new-method))
-                                     (def-info.file old-info)
-                                     (def-info.file new-info)))
-                        (push new-method old-methods)))
-             (setq new-info (def-info-with-new-methods old-info old-methods))))
+           (setq new-info (combine-gf-def-infos name old-info new-info)))
           ((or (eq (or old-type 'defun) (or new-type 'defun))
                (eq (or old-type 'defgeneric) (or new-type 'defgeneric)))

branches/working-0711/ccl/level-1/l1-typesys.lisp

@@ -1510 +1510 @@
             (setq locked t)
             (if (or (symbolp spec)
-                    (and (consp spec) (symbolp (car spec))))
+                    (and (consp spec)
+                         (symbolp (car spec))
+                         ;; hashing scheme uses equal, so only use when equivalent to eql
+                         (not (and (eq (car spec) 'member)
+                                   (some (lambda (x)
+                                           (typep x '(or cons string bit-vector pathname)))
+                                         (cdr spec))))))
               (let* ((idx (hash-type-specifier spec)))
                 (incf probes)

branches/working-0711/ccl/level-1/sysutils.lisp

@@ -563 +563 @@
     (undefined-type-reference (verify-deferred-type-warning w))
     (undefined-function-reference (verify-deferred-function-warning w))
+    (undefined-keyword-reference (verify-deferred-keyword-warning w))
     (compiler-warning nil)))
 
@@ -595 +596 @@
 
 
+(defun deferred-function-def (name)
+  (let* ((defs (deferred-warnings.defs *outstanding-deferred-warnings*))
+         (def (or (let ((cell (gethash name defs)))
+                    (and cell (def-info.function-p (cdr cell)) cell))
+                 (let* ((global (fboundp name)))
+                   (and (typep global 'function) global)))))
+    def))
+
+(defun check-deferred-call-args (w def wargs)
+  (destructuring-bind (arglist spread-p) wargs
+    (multiple-value-bind (deftype reason) (nx1-check-call-args def arglist spread-p)
+      (when deftype
+        (when (eq deftype :deferred-mismatch)
+          (setq deftype (if (consp def) :environment-mismatch :global-mismatch)))
+        (make-condition
+         'invalid-arguments
+         :function-name (compiler-warning-function-name w)
+         :source-note (compiler-warning-source-note w)
+         :warning-type deftype
+         :args (list* (car (compiler-warning-args w)) reason arglist spread-p))))))
+
 (defun verify-deferred-function-warning (w)
   (let* ((args (compiler-warning-args w))
          (wfname (car args))
-         (defs (deferred-warnings.defs *outstanding-deferred-warnings*))
-         (def (or (let ((cell (gethash wfname defs)))
-                   (and cell (def-info.function-p (cdr cell)) cell))
-                 (let* ((global (fboundp wfname)))
-                   (and (typep global 'function) global)))))
+         (def (deferred-function-def wfname)))
     (cond ((null def) w)
           ((or (typep def 'function)
@@ -609 +627 @@
            ;; Check args in call to forward-referenced function.
            (when (cdr args)
-             (destructuring-bind (arglist spread-p) (cdr args)
-               (multiple-value-bind (deftype reason)
-                   (nx1-check-call-args def arglist spread-p)
-                 (when deftype
-                   (let* ((w2 (make-condition
-                               'invalid-arguments
-                               :function-name (compiler-warning-function-name w)
-                               :source-note (compiler-warning-source-note w)
-                               :warning-type deftype
-                               :args (list (car args) reason arglist spread-p))))
-                     w2))))))
+             (check-deferred-call-args w def (cdr args))))
           ((def-info.macro-p (cdr def))
            (let* ((w2 (make-condition
@@ -628 +636 @@
                        :args (list (car args)))))
              w2)))))
+
+(defun verify-deferred-keyword-warning (w)
+  (let* ((args (compiler-warning-args w))
+         (wfname (car args))
+         (def (deferred-function-def wfname)))
+    (when def
+      (check-deferred-call-args w def (cddr args)))))
 
 

branches/working-0711/ccl/lib/macros.lisp

@@ -1765 +1765 @@
       (append ll '(&allow-other-keys)))))
 
-(defun encode-gf-lambda-list (lambda-list)
-  (let* ((bits (encode-lambda-list lambda-list)))
-    (declare (fixnum bits))
-    (if (logbitp $lfbits-keys-bit bits)
-      (logior bits (ash 1 $lfbits-aok-bit))
-      bits)))
-
 (defmacro defmethod (name &rest args &environment env)
   (multiple-value-bind (function-form specializers-form qualifiers lambda-list documentation specializers)
@@ -1778 +1771 @@
        (eval-when (:compile-toplevel)
          (record-function-info ',(maybe-setf-function-name name)
-                               ',(%cons-def-info 'defmethod (encode-gf-lambda-list lambda-list) nil nil
-                                                 specializers qualifiers)
+                               ',(multiple-value-bind (bits keyvect) (encode-lambda-list lambda-list t)
+                                   (%cons-def-info 'defmethod bits keyvect nil specializers qualifiers))
                                ,env))
        (compiler-let ((*nx-method-warning-name* '(,name ,@qualifiers ,specializers)))
@@ -2080 +2073 @@
          (eval-when (:compile-toplevel)
            (record-function-info ',(maybe-setf-function-name function-name)
-                                 ',(%cons-def-info 'defgeneric (encode-gf-lambda-list lambda-list))
+                                 ',(multiple-value-bind (bits keyvect) (encode-lambda-list lambda-list t)
+                                     (%cons-def-info 'defgeneric bits keyvect))
                                  ,env))
          (let ((,gf (%defgeneric