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.

File:
1 edited

Legend:

Unmodified
Added
Removed
  • trunk/source/compiler/nx0.lisp

    r12861 r12940  
    20972097
    20982098(defun innermost-lfun-bits-keyvect (def)
    2099   (declare (notinline innermost-lfun-bits-keyvect))
    21002099  (let* ((inner-def (closure-function (find-unencapsulated-definition def)))
    21012100         (bits (lfun-bits inner-def))
    21022101         (keys (lfun-keyvect inner-def)))
    21032102    (declare (fixnum bits))
     2103    #+no
    21042104    (when (and (eq (ash 1 $lfbits-gfn-bit)
    21052105                   (logand bits (logior (ash 1 $lfbits-gfn-bit)
     
    21102110    (values bits keys)))
    21112111
     2112(defun def-info-bits-keyvect (info)
     2113  (let ((bits (def-info.lfbits info)))
     2114    (when (and (eq (def-info.function-type info) 'defgeneric)
     2115               (logbitp $lfbits-keys-bit bits)
     2116               (not (logbitp $lfbits-aok-bit bits))
     2117               #-BOOTSTRAPPED (fboundp 'def-info-method.keyvect)
     2118               (loop for m in (def-info.methods info)
     2119                     thereis (null (def-info-method.keyvect m))))
     2120      ;; Some method has &aok, don't bother checking keywords.
     2121      (setq bits (logior bits (ash 1 $lfbits-aok-bit))))
     2122    (values bits (def-info.keyvect info))))
     2123
    21122124
    21132125(defun nx1-check-call-args (def arglist spread-p)
    2114   (let* ((deftype (if (functionp def)
    2115                     :global-mismatch
    2116                     (if (istruct-typep def 'afunc)
    2117                       :lexical-mismatch
    2118                       :environment-mismatch)))
    2119          (reason nil))
    2120     (multiple-value-bind (bits keyvect)
    2121                          (case deftype
    2122                            (:global-mismatch (innermost-lfun-bits-keyvect def))
    2123                            (:environment-mismatch
    2124                               (values (def-info.lfbits (cdr def)) (def-info.keyvect (cdr def))))
    2125                            (t (let* ((lambda-form (afunc-lambdaform def)))
    2126                                 (if (lambda-expression-p lambda-form)
    2127                                   (encode-lambda-list (cadr lambda-form))))))
    2128       (setq reason (nx1-check-call-bits bits keyvect arglist spread-p))
    2129       (when reason
    2130         (values deftype reason)))))
    2131 
    2132 (defun nx1-check-call-bits (bits keyvect arglist spread-p)
    2133   (when bits
    2134     (unless (typep bits 'fixnum) (error "Bug: Bad bits ~s!" bits))
    2135     (let* ((env *nx-lexical-environment*)
    2136            (nargs (length arglist))
    2137            (minargs (if spread-p (1- nargs) nargs))
    2138            (required (ldb $lfbits-numreq bits))
    2139            (max (if (logtest (logior (ash 1 $lfbits-rest-bit) (ash 1 $lfbits-restv-bit) (ash 1 $lfbits-keys-bit)) bits)
    2140                   nil
    2141                   (+ required (ldb $lfbits-numopt bits)))))
    2142       ;; If the (apparent) number of args in the call doesn't
    2143       ;; match the definition, complain.  If "spread-p" is true,
    2144       ;; we can only be sure of the case when more than the
    2145       ;; required number of args have been supplied.
    2146       (or (and (not spread-p)
    2147                (< minargs required)
    2148                `(:toofew ,minargs ,required))
    2149           (and max
    2150                (> minargs max)
    2151                (list :toomany nargs max))
    2152           (nx1-find-bogus-keywords arglist spread-p bits keyvect env)))))
    2153 
    2154 (defun nx1-find-bogus-keywords (args spread-p bits keyvect env)
    2155   (declare (fixnum bits))
    2156   (when (logbitp $lfbits-aok-bit bits)
    2157     (setq keyvect nil))                 ; only check for even length tail
    2158   (when (and (logbitp $lfbits-keys-bit bits)
    2159              (not spread-p))     ; Can't be sure, last argform may contain :allow-other-keys
    2160     (do* ((bad-keys nil)
    2161           (key-values (nthcdr (+ (ldb $lfbits-numreq bits)  (ldb $lfbits-numopt bits)) args))
    2162           (key-args key-values  (cddr key-args)))
    2163          ((null key-args)
    2164           (when (and keyvect bad-keys)
    2165             (list :unknown-keyword
    2166                   (if (cdr bad-keys) (nreverse bad-keys) (%car bad-keys))
    2167                   (coerce keyvect 'list))))
    2168       (unless (cdr key-args)
    2169         (return (list :odd-keywords key-values)))
    2170       (when keyvect
    2171         (let* ((keyword (%car key-args)))
    2172           (unless (nx-form-constant-p keyword env)
    2173             (return nil))
    2174           (setq keyword (nx-form-constant-value keyword env))
    2175           (if (eq keyword :allow-other-keys)
    2176             (setq keyvect nil)
    2177             (unless (position keyword keyvect)
    2178               (push keyword bad-keys))))))))
     2126  (multiple-value-bind (bits keyvect)
     2127      (etypecase def
     2128        (function (innermost-lfun-bits-keyvect def))
     2129        (afunc (let ((lambda-form (afunc-lambdaform def)))
     2130                 (and (lambda-expression-p lambda-form)
     2131                      (encode-lambda-list (cadr lambda-form) t))))
     2132        (cons (def-info-bits-keyvect (cdr def))))
     2133    (when bits
     2134      (multiple-value-bind (reason defer-p)
     2135          (or (nx1-check-call-bits bits arglist spread-p) ;; never deferred
     2136              (nx1-check-call-keywords def bits keyvect arglist spread-p))
     2137        (when reason
     2138          #-BOOTSTRAPPED (unless (find-class 'undefined-keyword-reference nil)
     2139                           (return-from nx1-check-call-args nil))
     2140          (values (if defer-p
     2141                    :deferred-mismatch
     2142                    (typecase def
     2143                      (function :global-mismatch)
     2144                      (afunc :lexical-mismatch)
     2145                      (t :environment-mismatch)))
     2146                  reason))))))
     2147
     2148(defun nx1-check-call-bits (bits arglist spread-p)
     2149  (let* ((nargs (length arglist))
     2150         (minargs (if spread-p (1- nargs) nargs))
     2151         (required (ldb $lfbits-numreq bits))
     2152         (max (if (logtest (logior (ash 1 $lfbits-rest-bit) (ash 1 $lfbits-restv-bit) (ash 1 $lfbits-keys-bit)) bits)
     2153                nil
     2154                (+ required (ldb $lfbits-numopt bits)))))
     2155    ;; If the (apparent) number of args in the call doesn't
     2156    ;; match the definition, complain.  If "spread-p" is true,
     2157    ;; we can only be sure of the case when more than the
     2158    ;; required number of args have been supplied.
     2159    (or (and (not spread-p)
     2160             (< minargs required)
     2161             `(:toofew ,minargs ,required))
     2162        (and max
     2163             (> minargs max)
     2164             `(:toomany ,nargs ,max)))))
     2165
     2166(defun nx1-check-call-keywords (def bits keyvect args spread-p &aux (env *nx-lexical-environment*))
     2167  ;; Ok, if generic function, bits and keyvect are for the generic function itself.
     2168  ;; Still, since all congruent, can check whether have variable numargs
     2169  (unless (and (logbitp $lfbits-keys-bit bits)
     2170               (not spread-p)) ; last argform may contain :allow-other-keys
     2171    (return-from nx1-check-call-keywords nil))
     2172  (let* ((bad-keys nil)
     2173         (key-args (nthcdr (+ (ldb $lfbits-numreq bits) (ldb $lfbits-numopt bits)) args))
     2174         (generic-p (or (generic-function-p def)
     2175                        (and (consp def)
     2176                             (eq (def-info.function-type (cdr def)) 'defgeneric)))))
     2177    (when (oddp (length key-args))
     2178      (return-from nx1-check-call-keywords (list :odd-keywords key-args)))
     2179    (when (logbitp $lfbits-aok-bit bits)
     2180      (return-from nx1-check-call-keywords nil))
     2181    (loop for key-form in key-args by #'cddr
     2182          do (unless (nx-form-constant-p key-form env) ;; could be :aok
     2183               (return-from nx1-check-call-keywords nil))
     2184          do (let ((key (nx-form-constant-value key-form env)))
     2185               (when (eq key :allow-other-keys)
     2186                 (return-from nx1-check-call-keywords nil))
     2187               (unless (or (find key keyvect)
     2188                          (and generic-p (nx1-valid-gf-keyword-p def key)))
     2189                 (push key bad-keys))))
     2190    (when bad-keys
     2191      (if generic-p
     2192        (values (list :unknown-gf-keywords bad-keys) t)
     2193        (list :unknown-keyword (if (cdr bad-keys) (nreverse bad-keys) (%car bad-keys)) keyvect)))))
     2194
     2195(defun nx1-valid-gf-keyword-p (def key)
     2196  ;; Can assume has $lfbits-keys-bit and not $lfbits-aok-bit
     2197  (if (consp def)
     2198    (let ((definfo (cdr def)))
     2199      (assert (eq (def-info.function-type definfo) 'defgeneric))
     2200      (loop for m in (def-info.methods definfo)
     2201            as keyvect = (def-info-method.keyvect m)
     2202            thereis (or (null keyvect) (find key keyvect))))
     2203    (let ((gf (find-unencapsulated-definition def)))
     2204      (or (find key (%defgeneric-keys gf))
     2205          (loop for m in (%gf-methods gf)
     2206                thereis (let* ((func (%inner-method-function m))
     2207                               (mbits (lfun-bits func)))
     2208                          (or (and (logbitp $lfbits-aok-bit mbits)
     2209                                   ;; If no &rest, then either don't use the keyword in which case
     2210                                   ;; it's good to warn; or it's used via next-method, we'll approve
     2211                                   ;; it when we get to that method.
     2212                                   (logbitp $lfbits-rest-bit mbits))
     2213                              (find key (lfun-keyvect func)))))))))
    21792214
    21802215;;; we can save some space by going through subprims to call "builtin"
Note: See TracChangeset for help on using the changeset viewer.