Changeset 12940 for trunk/source/level-1


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/level-1
Files:
4 edited

Legend:

Unmodified
Added
Removed
  • 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
Note: See TracChangeset for help on using the changeset viewer.