Index: /trunk/source/compiler/nx-basic.lisp =================================================================== --- /trunk/source/compiler/nx-basic.lisp (revision 12939) +++ /trunk/source/compiler/nx-basic.lisp (revision 12940) @@ -584,5 +584,5 @@ (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) @@ -591,5 +591,5 @@ callee args) - (case (car reason) + (ecase (car reason) (:toomany (destructuring-bind (provided max) @@ -606,12 +606,20 @@ (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))) + (when (and (consp badguys) (null (%cdr badguys))) (setq badguys (car badguys))) + (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") (:environment-mismatch "the definition of ~s visible in the current compilation unit.") - (:lexical-mismatch "the lexically visible definition of ~s")) + (:lexical-mismatch "the lexically visible definition of ~s") + ;; This can happen when compiling without compilation unit: + (:deferred-mismatch "~s")) callee))) @@ -620,6 +628,6 @@ (: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") @@ -633,8 +641,12 @@ (:lexical-mismatch . report-compile-time-argument-mismatch) (:ftype-mismatch . report-compile-time-argument-mismatch) + (:deferred-mismatch . report-compile-time-argument-mismatch) (:type . "Type declarations violated in ~S") (:type-conflict . "Conflicting type declarations for ~S") (: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) Index: /trunk/source/compiler/nx.lisp =================================================================== --- /trunk/source/compiler/nx.lisp (revision 12939) +++ /trunk/source/compiler/nx.lisp (revision 12940) @@ -199,4 +199,5 @@ '((: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) Index: /trunk/source/compiler/nx0.lisp =================================================================== --- /trunk/source/compiler/nx0.lisp (revision 12939) +++ /trunk/source/compiler/nx0.lisp (revision 12940) @@ -2097,9 +2097,9 @@ (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) @@ -2110,71 +2110,106 @@ (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)) + #-BOOTSTRAPPED (fboundp 'def-info-method.keyvect) + (loop for m in (def-info.methods info) + thereis (null (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) + as keyvect = (def-info-method.keyvect m) + thereis (or (null keyvect) (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" Index: /trunk/source/level-1/l1-clos-boot.lisp =================================================================== --- /trunk/source/level-1/l1-clos-boot.lisp (revision 12939) +++ /trunk/source/level-1/l1-clos-boot.lisp (revision 12940) @@ -360,5 +360,5 @@ (when aokp (setq bits (%ilogior (%ilsl $lfbits-aok-bit 1) bits))) (if return-keys? - (values bits (apply #'vector (nreverse key-list))) + (values bits (and keyp (apply #'vector (nreverse key-list)))) bits))))) Index: /trunk/source/level-1/l1-error-system.lisp =================================================================== --- /trunk/source/level-1/l1-error-system.lisp (revision 12939) +++ /trunk/source/level-1/l1-error-system.lisp (revision 12940) @@ -84,4 +84,5 @@ (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) ()) Index: /trunk/source/level-1/l1-readloop.lisp =================================================================== --- /trunk/source/level-1/l1-readloop.lisp (revision 12939) +++ /trunk/source/level-1/l1-readloop.lisp (revision 12940) @@ -421,12 +421,15 @@ -(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,8 +454,29 @@ (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 (logbitp $lfbits-aok-bit lfbits) + (and (not (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,23 +544,64 @@ :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) + (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 mkeys + (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))) Index: /trunk/source/level-1/sysutils.lisp =================================================================== --- /trunk/source/level-1/sysutils.lisp (revision 12939) +++ /trunk/source/level-1/sysutils.lisp (revision 12940) @@ -563,4 +563,5 @@ (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,12 +596,29 @@ +(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,15 +627,5 @@ ;; 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,4 +636,11 @@ :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))))) Index: /trunk/source/lib/macros.lisp =================================================================== --- /trunk/source/lib/macros.lisp (revision 12939) +++ /trunk/source/lib/macros.lisp (revision 12940) @@ -1811,11 +1811,4 @@ (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) @@ -1824,6 +1817,6 @@ (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))) @@ -2126,5 +2119,6 @@ (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