Changeset 8767

Mar 13, 2008, 10:36:53 AM (14 years ago)

Call argument checking returns more info on failure, so warnings can
offer more detail.

1 edited


  • branches/working-0711/ccl/compiler/nx0.lisp

    r8708 r8767  
    19621962      (nx1-whine :undefined-function sym))
    19631963    (when (and args-p (setq somedef (or lexenv-def defenv-def global-def)))
    1964       (multiple-value-bind (deftype required max minargs maxargs)
    1965                            (nx1-check-call-args somedef args spread-p)
     1964      (multiple-value-bind (deftype reason)
     1965          (nx1-check-call-args somedef args spread-p)
    19661966        (when deftype
    1967           (nx1-whine (if (eq deftype :lexical-mismatch) :environment-mismatch deftype)
    1968                      sym required max minargs maxargs))))
     1967          (nx1-whine deftype sym reason args spread-p))))
    19691968    (nx-target-type *nx-form-type*)))
    20022001                    (if (istruct-typep def 'afunc)
    20032002                      :lexical-mismatch
    2004                       :environment-mismatch))))
     2003                      :environment-mismatch)))
     2004         (reason nil))
    20052005    (multiple-value-bind (bits keyvect)
    20062006                         (case deftype
    20232023          ;; we can only be sure of the case when more than the
    20242024          ;; required number of args have been supplied.
    2025           (if (or (and (not spread-p) (< minargs required))
    2026                   (and max (or (> minargs max)) (if maxargs (> maxargs max)))
    2027                   (nx1-find-bogus-keywords arglist spread-p bits keyvect))
    2028             (values deftype required max minargs maxargs)))))))
     2025          (if (or (if (and (not spread-p) (< minargs required))
     2026                    (setq reason `(:toofew ,minargs ,required)))
     2027                  (if (and max (or (> minargs max)) (if maxargs (> maxargs max)))
     2028                    (setq reason (list :toomany (if (> minargs max) minargs maxargs) max)))
     2029                  (setq reason (nx1-find-bogus-keywords arglist spread-p bits keyvect)))
     2030            (values deftype reason)))))))
    20302032(defun nx1-find-bogus-keywords (args spread-p bits keyvect)
    20342036  (when (and (logbitp $lfbits-keys-bit bits)
    20352037             (not spread-p))     ; Can't be sure, last argform may contain :allow-other-keys
    2036     (do* ((key-args (nthcdr (+ (ldb $lfbits-numreq bits)  (ldb $lfbits-numopt bits)) args) (cddr key-args)))
     2038    (do* ((key-values (nthcdr (+ (ldb $lfbits-numreq bits)  (ldb $lfbits-numopt bits)) args))
     2039          (key-args key-values  (cddr key-args)))
    20372040         ((null key-args))
    20382041      (if (null (cdr key-args))
    2039         (return t)
     2042        (return (list :odd-keywords key-values))
    20402043        (when keyvect
    20412044          (let* ((keyword (%car key-args)))
    20432046              (return nil))
    20442047            (unless (eq keyword :allow-other-keys)
    2045               (unless (position (nx-unquote keyword) keyvect)
    2046                 (return t)))))))))
     2048              (unless (position (nx-unquote keyword) keyvect)               
     2049                (return (list :unknown-keyword
     2050                              (nx-unquote keyword)
     2051                              (coerce keyvect 'list)))))))))))
    20482053;;; we can save some space by going through subprims to call "builtin"
    20662071                     spread-p)))))
    2068 ; If "sym" is an expression (not a symbol which names a function), the caller has already
    2069 ; alphatized it.
     2073;;; If "sym" is an expression (not a symbol which names a function),
     2074;;; the caller has already alphatized it.
    20702075(defun nx1-call (sym args &optional spread-p global-only)
    20712076  (nx1-verify-length args 0 nil)
    20722077  (let ((args-in-regs (if spread-p 1 (backend-num-arg-regs *target-backend*))))
    20732078    (if (nx-self-call-p sym global-only)
    2074       ; Should check for downward functions here as well.
    2075       (multiple-value-bind (deftype required max minargs maxargs)
    2076                            (nx1-check-call-args *nx-current-function* args spread-p)
     2079      ;; Should check for downward functions here as well.
     2080      (multiple-value-bind (deftype reason)
     2081          (nx1-check-call-args *nx-current-function* args spread-p)
    20772082        (when deftype
    2078           (nx1-whine (if (eq deftype :lexical-mismatch) :environment-mismatch deftype)
    2079                      sym required max minargs maxargs))
     2083          (nx1-whine deftype sym reason args spread-p))
    20802084        (make-acode (%nx1-operator self-call) (nx1-arglist args args-in-regs) spread-p))
    20812085      (multiple-value-bind (lambda-form containing-env token) (nx-inline-expansion sym *nx-lexical-environment* global-only)
Note: See TracChangeset for help on using the changeset viewer.