Mercurial > hg > xemacs-beta
diff lisp/bytecomp.el @ 5420:b9167d522a9a
Rebase with 21.5 trunk.
author | Mats Lidell <matsl@xemacs.org> |
---|---|
date | Thu, 28 Oct 2010 23:53:24 +0200 |
parents | 308d34e9f07d bbff29a01820 |
children | 002cb5224e4f |
line wrap: on
line diff
--- a/lisp/bytecomp.el Wed Oct 27 23:36:14 2010 +0200 +++ b/lisp/bytecomp.el Thu Oct 28 23:53:24 2010 +0200 @@ -503,6 +503,10 @@ (cons 'progn body))) (the . ,#'(lambda (type form) + (if (cl-const-expr-p form) + (or (eval (cl-make-type-test form type)) + (byte-compile-warn + "%s is not of type %s" form type))) (if byte-compile-delete-errors form (funcall (cdr (symbol-function 'the)) type form))))) @@ -1389,7 +1393,7 @@ (defmacro byte-compile-constp (form) ;; Returns non-nil if FORM is a constant. - `(cond ((consp ,form) (eq (car ,form) 'quote)) + `(cond ((consp ,form) (memq (car ,form) '(quote function))) ((symbolp ,form) (byte-compile-constant-symbol-p ,form)) (t))) @@ -2832,7 +2836,83 @@ (when for-effect (byte-compile-discard))) +;; Generate the list of functions with keyword arguments like so: +;; +;; (delete-duplicates +;; (sort* +;; (loop +;; for symbol being each symbol in obarray +;; with arglist = nil +;; if (and (fboundp symbol) +;; (ignore-errors (setq symbol (indirect-function symbol))) +;; (cond +;; ((and (subrp symbol) (setq symbol (intern (subr-name symbol))))) +;; ((and (compiled-function-p symbol) +;; (setq symbol (compiled-function-annotation symbol))))) +;; (setq arglist (function-arglist symbol)) +;; (setq arglist (ignore-errors (read-from-string arglist))) +;; (setq arglist (car arglist)) +;; (setq arglist (position '&key arglist))) +;; collect (cons symbol arglist)) +;; #'string-lessp +;; :key #'car) :test #'eq :key #'car) +;; +;; That won't include those that take advantage of cl-seq.el's +;; cl-parsing-keywords macro, but the below list does. + +(map nil + (function* + (lambda ((function . nargs)) + ;; Document that the car of OBJECT, a symbol, describes a function + ;; taking keyword arguments from the argument index described by + ;; the cdr of OBJECT. + (put function 'byte-compile-keyword-start nargs))) + '((adjoin . 3) (assoc* . 3) (assoc-if . 3) (assoc-if-not . 3) + (count . 3) (count-if . 3) (count-if-not . 3) (define-behavior . 3) + (define-behavior-group . 2) (delete* . 3) (delete-duplicates . 2) + (delete-if . 3) (delete-if-not . 3) (fill . 3) (find . 3) (find-if . 3) + (find-if-not . 3) (internal-make-translation-table . 1) + (make-Print-context . 1) (make-hash-table . 1) (make-saved-window . 1) + (make-window-configuration . 1) (member* . 3) + (member-if . 3) (member-if-not . 3) (merge . 5) (nsublis . 3) + (nsubst . 4) (nsubst-if . 4) (nsubst-if-not . 4) (nsubstitute . 4) + (nsubstitute-if . 4) (nsubstitute-if-not . 4) (override-behavior . 2) + (position . 3) (position-if . 3) (position-if-not . 3) (rassoc* . 3) + (rassoc-if . 3) (rassoc-if-not . 3) (reduce . 3) (remove* . 3) + (remove-duplicates . 2) (remove-if . 3) (remove-if-not . 3) + (replace . 3) (sort* . 3) (stable-sort . 3) (sublis . 3) + (subsetp . 3) (subst . 4) (subst-if . 4) (subst-if-not . 4) + (substitute . 4) (substitute-if . 4) (substitute-if-not . 4) + (tree-equal . 3))) + (defun byte-compile-normal-call (form) + (and (get (car form) 'byte-compile-keyword-start) + (let ((plist (nthcdr (get (car form) 'byte-compile-keyword-start) + form))) + (symbol-macrolet + ((not-present '#:not-present)) + (if (not (valid-plist-p plist)) + (byte-compile-warn + "#'%s: ill-formed keyword argument list: %S" (car form) plist) + (and + (memq 'callargs byte-compile-warnings) + (map nil + (function* + (lambda ((function . nargs)) + (and (setq function (plist-get plist function + not-present)) + (not (eq function not-present)) + (byte-compile-constp function) + (byte-compile-callargs-warn + (cons (eval function) + (member* + nargs + ;; Dummy arguments. There's no need for + ;; it to be longer than even 2, now, but + ;; very little harm in it. + '(9 8 7 6 5 4 3 2 1))))))) + '((:key . 1) (:test . 2) (:test-not . 2) + (:if . 1) (:if-not . 1)))))))) (if byte-compile-generate-call-tree (byte-compile-annotate-call-tree form)) (byte-compile-push-constant (car form))