Oct 9, 2009, 2:46:02 PM (10 years ago)

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.

1 edited


  • trunk/source/level-1/l1-readloop.lisp

    r12550 r12940  
    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))
    432435(defun def-info.lfbits (def-info)
    451454         (and (eq (car data) :methods) (%cdr data)))))
    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)))
     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))))
     471(defun def-info-method.file (def-info-method)
     472  (cdar def-info-method))
     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)))
     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)))
    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)))
Note: See TracChangeset for help on using the changeset viewer.