Mercurial > hg > xemacs-beta

comparison lisp/bytecomp.el @ 5420:b9167d522a9a

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
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
comparison
equal deleted inserted replaced
5419:eaf01113cd42 5420:b9167d522a9a
501 . ,#'(lambda (&rest body) 501 . ,#'(lambda (&rest body)
502 (byte-compile-eval (cons 'progn body)) 502 (byte-compile-eval (cons 'progn body))
503 (cons 'progn body))) 503 (cons 'progn body)))
504 (the . 504 (the .
505 ,#'(lambda (type form) 505 ,#'(lambda (type form)
506 (if (cl-const-expr-p form)
507 (or (eval (cl-make-type-test form type))
508 (byte-compile-warn
509 "%s is not of type %s" form type)))
506 (if byte-compile-delete-errors 510 (if byte-compile-delete-errors
507 form 511 form
508 (funcall (cdr (symbol-function 'the)) type form))))) 512 (funcall (cdr (symbol-function 'the)) type form)))))
509 "The default macro-environment passed to macroexpand by the compiler. 513 "The default macro-environment passed to macroexpand by the compiler.
510 Placing a macro here will cause a macro to have different semantics when 514 Placing a macro here will cause a macro to have different semantics when
1387 (defmacro byte-compile-constant-symbol-p (symbol) 1391 (defmacro byte-compile-constant-symbol-p (symbol)
1388 `(or (keywordp ,symbol) (memq ,symbol '(nil t)))) 1392 `(or (keywordp ,symbol) (memq ,symbol '(nil t))))
1389 1393
1390 (defmacro byte-compile-constp (form) 1394 (defmacro byte-compile-constp (form)
1391 ;; Returns non-nil if FORM is a constant. 1395 ;; Returns non-nil if FORM is a constant.
1392 `(cond ((consp ,form) (eq (car ,form) 'quote)) 1396 `(cond ((consp ,form) (memq (car ,form) '(quote function)))
1393 ((symbolp ,form) (byte-compile-constant-symbol-p ,form)) 1397 ((symbolp ,form) (byte-compile-constant-symbol-p ,form))
1394 (t))) 1398 (t)))
1395 1399
1396 (defmacro byte-compile-close-variables (&rest body) 1400 (defmacro byte-compile-close-variables (&rest body)
1397 `(let 1401 `(let
2830 (setq for-effect nil)) 2834 (setq for-effect nil))
2831 ((byte-compile-normal-call form))) 2835 ((byte-compile-normal-call form)))
2832 (when for-effect 2836 (when for-effect
2833 (byte-compile-discard))) 2837 (byte-compile-discard)))
2834 2838
2839 ;; Generate the list of functions with keyword arguments like so:
2840 ;;
2841 ;; (delete-duplicates
2842 ;; (sort*
2843 ;; (loop
2844 ;; for symbol being each symbol in obarray
2845 ;; with arglist = nil
2846 ;; if (and (fboundp symbol)
2847 ;; (ignore-errors (setq symbol (indirect-function symbol)))
2848 ;; (cond
2849 ;; ((and (subrp symbol) (setq symbol (intern (subr-name symbol)))))
2850 ;; ((and (compiled-function-p symbol)
2851 ;; (setq symbol (compiled-function-annotation symbol)))))
2852 ;; (setq arglist (function-arglist symbol))
2853 ;; (setq arglist (ignore-errors (read-from-string arglist)))
2854 ;; (setq arglist (car arglist))
2855 ;; (setq arglist (position '&key arglist)))
2856 ;; collect (cons symbol arglist))
2857 ;; #'string-lessp
2858 ;; :key #'car) :test #'eq :key #'car)
2859 ;;
2860 ;; That won't include those that take advantage of cl-seq.el's
2861 ;; cl-parsing-keywords macro, but the below list does.
2862
2863 (map nil
2864 (function*
2865 (lambda ((function . nargs))
2866 ;; Document that the car of OBJECT, a symbol, describes a function
2867 ;; taking keyword arguments from the argument index described by
2868 ;; the cdr of OBJECT.
2869 (put function 'byte-compile-keyword-start nargs)))
2870 '((adjoin . 3) (assoc* . 3) (assoc-if . 3) (assoc-if-not . 3)
2871 (count . 3) (count-if . 3) (count-if-not . 3) (define-behavior . 3)
2872 (define-behavior-group . 2) (delete* . 3) (delete-duplicates . 2)
2873 (delete-if . 3) (delete-if-not . 3) (fill . 3) (find . 3) (find-if . 3)
2874 (find-if-not . 3) (internal-make-translation-table . 1)
2875 (make-Print-context . 1) (make-hash-table . 1) (make-saved-window . 1)
2876 (make-window-configuration . 1) (member* . 3)
2877 (member-if . 3) (member-if-not . 3) (merge . 5) (nsublis . 3)
2878 (nsubst . 4) (nsubst-if . 4) (nsubst-if-not . 4) (nsubstitute . 4)
2879 (nsubstitute-if . 4) (nsubstitute-if-not . 4) (override-behavior . 2)
2880 (position . 3) (position-if . 3) (position-if-not . 3) (rassoc* . 3)
2881 (rassoc-if . 3) (rassoc-if-not . 3) (reduce . 3) (remove* . 3)
2882 (remove-duplicates . 2) (remove-if . 3) (remove-if-not . 3)
2883 (replace . 3) (sort* . 3) (stable-sort . 3) (sublis . 3)
2884 (subsetp . 3) (subst . 4) (subst-if . 4) (subst-if-not . 4)
2885 (substitute . 4) (substitute-if . 4) (substitute-if-not . 4)
2886 (tree-equal . 3)))
2887
2835 (defun byte-compile-normal-call (form) 2888 (defun byte-compile-normal-call (form)
2889 (and (get (car form) 'byte-compile-keyword-start)
2890 (let ((plist (nthcdr (get (car form) 'byte-compile-keyword-start)
2891 form)))
2892 (symbol-macrolet
2893 ((not-present '#:not-present))
2894 (if (not (valid-plist-p plist))
2895 (byte-compile-warn
2896 "#'%s: ill-formed keyword argument list: %S" (car form) plist)
2897 (and
2898 (memq 'callargs byte-compile-warnings)
2899 (map nil
2900 (function*
2901 (lambda ((function . nargs))
2902 (and (setq function (plist-get plist function
2903 not-present))
2904 (not (eq function not-present))
2905 (byte-compile-constp function)
2906 (byte-compile-callargs-warn
2907 (cons (eval function)
2908 (member*
2909 nargs
2910 ;; Dummy arguments. There's no need for
2911 ;; it to be longer than even 2, now, but
2912 ;; very little harm in it.
2913 '(9 8 7 6 5 4 3 2 1)))))))
2914 '((:key . 1) (:test . 2) (:test-not . 2)
2915 (:if . 1) (:if-not . 1))))))))
2836 (if byte-compile-generate-call-tree 2916 (if byte-compile-generate-call-tree
2837 (byte-compile-annotate-call-tree form)) 2917 (byte-compile-annotate-call-tree form))
2838 (byte-compile-push-constant (car form)) 2918 (byte-compile-push-constant (car form))
2839 (mapc 'byte-compile-form (cdr form)) ; wasteful, but faster. 2919 (mapc 'byte-compile-form (cdr form)) ; wasteful, but faster.
2840 (byte-compile-out 'byte-call (length (cdr form)))) 2920 (byte-compile-out 'byte-call (length (cdr form))))