[Openmcl-cvs-notifications] r12940 - in /trunk/source: compiler/nx-basic.lisp compiler/nx.lisp compiler/nx0.lisp level-1/l1-clos-boot.lisp level-1/l1-error-system.lisp level-1/l1-readloop.lisp level-1/sysutils.lisp lib/macros.lisp
gz at clozure.com
gz at clozure.com
Fri Oct 9 10:46:02 EDT 2009
Author: gz
Date: Fri Oct 9 10:46:02 2009
New Revision: 12940
Log:
>From working-0711 branch: more extensive compile-time checking involving me=
thods/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 warning=
s can cite the right file.
Modified:
trunk/source/compiler/nx-basic.lisp
trunk/source/compiler/nx.lisp
trunk/source/compiler/nx0.lisp
trunk/source/level-1/l1-clos-boot.lisp
trunk/source/level-1/l1-error-system.lisp
trunk/source/level-1/l1-readloop.lisp
trunk/source/level-1/sysutils.lisp
trunk/source/lib/macros.lisp
Modified: trunk/source/compiler/nx-basic.lisp
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D
--- trunk/source/compiler/nx-basic.lisp (original)
+++ trunk/source/compiler/nx-basic.lisp Fri Oct 9 10:46:02 2009
@@ -582,14 +582,14 @@
(return-from nx-declared-inline-p (eq (cddr decl) 'inline))))
(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)
(format stream "In the ~a ~s with arguments ~:s,~% "
(if spread-p "application of" "call to")
callee
args)
- (case (car reason)
+ (ecase (car reason)
(:toomany
(destructuring-bind (provided max)
(cdr reason)
@@ -604,22 +604,30 @@
(:unknown-keyword
(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~^~#[~; an=
d~:;,~]~} 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)))
=
(defparameter *compiler-warning-formats*
'((:special . "Undeclared free variable ~S")
(:unused . "Unused lexical variable ~S")
(:ignore . "Variable ~S not ignored.")
- (:undefined-function . "Undefined function ~S") ;; (not reported if de=
fined later)
- (:undefined-type . "Undefined type ~S") ;; (not reported if de=
fined later)
+ (:undefined-function . "Undefined function ~S") ;; (deferred)
+ (:undefined-type . "Undefined type ~S") ;; (deferred)
(:unknown-type-in-declaration . "Unknown or invalid type ~S, declarati=
on ignored")
(:bad-declaration . "Unknown or invalid declaration ~S")
(:invalid-type . report-invalid-type-compiler-warning)
@@ -631,10 +639,14 @@
(:environment-mismatch . report-compile-time-argument-mismatch)
(: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. Resul=
t 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 w=
ith previous definition of ~s")
+ (:gf-keys-not-accepted . "~s does not accept keywords ~s required by t=
he generic functions")
(:result-ignored . "Function result ignored in call to ~s")
(:duplicate-definition . report-compile-time-duplicate-definition)
(:format-error . "~:{~@?~%~}")
Modified: trunk/source/compiler/nx.lisp
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D
--- trunk/source/compiler/nx.lisp (original)
+++ trunk/source/compiler/nx.lisp Fri Oct 9 10:46:02 2009
@@ -198,6 +198,7 @@
(defparameter *compiler-whining-conditions*
'((: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)
(:lexical-mismatch . invalid-arguments)
Modified: trunk/source/compiler/nx0.lisp
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D
--- trunk/source/compiler/nx0.lisp (original)
+++ trunk/source/compiler/nx0.lisp Fri Oct 9 10:46:02 2009
@@ -2096,11 +2096,11 @@
=
=
(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)
(ash 1 $lfbits-method-bit))))
@@ -2109,73 +2109,108 @@
keys nil))
(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-inf=
o.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-rest=
v-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 b=
its)) 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 functio=
n 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-numop=
t bits)) args))
+ (generic-p (or (generic-function-p def)
+ (and (consp def)
+ (eq (def-info.function-type (cdr def)) 'defge=
neric)))))
+ (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) (%ca=
r 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 =3D (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 t=
he 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"
;;; functions for us.
Modified: trunk/source/level-1/l1-clos-boot.lisp
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D
--- trunk/source/level-1/l1-clos-boot.lisp (original)
+++ trunk/source/level-1/l1-clos-boot.lisp Fri Oct 9 10:46:02 2009
@@ -356,7 +356,7 @@
(when keyp (setq bits (%ilogior (%ilsl $lfbits-keys-bit 1) bits)))
(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)))))
=
(defun pair-arg-p (thing &optional lambda-list-ok supplied-p-ok keyword-ne=
sting-ok)
Modified: trunk/source/level-1/l1-error-system.lisp
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D
--- trunk/source/level-1/l1-error-system.lisp (original)
+++ trunk/source/level-1/l1-error-system.lisp Fri Oct 9 10:46:02 2009
@@ -83,6 +83,7 @@
(define-condition invalid-type-warning (style-warning) ())
(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) ())
=
Modified: trunk/source/level-1/l1-readloop.lisp
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D
--- trunk/source/level-1/l1-readloop.lisp (original)
+++ trunk/source/level-1/l1-readloop.lisp Fri Oct 9 10:46:02 2009
@@ -420,14 +420,17 @@
lambda-expression))
=
=
-(defun %cons-def-info (type &optional lfbits keyvect lambda specializers q=
ualifiers)
+(defun %cons-def-info (type &optional lfbits keyvect data specializers qua=
lifiers)
(ecase type
(defun nil)
- (defmacro (setq lambda '(macro) lfbits nil)) ;; some code assumes lfbi=
ts=3Dnil
- (defgeneric (setq lambda (list :methods)))
- (defmethod (setq lambda (list :methods (cons qualifiers specializers))=
))
- (deftype (setq lambda '(type) lfbits (cons nil *loading-file-source-fi=
le*))))
- (vector lfbits keyvect *loading-file-source-file* lambda))
+ (defmacro (setq data '(macro) lfbits nil)) ;; some code assumes lfbits=
=3Dnil
+ (defgeneric (setq data (list :methods) lfbits (logior (ash 1 $lfbits-g=
fn-bit) lfbits)))
+ (defmethod (setq data (list :methods
+ (%cons-def-info-method lfbits keyvect qual=
ifiers 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)
(and def-info
@@ -450,10 +453,31 @@
(let ((data (svref def-info 3)))
(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-bit=
s)) old-bits))
(setf (svref new 3) (cons :methods new-methods))
new)))
=
@@ -519,25 +543,66 @@
:deftype (def-info.deftype def-info)
: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 imp=
licit 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 com=
plain 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 =3D (member (cdr new-method) old-methods :test #'equal :k=
ey #'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.keyvec=
t 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) col=
lect gk)))
+ (nx1-whine :gf-keys-not-accepted
+ `(:method ,@(cadr minfo) ,name ,(cddr minf=
o))
+ 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 ,(c=
dr 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-method=
s))))
+ (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)))
(when (and old-type new-type *compiler-warn-on-duplicate-defini=
tions*)
Modified: trunk/source/level-1/sysutils.lisp
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D
--- trunk/source/level-1/sysutils.lisp (original)
+++ trunk/source/level-1/sysutils.lisp Fri Oct 9 10:46:02 2009
@@ -560,6 +560,7 @@
(etypecase w
(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)))
=
(defun verify-deferred-type-warning (w)
@@ -592,31 +593,38 @@
nil)))
=
=
+(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-mism=
atch)))
+ (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)
(and (consp def)
(def-info.lfbits (cdr def))))
;; 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
'macro-used-before-definition
@@ -625,6 +633,13 @@
:warning-type :macro-used-before-definition
: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)))))
=
=
(defun report-deferred-warnings (&optional (file nil))
Modified: trunk/source/lib/macros.lisp
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D
--- trunk/source/lib/macros.lisp (original)
+++ trunk/source/lib/macros.lisp Fri Oct 9 10:46:02 2009
@@ -1810,21 +1810,14 @@
ll)
(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)
(parse-defmethod name args env)
`(progn
(eval-when (:compile-toplevel)
(record-function-info ',(maybe-setf-function-name name)
- ',(%cons-def-info 'defmethod (encode-gf-lam=
bda-list lambda-list) nil nil
- specializers qualifiers)
+ ',(multiple-value-bind (bits keyvect) (enco=
de-lambda-list lambda-list t)
+ (%cons-def-info 'defmethod bits keyvect=
nil specializers qualifiers))
,env))
(compiler-let ((*nx-method-warning-name* '(,name , at qualifiers ,spec=
ializers)))
(ensure-method ',name ,specializers-form
@@ -2125,7 +2118,8 @@
`(progn
(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) (en=
code-lambda-list lambda-list t)
+ (%cons-def-info 'defgeneric bits keyv=
ect))
,env))
(let ((,gf (%defgeneric
',function-name ',lambda-list ',method-combination ',=
generic-function-class =
More information about the Openmcl-cvs-notifications
mailing list