]> code.delx.au - gnu-emacs/blobdiff - lisp/emacs-lisp/byte-opt.el
Merge from origin/emacs-25
[gnu-emacs] / lisp / emacs-lisp / byte-opt.el
index 149c472319954318acaa145406ba67a9ced0e08a..dbaf2bc6f6ab181d5e9f3b46af510ecdf49b2d00 100644 (file)
@@ -1,6 +1,6 @@
 ;;; byte-opt.el --- the optimization passes of the emacs-lisp byte compiler -*- lexical-binding: t -*-
 
-;; Copyright (C) 1991, 1994, 2000-2015 Free Software Foundation, Inc.
+;; Copyright (C) 1991, 1994, 2000-2016 Free Software Foundation, Inc.
 
 ;; Author: Jamie Zawinski <jwz@lucid.com>
 ;;     Hallvard Furuseth <hbf@ulrik.uio.no>
   ;; (if (aref byte-code-vector 0)
   ;;     (error "The old version of the disassembler is loaded.  Reload new-bytecomp as well"))
   (byte-compile-log-1
-   (apply 'format format
+   (apply #'format-message format
      (let (c a)
        (mapcar (lambda (arg)
                  (if (not (consp arg))
               (format "Inlining closure %S failed" name))
              form))))
 
-      (t ;; Give up on inlining.
+      (_ ;; Give up on inlining.
        form))))
 
 ;; ((lambda ...) ...)
   ;; doesn't matter here, because function's behavior is underspecified so it
   ;; can safely be turned into a `let', even though the reverse is not true.
   (or name (setq name "anonymous lambda"))
-  (let ((lambda (car form))
-       (values (cdr form)))
-    (let ((arglist (nth 1 lambda))
-         (body (cdr (cdr lambda)))
-         optionalp restp
-         bindings)
-      (if (and (stringp (car body)) (cdr body))
-         (setq body (cdr body)))
-      (if (and (consp (car body)) (eq 'interactive (car (car body))))
-         (setq body (cdr body)))
-      ;; FIXME: The checks below do not belong in an optimization phase.
-      (while arglist
-       (cond ((eq (car arglist) '&optional)
-              ;; ok, I'll let this slide because funcall_lambda() does...
-              ;; (if optionalp (error "multiple &optional keywords in %s" name))
-              (if restp (error "&optional found after &rest in %s" name))
-              (if (null (cdr arglist))
-                  (error "nothing after &optional in %s" name))
-              (setq optionalp t))
-             ((eq (car arglist) '&rest)
-              ;; ...but it is by no stretch of the imagination a reasonable
-              ;; thing that funcall_lambda() allows (&rest x y) and
-              ;; (&rest x &optional y) in arglists.
-              (if (null (cdr arglist))
-                  (error "nothing after &rest in %s" name))
-              (if (cdr (cdr arglist))
-                  (error "multiple vars after &rest in %s" name))
-              (setq restp t))
-             (restp
-              (setq bindings (cons (list (car arglist)
-                                         (and values (cons 'list values)))
-                                   bindings)
-                    values nil))
-             ((and (not optionalp) (null values))
-              (byte-compile-warn "attempt to open-code `%s' with too few arguments" name)
-              (setq arglist nil values 'too-few))
-             (t
-              (setq bindings (cons (list (car arglist) (car values))
-                                   bindings)
-                    values (cdr values))))
-       (setq arglist (cdr arglist)))
-      (if values
-         (progn
-           (or (eq values 'too-few)
-               (byte-compile-warn
-                "attempt to open-code `%s' with too many arguments" name))
-           form)
-
-       ;; The following leads to infinite recursion when loading a
-       ;; file containing `(defsubst f () (f))', and then trying to
-       ;; byte-compile that file.
-       ;(setq body (mapcar 'byte-optimize-form body)))
-
-       (let ((newform
-              (if bindings
-                  (cons 'let (cons (nreverse bindings) body))
-                (cons 'progn body))))
-         (byte-compile-log "  %s\t==>\t%s" form newform)
-         newform)))))
+  (let* ((lambda (car form))
+         (values (cdr form))
+         (arglist (nth 1 lambda))
+         (body (cdr (cdr lambda)))
+         optionalp restp
+         bindings)
+    (if (and (stringp (car body)) (cdr body))
+        (setq body (cdr body)))
+    (if (and (consp (car body)) (eq 'interactive (car (car body))))
+        (setq body (cdr body)))
+    ;; FIXME: The checks below do not belong in an optimization phase.
+    (while arglist
+      (cond ((eq (car arglist) '&optional)
+             ;; ok, I'll let this slide because funcall_lambda() does...
+             ;; (if optionalp (error "multiple &optional keywords in %s" name))
+             (if restp (error "&optional found after &rest in %s" name))
+             (if (null (cdr arglist))
+                 (error "nothing after &optional in %s" name))
+             (setq optionalp t))
+            ((eq (car arglist) '&rest)
+             ;; ...but it is by no stretch of the imagination a reasonable
+             ;; thing that funcall_lambda() allows (&rest x y) and
+             ;; (&rest x &optional y) in arglists.
+             (if (null (cdr arglist))
+                 (error "nothing after &rest in %s" name))
+             (if (cdr (cdr arglist))
+                 (error "multiple vars after &rest in %s" name))
+             (setq restp t))
+            (restp
+             (setq bindings (cons (list (car arglist)
+                                        (and values (cons 'list values)))
+                                  bindings)
+                   values nil))
+            ((and (not optionalp) (null values))
+             (byte-compile-warn "attempt to open-code `%s' with too few arguments" name)
+             (setq arglist nil values 'too-few))
+            (t
+             (setq bindings (cons (list (car arglist) (car values))
+                                  bindings)
+                   values (cdr values))))
+      (setq arglist (cdr arglist)))
+    (if values
+        (progn
+          (or (eq values 'too-few)
+              (byte-compile-warn
+               "attempt to open-code `%s' with too many arguments" name))
+          form)
+
+                                       ;; The following leads to infinite recursion when loading a
+                                       ;; file containing `(defsubst f () (f))', and then trying to
+                                       ;; byte-compile that file.
+                       ;(setq body (mapcar 'byte-optimize-form body)))
+
+      (let ((newform
+             (if bindings
+                 (cons 'let (cons (nreverse bindings) body))
+               (cons 'progn body))))
+        (byte-compile-log "  %s\t==>\t%s" form newform)
+        newform))))
 
 \f
 ;;; implementing source-level optimizers
           (and (nth 1 form)
                (not for-effect)
                form))
-         ((eq 'lambda (car-safe fn))
+         ((eq (car-safe fn) 'lambda)
           (let ((newform (byte-compile-unfold-lambda form)))
             (if (eq newform form)
                 ;; Some error occurred, avoid infinite recursion
                 form
               (byte-optimize-form-code-walker newform for-effect))))
+         ((eq (car-safe fn) 'closure) form)
          ((memq fn '(let let*))
           ;; recursively enter the optimizer for the bindings and body
           ;; of a let or let*.  This for depth-firstness: forms that
               (cons fn args)))))))
 
 (defun byte-optimize-all-constp (list)
-  "Non-nil if all elements of LIST satisfy `macroexp-const-p"
+  "Non-nil if all elements of LIST satisfy `macroexp-const-p'."
   (let ((constant t))
     (while (and list constant)
       (unless (macroexp-const-p (car list))
         radians-to-degrees rassq rassoc read-from-string regexp-quote
         region-beginning region-end reverse round
         sin sqrt string string< string= string-equal string-lessp string-to-char
-        string-to-int string-to-number substring sxhash symbol-function
-        symbol-name symbol-plist symbol-value string-make-unibyte
+        string-to-int string-to-number substring
+        sxhash sxhash-equal sxhash-eq sxhash-eql
+        symbol-function symbol-name symbol-plist symbol-value string-make-unibyte
         string-make-multibyte string-as-multibyte string-as-unibyte
         string-to-multibyte
         tan truncate
         window-left-child window-left-column window-margins window-minibuffer-p
         window-next-buffers window-next-sibling window-new-normal
         window-new-total window-normal-size window-parameter window-parameters
-        window-parent window-pixel-edges window-point window-prev-buffers 
+        window-parent window-pixel-edges window-point window-prev-buffers
         window-prev-sibling window-redisplay-end-trigger window-scroll-bars
         window-start window-text-height window-top-child window-top-line
         window-total-height window-total-width window-use-time window-vscroll