Changeset 8756


Ignore:
Timestamp:
Mar 13, 2008, 6:21:55 AM (11 years ago)
Author:
gb
Message:

Add P2-WHINE, for whining from the backend.
Add *WARN-IF-FUNCTION-RESULT-IGNORED*, a list of function names
where ignoring the result of a call to the named function may be
at least a bit suspect.
Stop ignoring generic functions in INNERMOST-LFUN-BITS-KEYVECT;
treat GFs that said &KEY as if they explicitly said &ALLOW-OTHER-KEYS
as well.
Return more (more specific) info about mismatched function calls.

File:
1 edited

Legend:

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

    r8515 r8756  
    17201720  nil)
    17211721
     1722(defun p2-whine (afunc about &rest forms)
     1723  (let* ((warning (make-condition (or (cdr (assq about *compiler-whining-conditions*)) 'compiler-warning)
     1724                                  :function-name (list (afunc-name afunc))
     1725                                  :warning-type about
     1726                                  :args (or forms (list nil)))))
     1727    (push warning (afunc-warnings afunc))
     1728    (do* ((p (afunc-parent afunc) (afunc-parent p)))
     1729         ((null p) warning)
     1730      (let* ((pname (afunc-name p)))
     1731        (push pname (compiler-warning-function-name warning))
     1732        (push warning (afunc-warnings p))))))
     1733
    17221734(defun nx1-type-intersect (form type1 type2 &optional env)
    17231735  (declare (ignore env)) ; use it when deftype records info in env.  Fix this then ...
     
    17761788      (list (%nx1-operator typed-form) type form))))
    17771789
    1778 ; Wimpy.
     1790;;; Wimpy.
    17791791(defun nx1-call-result-type (sym &optional (args nil args-p) spread-p)
    17801792  (let* ((env *nx-lexical-environment*)
     
    17921804      (nx1-whine :undefined-function sym))
    17931805    (when (and args-p (setq somedef (or lexenv-def defenv-def global-def)))
    1794       (multiple-value-bind (deftype required max minargs maxargs)
    1795                            (nx1-check-call-args somedef args spread-p)
     1806      (multiple-value-bind (deftype  reason)
     1807          (nx1-check-call-args somedef args spread-p)
    17961808        (when deftype
    1797           (nx1-whine (if (eq deftype :lexical-mismatch) :environment-mismatch deftype)
    1798                      sym required max minargs maxargs))))
     1809          (nx1-whine deftype sym reason args spread-p))))
    17991810    (nx-target-type *nx-form-type*)))
    18001811
     
    18131824
    18141825(defun innermost-lfun-bits-keyvect (def)
    1815  (declare (notinline innermost-lfun-bits-keyvect))
    1816   (let* ((gf-p (standard-generic-function-p def)))
    1817     (unless gf-p
    1818       (let ((inner-def (closure-function (find-unencapsulated-definition def))))
    1819         (values (lfun-bits inner-def)(lfun-keyvect inner-def))))))
     1826  (declare (notinline innermost-lfun-bits-keyvect))
     1827  (let* ((inner-def (closure-function (find-unencapsulated-definition def)))
     1828         (bits (lfun-bits inner-def))
     1829         (keys (lfun-keyvect inner-def)))
     1830    (declare (fixnum bits))
     1831    (when (and (eq (ash 1 $lfbits-gfn-bit)
     1832                   (logand bits (logior (ash 1 $lfbits-gfn-bit)
     1833                                        (ash 1 $lfbits-method-bit))))
     1834               (logbitp $lfbits-keys-bit bits))
     1835      (setq bits (logior (ash 1 $lfbits-aok-bit) bits)
     1836            keys nil))
     1837    (values bits keys)))
    18201838
    18211839
     
    18251843                    (if (istruct-typep def 'afunc)
    18261844                      :lexical-mismatch
    1827                       :environment-mismatch))))
     1845                      :environment-mismatch)))
     1846         (reason nil))
    18281847    (multiple-value-bind (bits keyvect)
    18291848                         (case deftype
     
    18461865          ;; we can only be sure of the case when more than the
    18471866          ;; required number of args have been supplied.
    1848           (if (or (and (not spread-p) (< minargs required))
    1849                   (and max (or (> minargs max)) (if maxargs (> maxargs max)))
    1850                   (nx1-find-bogus-keywords arglist spread-p bits keyvect))
    1851             (values deftype required max minargs maxargs)))))))
     1867          (if (or (if (and (not spread-p) (< minargs required))
     1868                    (setq reason `(:toofew ,minargs ,required)))
     1869                  (if (and max (or (> minargs max)) (if maxargs (> maxargs max)))
     1870                    (setq reason (list :toomany (if (> minargs max) minargs maxargs) max)))
     1871                  (setq reason (nx1-find-bogus-keywords arglist spread-p bits keyvect)))
     1872            (values deftype reason)))))))
    18521873
    18531874(defun nx1-find-bogus-keywords (args spread-p bits keyvect)
     
    18571878  (when (and (logbitp $lfbits-keys-bit bits)
    18581879             (not spread-p))     ; Can't be sure, last argform may contain :allow-other-keys
    1859     (do* ((key-args (nthcdr (+ (ldb $lfbits-numreq bits)  (ldb $lfbits-numopt bits)) args) (cddr key-args)))
     1880    (do* ((key-values (nthcdr (+ (ldb $lfbits-numreq bits)  (ldb $lfbits-numopt bits)) args))
     1881          (key-args key-values  (cddr key-args)))
    18601882         ((null key-args))
    18611883      (if (null (cdr key-args))
    1862         (return t)
     1884        (return (list :odd-keywords key-values))
    18631885        (when keyvect
    18641886          (let* ((keyword (%car key-args)))
     
    18661888              (return nil))
    18671889            (unless (eq keyword :allow-other-keys)
    1868               (unless (position (nx-unquote keyword) keyvect)
    1869                 (return t)))))))))
     1890              (unless (position (nx-unquote keyword) keyvect)               
     1891                (return (list :unknown-keyword
     1892                              (nx-unquote keyword)
     1893                              (coerce keyvect 'list)))))))))))
    18701894
    18711895;;; we can save some space by going through subprims to call "builtin"
     
    18891913                     spread-p)))))
    18901914 
    1891 ; If "sym" is an expression (not a symbol which names a function), the caller has already
    1892 ; alphatized it.
     1915;;; If "sym" is an expression (not a symbol which names a function),
     1916;;; the caller has already alphatized it.
    18931917(defun nx1-call (sym args &optional spread-p global-only)
    18941918  (nx1-verify-length args 0 nil)
    18951919  (let ((args-in-regs (if spread-p 1 (backend-num-arg-regs *target-backend*))))
    18961920    (if (nx-self-call-p sym global-only)
    1897       ; Should check for downward functions here as well.
    1898       (multiple-value-bind (deftype required max minargs maxargs)
     1921      ;; Should check for downward functions here as well.
     1922      (multiple-value-bind (deftype reason)
    18991923                           (nx1-check-call-args *nx-current-function* args spread-p)
    19001924        (when deftype
    1901           (nx1-whine (if (eq deftype :lexical-mismatch) :environment-mismatch deftype)
    1902                      sym required max minargs maxargs))
     1925          (nx1-whine deftype sym reason args spread-p))
    19031926        (make-acode (%nx1-operator self-call) (nx1-arglist args args-in-regs) spread-p))
    19041927      (multiple-value-bind (lambda-form containing-env token) (nx-inline-expansion sym *nx-lexical-environment* global-only)
     
    23892412  (or *nx-cur-func-name* "an anonymous function"))
    23902413
     2414(defparameter *warn-if-function-result-ignored*
     2415  '(sort stable-sort delete delete-if delete-if-not remf nreverse
     2416    nunion nset-intersection)
     2417  "Names of functions whos result(s) should ordinarily be used, because of their side-effects or lack of them.")
Note: See TracChangeset for help on using the changeset viewer.