LCOV - code coverage report
Current view: top level - lisp/emacs-lisp - bytecomp.el (source / functions) Hit Total Coverage
Test: tramp-tests-after.info Lines: 766 2500 30.6 %
Date: 2017-08-30 10:12:24 Functions: 84 200 42.0 %

          Line data    Source code
       1             : ;;; bytecomp.el --- compilation of Lisp code into byte code -*- lexical-binding: t -*-
       2             : 
       3             : ;; Copyright (C) 1985-1987, 1992, 1994, 1998, 2000-2017 Free Software
       4             : ;; Foundation, Inc.
       5             : 
       6             : ;; Author: Jamie Zawinski <jwz@lucid.com>
       7             : ;;      Hallvard Furuseth <hbf@ulrik.uio.no>
       8             : ;; Maintainer: emacs-devel@gnu.org
       9             : ;; Keywords: lisp
      10             : ;; Package: emacs
      11             : 
      12             : ;; This file is part of GNU Emacs.
      13             : 
      14             : ;; GNU Emacs is free software: you can redistribute it and/or modify
      15             : ;; it under the terms of the GNU General Public License as published by
      16             : ;; the Free Software Foundation, either version 3 of the License, or
      17             : ;; (at your option) any later version.
      18             : 
      19             : ;; GNU Emacs is distributed in the hope that it will be useful,
      20             : ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
      21             : ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
      22             : ;; GNU General Public License for more details.
      23             : 
      24             : ;; You should have received a copy of the GNU General Public License
      25             : ;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
      26             : 
      27             : ;;; Commentary:
      28             : 
      29             : ;; The Emacs Lisp byte compiler.  This crunches lisp source into a sort
      30             : ;; of p-code (`lapcode') which takes up less space and can be interpreted
      31             : ;; faster.  [`LAP' == `Lisp Assembly Program'.]
      32             : ;; The user entry points are byte-compile-file and byte-recompile-directory.
      33             : 
      34             : ;;; Todo:
      35             : 
      36             : ;; - Turn "not bound at runtime" functions into autoloads.
      37             : 
      38             : ;;; Code:
      39             : 
      40             : ;; ========================================================================
      41             : ;; Entry points:
      42             : ;;      byte-recompile-directory, byte-compile-file,
      43             : ;;      byte-recompile-file,
      44             : ;;     batch-byte-compile, batch-byte-recompile-directory,
      45             : ;;      byte-compile, compile-defun,
      46             : ;;      display-call-tree
      47             : ;; (byte-compile-buffer and byte-compile-and-load-file were turned off
      48             : ;;  because they are not terribly useful and get in the way of completion.)
      49             : 
      50             : ;; This version of the byte compiler has the following improvements:
      51             : ;;  + optimization of compiled code:
      52             : ;;    - removal of unreachable code;
      53             : ;;    - removal of calls to side-effectless functions whose return-value
      54             : ;;      is unused;
      55             : ;;    - compile-time evaluation of safe constant forms, such as (consp nil)
      56             : ;;      and (ash 1 6);
      57             : ;;    - open-coding of literal lambdas;
      58             : ;;    - peephole optimization of emitted code;
      59             : ;;    - trivial functions are left uncompiled for speed.
      60             : ;;  + support for inline functions;
      61             : ;;  + compile-time evaluation of arbitrary expressions;
      62             : ;;  + compile-time warning messages for:
      63             : ;;    - functions being redefined with incompatible arglists;
      64             : ;;    - functions being redefined as macros, or vice-versa;
      65             : ;;    - functions or macros defined multiple times in the same file;
      66             : ;;    - functions being called with the incorrect number of arguments;
      67             : ;;    - functions being called which are not defined globally, in the
      68             : ;;      file, or as autoloads;
      69             : ;;    - assignment and reference of undeclared free variables;
      70             : ;;    - various syntax errors;
      71             : ;;  + correct compilation of nested defuns, defmacros, defvars and defsubsts;
      72             : ;;  + correct compilation of top-level uses of macros;
      73             : ;;  + the ability to generate a histogram of functions called.
      74             : 
      75             : ;; User customization variables: M-x customize-group bytecomp
      76             : 
      77             : ;; New Features:
      78             : ;;
      79             : ;;  o   The form `defsubst' is just like `defun', except that the function
      80             : ;;      generated will be open-coded in compiled code which uses it.  This
      81             : ;;      means that no function call will be generated, it will simply be
      82             : ;;      spliced in.  Lisp functions calls are very slow, so this can be a
      83             : ;;      big win.
      84             : ;;
      85             : ;;      You can generally accomplish the same thing with `defmacro', but in
      86             : ;;      that case, the defined procedure can't be used as an argument to
      87             : ;;      mapcar, etc.
      88             : ;;
      89             : ;;  o   You can also open-code one particular call to a function without
      90             : ;;      open-coding all calls.  Use the 'inline' form to do this, like so:
      91             : ;;
      92             : ;;              (inline (foo 1 2 3))    ;; `foo' will be open-coded
      93             : ;;      or...
      94             : ;;              (inline                 ;;  `foo' and `baz' will be
      95             : ;;               (foo 1 2 3 (bar 5))    ;; open-coded, but `bar' will not.
      96             : ;;               (baz 0))
      97             : ;;
      98             : ;;  o   It is possible to open-code a function in the same file it is defined
      99             : ;;      in without having to load that file before compiling it.  The
     100             : ;;      byte-compiler has been modified to remember function definitions in
     101             : ;;      the compilation environment in the same way that it remembers macro
     102             : ;;      definitions.
     103             : ;;
     104             : ;;  o  Forms like ((lambda ...) ...) are open-coded.
     105             : ;;
     106             : ;;  o  The form `eval-when-compile' is like progn, except that the body
     107             : ;;     is evaluated at compile-time.  When it appears at top-level, this
     108             : ;;     is analogous to the Common Lisp idiom (eval-when (compile) ...).
     109             : ;;     When it does not appear at top-level, it is similar to the
     110             : ;;     Common Lisp #. reader macro (but not in interpreted code).
     111             : ;;
     112             : ;;  o  The form `eval-and-compile' is similar to eval-when-compile, but
     113             : ;;      the whole form is evalled both at compile-time and at run-time.
     114             : ;;
     115             : ;;  o  The command compile-defun is analogous to eval-defun.
     116             : ;;
     117             : ;;  o  If you run byte-compile-file on a filename which is visited in a
     118             : ;;     buffer, and that buffer is modified, you are asked whether you want
     119             : ;;     to save the buffer before compiling.
     120             : ;;
     121             : ;;  o  byte-compiled files now start with the string `;ELC'.
     122             : ;;     Some versions of `file' can be customized to recognize that.
     123             : 
     124             : (require 'backquote)
     125             : (require 'macroexp)
     126             : (require 'cconv)
     127             : (require 'cl-lib)
     128             : 
     129             : ;; During bootstrap, cl-loaddefs.el is not created yet, so loading cl-lib
     130             : ;; doesn't setup autoloads for things like cl-every, which is why we have to
     131             : ;; require cl-extra as well (bug#18804).
     132             : (or (fboundp 'cl-every)
     133             :     (require 'cl-extra))
     134             : 
     135             : (or (fboundp 'defsubst)
     136             :     ;; This really ought to be loaded already!
     137             :     (load "byte-run"))
     138             : 
     139             : ;; The feature of compiling in a specific target Emacs version
     140             : ;; has been turned off because compile time options are a bad idea.
     141             : (defgroup bytecomp nil
     142             :   "Emacs Lisp byte-compiler."
     143             :   :group 'lisp)
     144             : 
     145             : (defcustom emacs-lisp-file-regexp "\\.el\\'"
     146             :   "Regexp which matches Emacs Lisp source files.
     147             : If you change this, you might want to set `byte-compile-dest-file-function'."
     148             :   :group 'bytecomp
     149             :   :type 'regexp)
     150             : 
     151             : (defcustom byte-compile-dest-file-function nil
     152             :   "Function for the function `byte-compile-dest-file' to call.
     153             : It should take one argument, the name of an Emacs Lisp source
     154             : file name, and return the name of the compiled file."
     155             :   :group 'bytecomp
     156             :   :type '(choice (const nil) function)
     157             :   :version "23.2")
     158             : 
     159             : ;; This enables file name handlers such as jka-compr
     160             : ;; to remove parts of the file name that should not be copied
     161             : ;; through to the output file name.
     162             : (defun byte-compiler-base-file-name (filename)
     163           0 :   (let ((handler (find-file-name-handler filename
     164           0 :                                          'byte-compiler-base-file-name)))
     165           0 :     (if handler
     166           0 :         (funcall handler 'byte-compiler-base-file-name filename)
     167           0 :       filename)))
     168             : 
     169             : (defun byte-compile-dest-file (filename)
     170             :   "Convert an Emacs Lisp source file name to a compiled file name.
     171             : If `byte-compile-dest-file-function' is non-nil, uses that
     172             : function to do the work.  Otherwise, if FILENAME matches
     173             : `emacs-lisp-file-regexp' (by default, files with the extension `.el'),
     174             : adds `c' to it; otherwise adds `.elc'."
     175           0 :   (if byte-compile-dest-file-function
     176           0 :       (funcall byte-compile-dest-file-function filename)
     177           0 :     (setq filename (file-name-sans-versions
     178           0 :                     (byte-compiler-base-file-name filename)))
     179           0 :     (cond ((string-match emacs-lisp-file-regexp filename)
     180           0 :            (concat (substring filename 0 (match-beginning 0)) ".elc"))
     181           0 :           (t (concat filename ".elc")))))
     182             : 
     183             : ;; This can be the 'byte-compile property of any symbol.
     184             : (autoload 'byte-compile-inline-expand "byte-opt")
     185             : 
     186             : ;; This is the entry point to the lapcode optimizer pass1.
     187             : (autoload 'byte-optimize-form "byte-opt")
     188             : ;; This is the entry point to the lapcode optimizer pass2.
     189             : (autoload 'byte-optimize-lapcode "byte-opt")
     190             : (autoload 'byte-compile-unfold-lambda "byte-opt")
     191             : 
     192             : ;; This is the entry point to the decompiler, which is used by the
     193             : ;; disassembler.  The disassembler just requires 'byte-compile, but
     194             : ;; that doesn't define this function, so this seems to be a reasonable
     195             : ;; thing to do.
     196             : (autoload 'byte-decompile-bytecode "byte-opt")
     197             : 
     198             : (defcustom byte-compile-verbose
     199             :   (and (not noninteractive) (> baud-rate search-slow-speed))
     200             :   "Non-nil means print messages describing progress of byte-compiler."
     201             :   :group 'bytecomp
     202             :   :type 'boolean)
     203             : 
     204             : (defcustom byte-optimize t
     205             :   "Enable optimization in the byte compiler.
     206             : Possible values are:
     207             :   nil      - no optimization
     208             :   t        - all optimizations
     209             :   `source' - source-level optimizations only
     210             :   `byte'   - code-level optimizations only"
     211             :   :group 'bytecomp
     212             :   :type '(choice (const :tag "none" nil)
     213             :                  (const :tag "all" t)
     214             :                  (const :tag "source-level" source)
     215             :                  (const :tag "byte-level" byte)))
     216             : 
     217             : (defcustom byte-compile-delete-errors nil
     218             :   "If non-nil, the optimizer may delete forms that may signal an error.
     219             : This includes variable references and calls to functions such as `car'."
     220             :   :group 'bytecomp
     221             :   :type 'boolean)
     222             : 
     223             : (defcustom byte-compile-cond-use-jump-table t
     224             :   "Compile `cond' clauses to a jump table implementation (using a hash-table)."
     225             :   :group 'bytecomp
     226             :   :type 'boolean)
     227             : 
     228             : (defvar byte-compile-dynamic nil
     229             :   "If non-nil, compile function bodies so they load lazily.
     230             : They are hidden in comments in the compiled file,
     231             : and each one is brought into core when the
     232             : function is called.
     233             : 
     234             : To enable this option, make it a file-local variable
     235             : in the source file you want it to apply to.
     236             : For example, add  -*-byte-compile-dynamic: t;-*- on the first line.
     237             : 
     238             : When this option is true, if you load the compiled file and then move it,
     239             : the functions you loaded will not be able to run.")
     240             : ;;;###autoload(put 'byte-compile-dynamic 'safe-local-variable 'booleanp)
     241             : 
     242             : (defvar byte-compile-disable-print-circle nil
     243             :   "If non-nil, disable `print-circle' on printing a byte-compiled code.")
     244             : (make-obsolete-variable 'byte-compile-disable-print-circle nil "24.1")
     245             : ;;;###autoload(put 'byte-compile-disable-print-circle 'safe-local-variable 'booleanp)
     246             : 
     247             : (defcustom byte-compile-dynamic-docstrings t
     248             :   "If non-nil, compile doc strings for lazy access.
     249             : We bury the doc strings of functions and variables inside comments in
     250             : the file, and bring them into core only when they are actually needed.
     251             : 
     252             : When this option is true, if you load the compiled file and then move it,
     253             : you won't be able to find the documentation of anything in that file.
     254             : 
     255             : To disable this option for a certain file, make it a file-local variable
     256             : in the source file.  For example, add this to the first line:
     257             :   -*-byte-compile-dynamic-docstrings:nil;-*-
     258             : You can also set the variable globally.
     259             : 
     260             : This option is enabled by default because it reduces Emacs memory usage."
     261             :   :group 'bytecomp
     262             :   :type 'boolean)
     263             : ;;;###autoload(put 'byte-compile-dynamic-docstrings 'safe-local-variable 'booleanp)
     264             : 
     265             : (defconst byte-compile-log-buffer "*Compile-Log*"
     266             :   "Name of the byte-compiler's log buffer.")
     267             : 
     268             : (defcustom byte-optimize-log nil
     269             :   "If non-nil, the byte-compiler will log its optimizations.
     270             : If this is `source', then only source-level optimizations will be logged.
     271             : If it is `byte', then only byte-level optimizations will be logged.
     272             : The information is logged to `byte-compile-log-buffer'."
     273             :   :group 'bytecomp
     274             :   :type '(choice (const :tag "none" nil)
     275             :                  (const :tag "all" t)
     276             :                  (const :tag "source-level" source)
     277             :                  (const :tag "byte-level" byte)))
     278             : 
     279             : (defcustom byte-compile-error-on-warn nil
     280             :   "If true, the byte-compiler reports warnings with `error'."
     281             :   :group 'bytecomp
     282             :   :type 'boolean)
     283             : 
     284             : (defconst byte-compile-warning-types
     285             :   '(redefine callargs free-vars unresolved
     286             :              obsolete noruntime cl-functions interactive-only
     287             :              make-local mapcar constants suspicious lexical)
     288             :   "The list of warning types used when `byte-compile-warnings' is t.")
     289             : (defcustom byte-compile-warnings t
     290             :   "List of warnings that the byte-compiler should issue (t for all).
     291             : 
     292             : Elements of the list may be:
     293             : 
     294             :   free-vars   references to variables not in the current lexical scope.
     295             :   unresolved  calls to unknown functions.
     296             :   callargs    function calls with args that don't match the definition.
     297             :   redefine    function name redefined from a macro to ordinary function or vice
     298             :               versa, or redefined to take a different number of arguments.
     299             :   obsolete    obsolete variables and functions.
     300             :   noruntime   functions that may not be defined at runtime (typically
     301             :               defined only under `eval-when-compile').
     302             :   cl-functions    calls to runtime functions (as distinguished from macros and
     303             :                   aliases) from the old CL package (not the newer cl-lib).
     304             :   interactive-only
     305             :               commands that normally shouldn't be called from Lisp code.
     306             :   lexical     global/dynamic variables lacking a prefix.
     307             :   make-local  calls to make-variable-buffer-local that may be incorrect.
     308             :   mapcar      mapcar called for effect.
     309             :   constants   let-binding of, or assignment to, constants/nonvariables.
     310             :   suspicious  constructs that usually don't do what the coder wanted.
     311             : 
     312             : If the list begins with `not', then the remaining elements specify warnings to
     313             : suppress.  For example, (not mapcar) will suppress warnings about mapcar."
     314             :   :group 'bytecomp
     315             :   :type `(choice (const :tag "All" t)
     316             :                  (set :menu-tag "Some"
     317             :                       ,@(mapcar (lambda (x) `(const ,x))
     318             :                                 byte-compile-warning-types))))
     319             : 
     320             : ;;;###autoload
     321             : (put 'byte-compile-warnings 'safe-local-variable
     322             :      (lambda (v)
     323             :        (or (symbolp v)
     324             :            (null (delq nil (mapcar (lambda (x) (not (symbolp x))) v))))))
     325             : 
     326             : (defun byte-compile-warning-enabled-p (warning)
     327             :   "Return non-nil if WARNING is enabled, according to `byte-compile-warnings'."
     328        4275 :   (or (eq byte-compile-warnings t)
     329        3803 :       (if (eq (car byte-compile-warnings) 'not)
     330           0 :           (not (memq warning byte-compile-warnings))
     331        4275 :         (memq warning byte-compile-warnings))))
     332             : 
     333             : ;;;###autoload
     334             : (defun byte-compile-disable-warning (warning)
     335             :   "Change `byte-compile-warnings' to disable WARNING.
     336             : If `byte-compile-warnings' is t, set it to `(not WARNING)'.
     337             : Otherwise, if the first element is `not', add WARNING, else remove it.
     338             : Normally you should let-bind `byte-compile-warnings' before calling this,
     339             : else the global value will be modified."
     340           0 :   (setq byte-compile-warnings
     341           0 :         (cond ((eq byte-compile-warnings t)
     342           0 :                (list 'not warning))
     343           0 :               ((eq (car byte-compile-warnings) 'not)
     344           0 :                (if (memq warning byte-compile-warnings)
     345           0 :                    byte-compile-warnings
     346           0 :                  (append byte-compile-warnings (list warning))))
     347             :               (t
     348           0 :                (delq warning byte-compile-warnings)))))
     349             : 
     350             : ;;;###autoload
     351             : (defun byte-compile-enable-warning (warning)
     352             :   "Change `byte-compile-warnings' to enable WARNING.
     353             : If `byte-compile-warnings' is t, do nothing.  Otherwise, if the
     354             : first element is `not', remove WARNING, else add it.
     355             : Normally you should let-bind `byte-compile-warnings' before calling this,
     356             : else the global value will be modified."
     357           0 :   (or (eq byte-compile-warnings t)
     358           0 :       (setq byte-compile-warnings
     359           0 :             (cond ((eq (car byte-compile-warnings) 'not)
     360           0 :                    (delq warning byte-compile-warnings))
     361           0 :                   ((memq warning byte-compile-warnings)
     362           0 :                    byte-compile-warnings)
     363             :                   (t
     364           0 :                    (append byte-compile-warnings (list warning)))))))
     365             : 
     366             : (defvar byte-compile-interactive-only-functions nil
     367             :   "List of commands that are not meant to be called from Lisp.")
     368             : (make-obsolete-variable 'byte-compile-interactive-only-functions
     369             :                         "use the `interactive-only' symbol property instead."
     370             :                         "24.4")
     371             : 
     372             : (defvar byte-compile-not-obsolete-vars nil
     373             :   "List of variables that shouldn't be reported as obsolete.")
     374             : (defvar byte-compile-global-not-obsolete-vars nil
     375             :   "Global list of variables that shouldn't be reported as obsolete.")
     376             : 
     377             : (defvar byte-compile-not-obsolete-funcs nil
     378             :   "List of functions that shouldn't be reported as obsolete.")
     379             : 
     380             : (defcustom byte-compile-generate-call-tree nil
     381             :   "Non-nil means collect call-graph information when compiling.
     382             : This records which functions were called and from where.
     383             : If the value is t, compilation displays the call graph when it finishes.
     384             : If the value is neither t nor nil, compilation asks you whether to display
     385             : the graph.
     386             : 
     387             : The call tree only lists functions called, not macros used. Those functions
     388             : which the byte-code interpreter knows about directly (eq, cons, etc.) are
     389             : not reported.
     390             : 
     391             : The call tree also lists those functions which are not known to be called
     392             : \(that is, to which no calls have been compiled).  Functions which can be
     393             : invoked interactively are excluded from this list."
     394             :   :group 'bytecomp
     395             :   :type '(choice (const :tag "Yes" t) (const :tag "No" nil)
     396             :                  (other :tag "Ask" lambda)))
     397             : 
     398             : (defvar byte-compile-call-tree nil
     399             :   "Alist of functions and their call tree.
     400             : Each element looks like
     401             : 
     402             :   (FUNCTION CALLERS CALLS)
     403             : 
     404             : where CALLERS is a list of functions that call FUNCTION, and CALLS
     405             : is a list of functions for which calls were generated while compiling
     406             : FUNCTION.")
     407             : 
     408             : (defcustom byte-compile-call-tree-sort 'name
     409             :   "If non-nil, sort the call tree.
     410             : The values `name', `callers', `calls', `calls+callers'
     411             : specify different fields to sort on."
     412             :   :group 'bytecomp
     413             :   :type '(choice (const name) (const callers) (const calls)
     414             :                  (const calls+callers) (const nil)))
     415             : 
     416             : (defvar byte-compile-debug nil
     417             :   "If non-nil, byte compile errors will be raised as signals instead of logged.")
     418             : (defvar byte-compile-jump-tables nil
     419             :   "List of all jump tables used during compilation of this form.")
     420             : (defvar byte-compile-constants nil
     421             :   "List of all constants encountered during compilation of this form.")
     422             : (defvar byte-compile-variables nil
     423             :   "List of all variables encountered during compilation of this form.")
     424             : (defvar byte-compile-bound-variables nil
     425             :   "List of dynamic variables bound in the context of the current form.
     426             : This list lives partly on the stack.")
     427             : (defvar byte-compile-lexical-variables nil
     428             :   "List of variables that have been treated as lexical.
     429             : Filled in `cconv-analyze-form' but initialized and consulted here.")
     430             : (defvar byte-compile-const-variables nil
     431             :   "List of variables declared as constants during compilation of this file.")
     432             : (defvar byte-compile-free-references)
     433             : (defvar byte-compile-free-assignments)
     434             : 
     435             : (defvar byte-compiler-error-flag)
     436             : 
     437             : (defun byte-compile-recurse-toplevel (form non-toplevel-case)
     438             :   "Implement `eval-when-compile' and `eval-and-compile'.
     439             : Return the compile-time value of FORM."
     440             :   ;; Macroexpand (not macroexpand-all!) form at toplevel in case it
     441             :   ;; expands into a toplevel-equivalent `progn'.  See CLHS section
     442             :   ;; 3.2.3.1, "Processing of Top Level Forms".  The semantics are very
     443             :   ;; subtle: see test/lisp/emacs-lisp/bytecomp-tests.el for interesting
     444             :   ;; cases.
     445           0 :   (setf form (macroexp-macroexpand form byte-compile-macro-environment))
     446           0 :   (if (eq (car-safe form) 'progn)
     447           0 :       (cons 'progn
     448           0 :             (mapcar (lambda (subform)
     449           0 :                       (byte-compile-recurse-toplevel
     450           0 :                        subform non-toplevel-case))
     451           0 :                     (cdr form)))
     452           0 :     (funcall non-toplevel-case form)))
     453             : 
     454             : (defconst byte-compile-initial-macro-environment
     455             :   `(
     456             :     ;; (byte-compiler-options . (lambda (&rest forms)
     457             :     ;;                         (apply 'byte-compiler-options-handler forms)))
     458             :     (declare-function . byte-compile-macroexpand-declare-function)
     459             :     (eval-when-compile . ,(lambda (&rest body)
     460             :                             (let ((result nil))
     461             :                               (byte-compile-recurse-toplevel
     462             :                                (macroexp-progn body)
     463             :                                (lambda (form)
     464             :                                  ;; Insulate the following variables
     465             :                                  ;; against changes made in the
     466             :                                  ;; subsidiary compilation.  This
     467             :                                  ;; prevents spurious warning
     468             :                                  ;; messages: "not defined at runtime"
     469             :                                  ;; etc.
     470             :                                  (let ((byte-compile-unresolved-functions
     471             :                                         byte-compile-unresolved-functions)
     472             :                                        (byte-compile-new-defuns
     473             :                                         byte-compile-new-defuns))
     474             :                                    (setf result
     475             :                                          (byte-compile-eval
     476             :                                           (byte-compile-top-level
     477             :                                            (byte-compile-preprocess form)))))))
     478             :                               (list 'quote result))))
     479             :     (eval-and-compile . ,(lambda (&rest body)
     480             :                            (byte-compile-recurse-toplevel
     481             :                             (macroexp-progn body)
     482             :                             (lambda (form)
     483             :                               ;; Don't compile here, since we don't know
     484             :                               ;; whether to compile as byte-compile-form
     485             :                               ;; or byte-compile-file-form.
     486             :                               (let ((expanded
     487             :                                      (macroexpand-all
     488             :                                       form
     489             :                                       macroexpand-all-environment)))
     490             :                                 (eval expanded lexical-binding)
     491             :                                 expanded))))))
     492             :   "The default macro-environment passed to macroexpand by the compiler.
     493             : Placing a macro here will cause a macro to have different semantics when
     494             : expanded by the compiler as when expanded by the interpreter.")
     495             : 
     496             : (defvar byte-compile-macro-environment byte-compile-initial-macro-environment
     497             :   "Alist of macros defined in the file being compiled.
     498             : Each element looks like (MACRONAME . DEFINITION).  It is
     499             : \(MACRONAME . nil) when a macro is redefined as a function.")
     500             : 
     501             : (defvar byte-compile-function-environment nil
     502             :   "Alist of functions defined in the file being compiled.
     503             : This is so we can inline them when necessary.
     504             : Each element looks like (FUNCTIONNAME . DEFINITION).  It is
     505             : \(FUNCTIONNAME . nil) when a function is redefined as a macro.
     506             : It is \(FUNCTIONNAME . t) when all we know is that it was defined,
     507             : and we don't know the definition.  For an autoloaded function, DEFINITION
     508             : has the form (autoload . FILENAME).")
     509             : 
     510             : (defvar byte-compile-unresolved-functions nil
     511             :   "Alist of undefined functions to which calls have been compiled.
     512             : This variable is only significant whilst compiling an entire buffer.
     513             : Used for warnings when a function is not known to be defined or is later
     514             : defined with incorrect args.")
     515             : 
     516             : (defvar byte-compile-noruntime-functions nil
     517             :   "Alist of functions called that may not be defined when the compiled code is run.
     518             : Used for warnings about calling a function that is defined during compilation
     519             : but won't necessarily be defined when the compiled file is loaded.")
     520             : 
     521             : (defvar byte-compile-new-defuns nil
     522             :   "List of (runtime) functions defined in this compilation run.
     523             : This variable is used to qualify `byte-compile-noruntime-functions' when
     524             : outputting warnings about functions not being defined at runtime.")
     525             : 
     526             : ;; Variables for lexical binding
     527             : (defvar byte-compile--lexical-environment nil
     528             :   "The current lexical environment.")
     529             : 
     530             : (defvar byte-compile-tag-number 0)
     531             : (defvar byte-compile-output nil
     532             :   "Alist describing contents to put in byte code string.
     533             : Each element is (INDEX . VALUE)")
     534             : (defvar byte-compile-depth 0 "Current depth of execution stack.")
     535             : (defvar byte-compile-maxdepth 0 "Maximum depth of execution stack.")
     536             : 
     537             : 
     538             : ;;; The byte codes; this information is duplicated in bytecomp.c
     539             : 
     540             : (defvar byte-code-vector nil
     541             :   "An array containing byte-code names indexed by byte-code values.")
     542             : 
     543             : (defvar byte-stack+-info nil
     544             :   "An array with the stack adjustment for each byte-code.")
     545             : 
     546             : (defmacro byte-defop (opcode stack-adjust opname &optional docstring)
     547             :   ;; This is a speed-hack for building the byte-code-vector at compile-time.
     548             :   ;; We fill in the vector at macroexpand-time, and then after the last call
     549             :   ;; to byte-defop, we write the vector out as a constant instead of writing
     550             :   ;; out a bunch of calls to aset.
     551             :   ;; Actually, we don't fill in the vector itself, because that could make
     552             :   ;; it problematic to compile big changes to this compiler; we store the
     553             :   ;; values on its plist, and remove them later in -extrude.
     554         128 :   (let ((v1 (or (get 'byte-code-vector 'tmp-compile-time-value)
     555           1 :                 (put 'byte-code-vector 'tmp-compile-time-value
     556         128 :                      (make-vector 256 nil))))
     557         128 :         (v2 (or (get 'byte-stack+-info 'tmp-compile-time-value)
     558           1 :                 (put 'byte-stack+-info 'tmp-compile-time-value
     559         128 :                      (make-vector 256 nil)))))
     560         128 :     (aset v1 opcode opname)
     561         128 :     (aset v2 opcode stack-adjust))
     562         128 :   (if docstring
     563          23 :       (list 'defconst opname opcode (concat "Byte code opcode " docstring "."))
     564         128 :       (list 'defconst opname opcode)))
     565             : 
     566             : (defmacro byte-extrude-byte-code-vectors ()
     567           1 :   (prog1 (list 'setq 'byte-code-vector
     568           1 :                      (get 'byte-code-vector 'tmp-compile-time-value)
     569             :                      'byte-stack+-info
     570           1 :                      (get 'byte-stack+-info 'tmp-compile-time-value))
     571           1 :     (put 'byte-code-vector 'tmp-compile-time-value nil)
     572           1 :     (put 'byte-stack+-info 'tmp-compile-time-value nil)))
     573             : 
     574             : 
     575             : ;; These opcodes are special in that they pack their argument into the
     576             : ;; opcode word.
     577             : ;;
     578             : (byte-defop   0  1 byte-stack-ref "for stack reference")
     579             : (byte-defop   8  1 byte-varref  "for variable reference")
     580             : (byte-defop  16 -1 byte-varset  "for setting a variable")
     581             : (byte-defop  24 -1 byte-varbind "for binding a variable")
     582             : (byte-defop  32  0 byte-call    "for calling a function")
     583             : (byte-defop  40  0 byte-unbind  "for unbinding special bindings")
     584             : ;; codes 8-47 are consumed by the preceding opcodes
     585             : 
     586             : ;; New (in Emacs-24.4) bytecodes for more efficient handling of non-local exits
     587             : ;; (especially useful in lexical-binding code).
     588             : (byte-defop  48  0 byte-pophandler)
     589             : (byte-defop  50 -1 byte-pushcatch)
     590             : (byte-defop  49 -1 byte-pushconditioncase)
     591             : 
     592             : ;; unused: 51-55
     593             : 
     594             : (byte-defop  56 -1 byte-nth)
     595             : (byte-defop  57  0 byte-symbolp)
     596             : (byte-defop  58  0 byte-consp)
     597             : (byte-defop  59  0 byte-stringp)
     598             : (byte-defop  60  0 byte-listp)
     599             : (byte-defop  61 -1 byte-eq)
     600             : (byte-defop  62 -1 byte-memq)
     601             : (byte-defop  63  0 byte-not)
     602             : (byte-defop  64  0 byte-car)
     603             : (byte-defop  65  0 byte-cdr)
     604             : (byte-defop  66 -1 byte-cons)
     605             : (byte-defop  67  0 byte-list1)
     606             : (byte-defop  68 -1 byte-list2)
     607             : (byte-defop  69 -2 byte-list3)
     608             : (byte-defop  70 -3 byte-list4)
     609             : (byte-defop  71  0 byte-length)
     610             : (byte-defop  72 -1 byte-aref)
     611             : (byte-defop  73 -2 byte-aset)
     612             : (byte-defop  74  0 byte-symbol-value)
     613             : (byte-defop  75  0 byte-symbol-function) ; this was commented out
     614             : (byte-defop  76 -1 byte-set)
     615             : (byte-defop  77 -1 byte-fset) ; this was commented out
     616             : (byte-defop  78 -1 byte-get)
     617             : (byte-defop  79 -2 byte-substring)
     618             : (byte-defop  80 -1 byte-concat2)
     619             : (byte-defop  81 -2 byte-concat3)
     620             : (byte-defop  82 -3 byte-concat4)
     621             : (byte-defop  83  0 byte-sub1)
     622             : (byte-defop  84  0 byte-add1)
     623             : (byte-defop  85 -1 byte-eqlsign)
     624             : (byte-defop  86 -1 byte-gtr)
     625             : (byte-defop  87 -1 byte-lss)
     626             : (byte-defop  88 -1 byte-leq)
     627             : (byte-defop  89 -1 byte-geq)
     628             : (byte-defop  90 -1 byte-diff)
     629             : (byte-defop  91  0 byte-negate)
     630             : (byte-defop  92 -1 byte-plus)
     631             : (byte-defop  93 -1 byte-max)
     632             : (byte-defop  94 -1 byte-min)
     633             : (byte-defop  95 -1 byte-mult) ; v19 only
     634             : (byte-defop  96  1 byte-point)
     635             : (byte-defop  98  0 byte-goto-char)
     636             : (byte-defop  99  0 byte-insert)
     637             : (byte-defop 100  1 byte-point-max)
     638             : (byte-defop 101  1 byte-point-min)
     639             : (byte-defop 102  0 byte-char-after)
     640             : (byte-defop 103  1 byte-following-char)
     641             : (byte-defop 104  1 byte-preceding-char)
     642             : (byte-defop 105  1 byte-current-column)
     643             : (byte-defop 106  0 byte-indent-to)
     644             : (byte-defop 107  0 byte-scan-buffer-OBSOLETE) ; no longer generated as of v18
     645             : (byte-defop 108  1 byte-eolp)
     646             : (byte-defop 109  1 byte-eobp)
     647             : (byte-defop 110  1 byte-bolp)
     648             : (byte-defop 111  1 byte-bobp)
     649             : (byte-defop 112  1 byte-current-buffer)
     650             : (byte-defop 113  0 byte-set-buffer)
     651             : (byte-defop 114  0 byte-save-current-buffer
     652             :   "To make a binding to record the current buffer")
     653             : (byte-defop 115  0 byte-set-mark-OBSOLETE)
     654             : (byte-defop 116  1 byte-interactive-p-OBSOLETE)
     655             : 
     656             : ;; These ops are new to v19
     657             : (byte-defop 117  0 byte-forward-char)
     658             : (byte-defop 118  0 byte-forward-word)
     659             : (byte-defop 119 -1 byte-skip-chars-forward)
     660             : (byte-defop 120 -1 byte-skip-chars-backward)
     661             : (byte-defop 121  0 byte-forward-line)
     662             : (byte-defop 122  0 byte-char-syntax)
     663             : (byte-defop 123 -1 byte-buffer-substring)
     664             : (byte-defop 124 -1 byte-delete-region)
     665             : (byte-defop 125 -1 byte-narrow-to-region)
     666             : (byte-defop 126  1 byte-widen)
     667             : (byte-defop 127  0 byte-end-of-line)
     668             : 
     669             : ;; unused: 128
     670             : 
     671             : ;; These store their argument in the next two bytes
     672             : (byte-defop 129  1 byte-constant2
     673             :    "for reference to a constant with vector index >= byte-constant-limit")
     674             : (byte-defop 130  0 byte-goto "for unconditional jump")
     675             : (byte-defop 131 -1 byte-goto-if-nil "to pop value and jump if it's nil")
     676             : (byte-defop 132 -1 byte-goto-if-not-nil "to pop value and jump if it's not nil")
     677             : (byte-defop 133 -1 byte-goto-if-nil-else-pop
     678             :   "to examine top-of-stack, jump and don't pop it if it's nil,
     679             : otherwise pop it")
     680             : (byte-defop 134 -1 byte-goto-if-not-nil-else-pop
     681             :   "to examine top-of-stack, jump and don't pop it if it's non nil,
     682             : otherwise pop it")
     683             : 
     684             : (byte-defop 135 -1 byte-return "to pop a value and return it from `byte-code'")
     685             : (byte-defop 136 -1 byte-discard "to discard one value from stack")
     686             : (byte-defop 137  1 byte-dup     "to duplicate the top of the stack")
     687             : 
     688             : (byte-defop 138  0 byte-save-excursion
     689             :   "to make a binding to record the buffer, point and mark")
     690             : (byte-defop 139  0 byte-save-window-excursion-OBSOLETE
     691             :   "to make a binding to record entire window configuration")
     692             : (byte-defop 140  0 byte-save-restriction
     693             :   "to make a binding to record the current buffer clipping restrictions")
     694             : (byte-defop 141 -1 byte-catch
     695             :   "for catch.  Takes, on stack, the tag and an expression for the body")
     696             : (byte-defop 142 -1 byte-unwind-protect
     697             :   "for unwind-protect.  Takes, on stack, an expression for the unwind-action")
     698             : 
     699             : ;; For condition-case.  Takes, on stack, the variable to bind,
     700             : ;; an expression for the body, and a list of clauses.
     701             : (byte-defop 143 -2 byte-condition-case)
     702             : 
     703             : (byte-defop 144  0 byte-temp-output-buffer-setup-OBSOLETE)
     704             : (byte-defop 145 -1 byte-temp-output-buffer-show-OBSOLETE)
     705             : 
     706             : ;; these ops are new to v19
     707             : 
     708             : ;; To unbind back to the beginning of this frame.
     709             : ;; Not used yet, but will be needed for tail-recursion elimination.
     710             : (byte-defop 146  0 byte-unbind-all)
     711             : 
     712             : ;; these ops are new to v19
     713             : (byte-defop 147 -2 byte-set-marker)
     714             : (byte-defop 148  0 byte-match-beginning)
     715             : (byte-defop 149  0 byte-match-end)
     716             : (byte-defop 150  0 byte-upcase)
     717             : (byte-defop 151  0 byte-downcase)
     718             : (byte-defop 152 -1 byte-string=)
     719             : (byte-defop 153 -1 byte-string<)
     720             : (byte-defop 154 -1 byte-equal)
     721             : (byte-defop 155 -1 byte-nthcdr)
     722             : (byte-defop 156 -1 byte-elt)
     723             : (byte-defop 157 -1 byte-member)
     724             : (byte-defop 158 -1 byte-assq)
     725             : (byte-defop 159  0 byte-nreverse)
     726             : (byte-defop 160 -1 byte-setcar)
     727             : (byte-defop 161 -1 byte-setcdr)
     728             : (byte-defop 162  0 byte-car-safe)
     729             : (byte-defop 163  0 byte-cdr-safe)
     730             : (byte-defop 164 -1 byte-nconc)
     731             : (byte-defop 165 -1 byte-quo)
     732             : (byte-defop 166 -1 byte-rem)
     733             : (byte-defop 167  0 byte-numberp)
     734             : (byte-defop 168  0 byte-integerp)
     735             : 
     736             : ;; unused: 169-174
     737             : (byte-defop 175 nil byte-listN)
     738             : (byte-defop 176 nil byte-concatN)
     739             : (byte-defop 177 nil byte-insertN)
     740             : 
     741             : (byte-defop 178 -1 byte-stack-set)      ; Stack offset in following one byte.
     742             : (byte-defop 179 -1 byte-stack-set2)     ; Stack offset in following two bytes.
     743             : 
     744             : ;; If (following one byte & 0x80) == 0
     745             : ;;    discard (following one byte & 0x7F) stack entries
     746             : ;; else
     747             : ;;    discard (following one byte & 0x7F) stack entries _underneath_ TOS
     748             : ;;    (that is, if the operand = 0x83,  ... X Y Z T  =>  ... T)
     749             : (byte-defop 182 nil byte-discardN)
     750             : ;; `byte-discardN-preserve-tos' is a pseudo-op that gets turned into
     751             : ;; `byte-discardN' with the high bit in the operand set (by
     752             : ;; `byte-compile-lapcode').
     753             : (defconst byte-discardN-preserve-tos byte-discardN)
     754             : 
     755             : (byte-defop 183 -2 byte-switch
     756             :  "to take a hash table and a value from the stack, and jump to the address
     757             : the value maps to, if any.")
     758             : 
     759             : ;; unused: 182-191
     760             : 
     761             : (byte-defop 192  1 byte-constant        "for reference to a constant")
     762             : ;; codes 193-255 are consumed by byte-constant.
     763             : (defconst byte-constant-limit 64
     764             :   "Exclusive maximum index usable in the `byte-constant' opcode.")
     765             : 
     766             : (defconst byte-goto-ops '(byte-goto byte-goto-if-nil byte-goto-if-not-nil
     767             :                           byte-goto-if-nil-else-pop
     768             :                           byte-goto-if-not-nil-else-pop
     769             :                           byte-pushcatch byte-pushconditioncase)
     770             :   "List of byte-codes whose offset is a pc.")
     771             : 
     772             : (defconst byte-goto-always-pop-ops '(byte-goto-if-nil byte-goto-if-not-nil))
     773             : 
     774             : (byte-extrude-byte-code-vectors)
     775             : 
     776             : ;;; lapcode generator
     777             : ;;
     778             : ;; the byte-compiler now does source -> lapcode -> bytecode instead of
     779             : ;; source -> bytecode, because it's a lot easier to make optimizations
     780             : ;; on lapcode than on bytecode.
     781             : ;;
     782             : ;; Elements of the lapcode list are of the form (<instruction> . <parameter>)
     783             : ;; where instruction is a symbol naming a byte-code instruction,
     784             : ;; and parameter is an argument to that instruction, if any.
     785             : ;;
     786             : ;; The instruction can be the pseudo-op TAG, which means that this position
     787             : ;; in the instruction stream is a target of a goto.  (car PARAMETER) will be
     788             : ;; the PC for this location, and the whole instruction "(TAG pc)" will be the
     789             : ;; parameter for some goto op.
     790             : ;;
     791             : ;; If the operation is varbind, varref, varset or push-constant, then the
     792             : ;; parameter is (variable/constant . index_in_constant_vector).
     793             : ;;
     794             : ;; First, the source code is macroexpanded and optimized in various ways.
     795             : ;; Then the resultant code is compiled into lapcode.  Another set of
     796             : ;; optimizations are then run over the lapcode.  Then the variables and
     797             : ;; constants referenced by the lapcode are collected and placed in the
     798             : ;; constants-vector.  (This happens now so that variables referenced by dead
     799             : ;; code don't consume space.)  And finally, the lapcode is transformed into
     800             : ;; compacted byte-code.
     801             : ;;
     802             : ;; A distinction is made between variables and constants because the variable-
     803             : ;; referencing instructions are more sensitive to the variables being near the
     804             : ;; front of the constants-vector than the constant-referencing instructions.
     805             : ;; Also, this lets us notice references to free variables.
     806             : 
     807             : (defmacro byte-compile-push-bytecodes (&rest args)
     808             :   "Push bytes onto BVAR, and increment CVAR by the number of bytes pushed.
     809             : BVAR and CVAR are variables which are updated after evaluating
     810             : all the arguments.
     811             : 
     812             : \(fn BYTE1 BYTE2 ... BYTEn BVAR CVAR)"
     813          12 :   (let ((byte-exprs (butlast args 2))
     814          12 :         (bytes-var (car (last args 2)))
     815          12 :         (pc-var (car (last args))))
     816          12 :     `(setq ,bytes-var ,(if (null (cdr byte-exprs))
     817           4 :                            `(progn (cl-assert (<= 0 ,(car byte-exprs)))
     818           4 :                                    (cons ,@byte-exprs ,bytes-var))
     819          12 :                          `(nconc (list ,@(reverse byte-exprs)) ,bytes-var))
     820          12 :            ,pc-var (+ ,(length byte-exprs) ,pc-var))))
     821             : 
     822             : (defmacro byte-compile-push-bytecode-const2 (opcode const2 bytes pc)
     823             :   "Push OPCODE and the two-byte constant CONST2 onto BYTES, and add 3 to PC.
     824             : CONST2 may be evaluated multiple times."
     825           3 :   `(byte-compile-push-bytecodes ,opcode (logand ,const2 255) (lsh ,const2 -8)
     826           3 :                                 ,bytes ,pc))
     827             : 
     828             : (defun byte-compile-lapcode (lap)
     829             :   "Turns lapcode into bytecode.  The lapcode is destroyed."
     830             :   ;; Lapcode modifications: changes the ID of a tag to be the tag's PC.
     831          24 :   (let ((pc 0)                  ; Program counter
     832             :         op off                  ; Operation & offset
     833             :         opcode                  ; numeric value of OP
     834             :         (bytes '())             ; Put the output bytes here
     835             :         (patchlist nil))        ; List of gotos to patch
     836          24 :     (dolist (lap-entry lap)
     837        4006 :       (setq op (car lap-entry)
     838        4006 :             off (cdr lap-entry))
     839        4006 :       (cond
     840        4006 :        ((not (symbolp op))
     841           0 :         (error "Non-symbolic opcode `%s'" op))
     842        4006 :        ((eq op 'TAG)
     843         145 :         (setcar off pc))
     844             :        (t
     845        3861 :         (setq opcode
     846        3861 :               (if (eq op 'byte-discardN-preserve-tos)
     847             :                   ;; byte-discardN-preserve-tos is a pseudo op, which
     848             :                   ;; is actually the same as byte-discardN
     849             :                   ;; with a modified argument.
     850           5 :                   byte-discardN
     851        3861 :                 (symbol-value op)))
     852        3861 :         (cond ((memq op byte-goto-ops)
     853             :                ;; goto
     854         160 :                (byte-compile-push-bytecodes opcode nil (cdr off) bytes pc)
     855         320 :                (push bytes patchlist))
     856        3701 :               ((or (and (consp off)
     857             :                         ;; Variable or constant reference
     858        2106 :                         (progn
     859        2106 :                           (setq off (cdr off))
     860        3701 :                           (eq op 'byte-constant)))
     861        1655 :                    (and (eq op 'byte-constant)
     862        3701 :                         (integerp off)))
     863             :                ;; constant ref
     864        2140 :                (if (< off byte-constant-limit)
     865        1586 :                    (byte-compile-push-bytecodes (+ byte-constant off)
     866        1586 :                                                 bytes pc)
     867         554 :                  (byte-compile-push-bytecode-const2 byte-constant2 off
     868        2140 :                                                     bytes pc)))
     869        1561 :               ((and (= opcode byte-stack-set)
     870        1561 :                     (> off 255))
     871             :                ;; Use the two-byte version of byte-stack-set if the
     872             :                ;; offset is too large for the normal version.
     873           0 :                (byte-compile-push-bytecode-const2 byte-stack-set2 off
     874           0 :                                                   bytes pc))
     875        1561 :               ((and (>= opcode byte-listN)
     876        1561 :                     (< opcode byte-discardN))
     877             :                ;; These insns all put their operand into one extra byte.
     878          36 :                (byte-compile-push-bytecodes opcode off bytes pc))
     879        1525 :               ((= opcode byte-discardN)
     880             :                ;; byte-discardN is weird in that it encodes a flag in the
     881             :                ;; top bit of its one-byte argument.  If the argument is
     882             :                ;; too large to fit in 7 bits, the opcode can be repeated.
     883           5 :                (let ((flag (if (eq op 'byte-discardN-preserve-tos) #x80 0)))
     884           5 :                  (while (> off #x7f)
     885           0 :                    (byte-compile-push-bytecodes opcode (logior #x7f flag)
     886           0 :                                                 bytes pc)
     887           5 :                    (setq off (- off #x7f)))
     888           5 :                  (byte-compile-push-bytecodes opcode (logior off flag)
     889           5 :                                               bytes pc)))
     890        1520 :               ((null off)
     891             :                ;; opcode that doesn't use OFF
     892          75 :                (byte-compile-push-bytecodes opcode bytes pc))
     893        1445 :               ((and (eq opcode byte-stack-ref) (eq off 0))
     894             :                ;; (stack-ref 0) is really just another name for `dup'.
     895           0 :                (debug)                 ;FIXME: When would this happen?
     896           0 :                (byte-compile-push-bytecodes byte-dup bytes pc))
     897             :               ;; The following three cases are for the special
     898             :               ;; insns that encode their operand into 0, 1, or 2
     899             :               ;; extra bytes depending on its magnitude.
     900        1445 :               ((< off 6)
     901        1311 :                (byte-compile-push-bytecodes (+ opcode off) bytes pc))
     902         134 :               ((< off 256)
     903         134 :                (byte-compile-push-bytecodes (+ opcode 6) off bytes pc))
     904             :               (t
     905           0 :                (byte-compile-push-bytecode-const2 (+ opcode 7) off
     906        4006 :                                                   bytes pc))))))
     907             :     ;;(if (not (= pc (length bytes)))
     908             :     ;;    (error "Compiler error: pc mismatch - %s %s" pc (length bytes)))
     909             :     ;; Patch tag PCs into absolute jumps.
     910          24 :     (dolist (bytes-tail patchlist)
     911         160 :       (setq pc (caar bytes-tail))       ; Pick PC from goto's tag.
     912             :       ;; Splits PC's value into 2 bytes. The jump address is
     913             :       ;; "reconstructed" by the `FETCH2' macro in `bytecode.c'.
     914         160 :       (setcar (cdr bytes-tail) (logand pc 255))
     915         160 :       (setcar bytes-tail (lsh pc -8))
     916             :       ;; FIXME: Replace this by some workaround.
     917         160 :       (if (> (car bytes-tail) 255) (error "Bytecode overflow")))
     918             : 
     919             :     ;; Similarly, replace TAGs in all jump tables with the correct PC index.
     920          24 :     (dolist (hash-table byte-compile-jump-tables)
     921           0 :       (maphash #'(lambda (value tag)
     922           0 :                    (setq pc (cadr tag))
     923             :                    ;; We don't need to split PC here, as it is stored as a lisp
     924             :                    ;; object in the hash table (whereas other goto-* ops store
     925             :                    ;; it within 2 bytes in the byte string).
     926           0 :                    (puthash value pc hash-table))
     927          24 :                hash-table))
     928          24 :     (apply 'unibyte-string (nreverse bytes))))
     929             : 
     930             : 
     931             : ;;; compile-time evaluation
     932             : 
     933             : (defun byte-compile-cl-file-p (file)
     934             :   "Return non-nil if FILE is one of the CL files."
     935        2266 :   (and (stringp file)
     936        2266 :        (string-match "^cl\\.el" (file-name-nondirectory file))))
     937             : 
     938             : (defun byte-compile-eval (form)
     939             :   "Eval FORM and mark the functions defined therein.
     940             : Each function's symbol gets added to `byte-compile-noruntime-functions'."
     941           0 :   (let ((hist-orig load-history)
     942           0 :         (hist-nil-orig current-load-list))
     943           0 :     (prog1 (eval form lexical-binding)
     944           0 :       (when (byte-compile-warning-enabled-p 'noruntime)
     945           0 :         (let ((hist-new load-history)
     946           0 :               (hist-nil-new current-load-list))
     947             :           ;; Go through load-history, look for newly loaded files
     948             :           ;; and mark all the functions defined therein.
     949           0 :           (while (and hist-new (not (eq hist-new hist-orig)))
     950           0 :             (let ((xs (pop hist-new))
     951             :                   old-autoloads)
     952             :               ;; Make sure the file was not already loaded before.
     953           0 :               (unless (assoc (car xs) hist-orig)
     954           0 :                 (dolist (s xs)
     955           0 :                   (cond
     956           0 :                    ((and (consp s) (eq t (car s)))
     957           0 :                     (push (cdr s) old-autoloads))
     958           0 :                    ((and (consp s) (memq (car s) '(autoload defun)))
     959           0 :                     (unless (memq (cdr s) old-autoloads)
     960           0 :                       (push (cdr s) byte-compile-noruntime-functions))))))))
     961             :           ;; Go through current-load-list for the locally defined funs.
     962           0 :           (let (old-autoloads)
     963           0 :             (while (and hist-nil-new (not (eq hist-nil-new hist-nil-orig)))
     964           0 :               (let ((s (pop hist-nil-new)))
     965           0 :                 (when (and (symbolp s) (not (memq s old-autoloads)))
     966           0 :                   (push s byte-compile-noruntime-functions))
     967           0 :                 (when (and (consp s) (eq t (car s)))
     968           0 :                   (push (cdr s) old-autoloads)))))))
     969           0 :       (when (byte-compile-warning-enabled-p 'cl-functions)
     970           0 :         (let ((hist-new load-history))
     971             :           ;; Go through load-history, looking for the cl files.
     972             :           ;; Since new files are added at the start of load-history,
     973             :           ;; we scan the new history until the tail matches the old.
     974           0 :           (while (and (not byte-compile-cl-functions)
     975           0 :                       hist-new (not (eq hist-new hist-orig)))
     976             :             ;; We used to check if the file had already been loaded,
     977             :             ;; but it is better to check non-nil byte-compile-cl-functions.
     978           0 :             (and (byte-compile-cl-file-p (car (pop hist-new)))
     979           0 :                  (byte-compile-find-cl-functions))))))))
     980             : 
     981             : (defun byte-compile-eval-before-compile (form)
     982             :   "Evaluate FORM for `eval-and-compile'."
     983           0 :   (let ((hist-nil-orig current-load-list))
     984           0 :     (prog1 (eval form lexical-binding)
     985             :       ;; (eval-and-compile (require 'cl) turns off warnings for cl functions.
     986             :       ;; FIXME Why does it do that - just as a hack?
     987             :       ;; There are other ways to do this nowadays.
     988           0 :       (let ((tem current-load-list))
     989           0 :         (while (not (eq tem hist-nil-orig))
     990           0 :           (when (equal (car tem) '(require . cl))
     991           0 :             (byte-compile-disable-warning 'cl-functions))
     992           0 :           (setq tem (cdr tem)))))))
     993             : 
     994             : ;;; byte compiler messages
     995             : 
     996             : (defvar byte-compile-current-form nil)
     997             : (defvar byte-compile-dest-file nil)
     998             : (defvar byte-compile-current-file nil)
     999             : (defvar byte-compile-current-group nil)
    1000             : (defvar byte-compile-current-buffer nil)
    1001             : 
    1002             : ;; Log something that isn't a warning.
    1003             : (defmacro byte-compile-log (format-string &rest args)
    1004           0 :   `(and
    1005             :     byte-optimize
    1006             :     (memq byte-optimize-log '(t source))
    1007             :     (let ((print-escape-newlines t)
    1008             :           (print-level 4)
    1009             :           (print-length 4))
    1010             :       (byte-compile-log-1
    1011             :        (format-message
    1012           0 :         ,format-string
    1013           0 :         ,@(mapcar
    1014           0 :            (lambda (x) (if (symbolp x) (list 'prin1-to-string x) x))
    1015           0 :            args))))))
    1016             : 
    1017             : ;; Log something that isn't a warning.
    1018             : (defun byte-compile-log-1 (string)
    1019           0 :   (with-current-buffer byte-compile-log-buffer
    1020           0 :     (let ((inhibit-read-only t))
    1021           0 :       (goto-char (point-max))
    1022           0 :       (byte-compile-warning-prefix nil nil)
    1023           0 :       (cond (noninteractive
    1024           0 :              (message " %s" string))
    1025             :             (t
    1026           0 :              (insert (format "%s\n" string)))))))
    1027             : 
    1028             : (defvar byte-compile-read-position nil
    1029             :   "Character position we began the last `read' from.")
    1030             : (defvar byte-compile-last-position nil
    1031             :   "Last known character position in the input.")
    1032             : 
    1033             : ;; copied from gnus-util.el
    1034             : (defsubst byte-compile-delete-first (elt list)
    1035           0 :   (if (eq (car list) elt)
    1036           0 :       (cdr list)
    1037           0 :     (let ((total list))
    1038           0 :       (while (and (cdr list)
    1039           0 :                   (not (eq (cadr list) elt)))
    1040           0 :         (setq list (cdr list)))
    1041           0 :       (when (cdr list)
    1042           0 :         (setcdr list (cddr list)))
    1043           0 :       total)))
    1044             : 
    1045             : ;; The purpose of `byte-compile-set-symbol-position' is to attempt to
    1046             : ;; set `byte-compile-last-position' to the "current position" in the
    1047             : ;; raw source code.  This is used for warning and error messages.
    1048             : ;;
    1049             : ;; The function should be called for most occurrences of symbols in
    1050             : ;; the forms being compiled, strictly in the order they occur in the
    1051             : ;; source code.  It should never be called twice for any single
    1052             : ;; occurrence, and should not be called for symbols generated by the
    1053             : ;; byte compiler itself.
    1054             : ;;
    1055             : ;; The function works by scanning the elements in the alist
    1056             : ;; `read-symbol-positions-list' for the next match for the symbol
    1057             : ;; after the current value of `byte-compile-last-position', setting
    1058             : ;; that variable to the match's character position, then deleting the
    1059             : ;; matching element from the list.  Thus the new value for
    1060             : ;; `byte-compile-last-position' is later than the old value unless,
    1061             : ;; perhaps, ALLOW-PREVIOUS is non-nil.
    1062             : ;;
    1063             : ;; So your're probably asking yourself: Isn't this function a gross
    1064             : ;; hack?  And the answer, of course, would be yes.
    1065             : (defun byte-compile-set-symbol-position (sym &optional allow-previous)
    1066        1508 :   (when byte-compile-read-position
    1067           0 :     (let ((last byte-compile-last-position)
    1068             :           entry)
    1069           0 :       (while (progn
    1070           0 :                (setq entry (assq sym read-symbol-positions-list))
    1071           0 :                (when entry
    1072           0 :                  (setq byte-compile-last-position
    1073           0 :                        (+ byte-compile-read-position (cdr entry))
    1074             :                        read-symbol-positions-list
    1075           0 :                        (byte-compile-delete-first
    1076           0 :                         entry read-symbol-positions-list)))
    1077           0 :                (and entry
    1078           0 :                     (or (and allow-previous
    1079           0 :                              (not (= last byte-compile-last-position)))
    1080        1508 :                         (> last byte-compile-last-position))))))))
    1081             : 
    1082             : (defvar byte-compile-last-warned-form nil)
    1083             : (defvar byte-compile-last-logged-file nil)
    1084             : (defvar byte-compile-root-dir nil
    1085             :   "Directory relative to which file names in error messages are written.")
    1086             : 
    1087             : ;; FIXME: We should maybe extend abbreviate-file-name with an optional DIR
    1088             : ;; argument to try and use a relative file-name.
    1089             : (defun byte-compile-abbreviate-file (file &optional dir)
    1090           0 :   (let ((f1 (abbreviate-file-name file))
    1091           0 :         (f2 (file-relative-name file dir)))
    1092           0 :     (if (< (length f2) (length f1)) f2 f1)))
    1093             : 
    1094             : ;; This is used as warning-prefix for the compiler.
    1095             : ;; It is always called with the warnings buffer current.
    1096             : (defun byte-compile-warning-prefix (level entry)
    1097           0 :   (let* ((inhibit-read-only t)
    1098           0 :          (dir (or byte-compile-root-dir default-directory))
    1099           0 :          (file (cond ((stringp byte-compile-current-file)
    1100           0 :                       (format "%s:" (byte-compile-abbreviate-file
    1101           0 :                                      byte-compile-current-file dir)))
    1102           0 :                      ((bufferp byte-compile-current-file)
    1103           0 :                       (format "Buffer %s:"
    1104           0 :                               (buffer-name byte-compile-current-file)))
    1105             :                      ;; We might be simply loading a file that
    1106             :                      ;; contains explicit calls to byte-compile functions.
    1107           0 :                      ((stringp load-file-name)
    1108           0 :                       (format "%s:" (byte-compile-abbreviate-file
    1109           0 :                                      load-file-name dir)))
    1110           0 :                      (t "")))
    1111           0 :          (pos (if (and byte-compile-current-file
    1112           0 :                        (integerp byte-compile-read-position))
    1113           0 :                   (with-current-buffer byte-compile-current-buffer
    1114           0 :                     (format "%d:%d:"
    1115           0 :                             (save-excursion
    1116           0 :                               (goto-char byte-compile-last-position)
    1117           0 :                               (1+ (count-lines (point-min) (point-at-bol))))
    1118           0 :                             (save-excursion
    1119           0 :                               (goto-char byte-compile-last-position)
    1120           0 :                               (1+ (current-column)))))
    1121           0 :                 ""))
    1122           0 :          (form (if (eq byte-compile-current-form :end) "end of data"
    1123           0 :                  (or byte-compile-current-form "toplevel form"))))
    1124           0 :     (when (or (and byte-compile-current-file
    1125           0 :                    (not (equal byte-compile-current-file
    1126           0 :                                byte-compile-last-logged-file)))
    1127           0 :               (and byte-compile-current-form
    1128           0 :                    (not (eq byte-compile-current-form
    1129           0 :                             byte-compile-last-warned-form))))
    1130           0 :       (insert (format "\nIn %s:\n" form)))
    1131           0 :     (when level
    1132           0 :       (insert (format "%s%s" file pos))))
    1133           0 :   (setq byte-compile-last-logged-file byte-compile-current-file
    1134           0 :         byte-compile-last-warned-form byte-compile-current-form)
    1135           0 :   entry)
    1136             : 
    1137             : ;; This no-op function is used as the value of warning-series
    1138             : ;; to tell inner calls to displaying-byte-compile-warnings
    1139             : ;; not to bind warning-series.
    1140             : (defun byte-compile-warning-series (&rest _ignore)
    1141             :   nil)
    1142             : 
    1143             : ;; (compile-mode) will cause this to be loaded.
    1144             : (declare-function compilation-forget-errors "compile" ())
    1145             : 
    1146             : ;; Log the start of a file in `byte-compile-log-buffer', and mark it as done.
    1147             : ;; Return the position of the start of the page in the log buffer.
    1148             : ;; But do nothing in batch mode.
    1149             : (defun byte-compile-log-file ()
    1150          12 :   (and (not (equal byte-compile-current-file byte-compile-last-logged-file))
    1151           0 :        (not noninteractive)
    1152           0 :        (with-current-buffer (get-buffer-create byte-compile-log-buffer)
    1153           0 :          (goto-char (point-max))
    1154           0 :          (let* ((inhibit-read-only t)
    1155           0 :                 (dir (and byte-compile-current-file
    1156           0 :                           (file-name-directory byte-compile-current-file)))
    1157           0 :                 (was-same (equal default-directory dir))
    1158             :                 pt)
    1159           0 :            (when dir
    1160           0 :              (unless was-same
    1161           0 :                (insert (format-message "Leaving directory `%s'\n"
    1162           0 :                                        default-directory))))
    1163           0 :            (unless (bolp)
    1164           0 :              (insert "\n"))
    1165           0 :            (setq pt (point-marker))
    1166           0 :            (if byte-compile-current-file
    1167           0 :                (insert "\f\nCompiling "
    1168           0 :                        (if (stringp byte-compile-current-file)
    1169           0 :                            (concat "file " byte-compile-current-file)
    1170           0 :                          (concat "buffer "
    1171           0 :                                  (buffer-name byte-compile-current-file)))
    1172           0 :                        " at " (current-time-string) "\n")
    1173           0 :              (insert "\f\nCompiling no file at " (current-time-string) "\n"))
    1174           0 :            (when dir
    1175           0 :              (setq default-directory dir)
    1176           0 :              (unless was-same
    1177           0 :                (insert (format-message "Entering directory `%s'\n"
    1178           0 :                                        default-directory))))
    1179           0 :            (setq byte-compile-last-logged-file byte-compile-current-file
    1180           0 :                  byte-compile-last-warned-form nil)
    1181             :            ;; Do this after setting default-directory.
    1182           0 :            (unless (derived-mode-p 'compilation-mode) (compilation-mode))
    1183           0 :            (compilation-forget-errors)
    1184          12 :            pt))))
    1185             : 
    1186             : (defun byte-compile-log-warning (string &optional fill level)
    1187             :   "Log a message STRING in `byte-compile-log-buffer'.
    1188             : Also log the current function and file if not already done.  If
    1189             : FILL is non-nil, set `warning-fill-prefix' to four spaces.  LEVEL
    1190             : is the warning level (`:warning' or `:error').  Do not call this
    1191             : function directly; use `byte-compile-warn' or
    1192             : `byte-compile-report-error' instead."
    1193           0 :   (let ((warning-prefix-function 'byte-compile-warning-prefix)
    1194             :         (warning-type-format "")
    1195           0 :         (warning-fill-prefix (if fill "    ")))
    1196           0 :     (display-warning 'bytecomp string level byte-compile-log-buffer)))
    1197             : 
    1198             : (defun byte-compile-warn (format &rest args)
    1199             :   "Issue a byte compiler warning; use (format-message FORMAT ARGS...) for message."
    1200           0 :   (setq format (apply #'format-message format args))
    1201           0 :   (if byte-compile-error-on-warn
    1202           0 :       (error "%s" format)             ; byte-compile-file catches and logs it
    1203           0 :     (byte-compile-log-warning format t :warning)))
    1204             : 
    1205             : (defun byte-compile-warn-obsolete (symbol)
    1206             :   "Warn that SYMBOL (a variable or function) is obsolete."
    1207           1 :   (when (byte-compile-warning-enabled-p 'obsolete)
    1208           0 :     (let* ((funcp (get symbol 'byte-obsolete-info))
    1209           0 :            (msg (macroexp--obsolete-warning
    1210           0 :                  symbol
    1211           0 :                  (or funcp (get symbol 'byte-obsolete-variable))
    1212           0 :                  (if funcp "function" "variable"))))
    1213           0 :       (unless (and funcp (memq symbol byte-compile-not-obsolete-funcs))
    1214           1 :         (byte-compile-warn "%s" msg)))))
    1215             : 
    1216             : (defun byte-compile-report-error (error-info &optional fill)
    1217             :   "Report Lisp error in compilation.
    1218             : ERROR-INFO is the error data, in the form of either (ERROR-SYMBOL . DATA)
    1219             : or STRING.  If FILL is non-nil, set ‘warning-fill-prefix’ to four spaces
    1220             : when printing the error message."
    1221           0 :   (setq byte-compiler-error-flag t)
    1222           0 :   (byte-compile-log-warning
    1223           0 :    (if (stringp error-info) error-info
    1224           0 :      (error-message-string error-info))
    1225           0 :    fill :error))
    1226             : 
    1227             : ;;; sanity-checking arglists
    1228             : 
    1229             : (defun byte-compile-fdefinition (name macro-p)
    1230             :   ;; If a function has an entry saying (FUNCTION . t).
    1231             :   ;; that means we know it is defined but we don't know how.
    1232             :   ;; If a function has an entry saying (FUNCTION . nil),
    1233             :   ;; that means treat it as not defined.
    1234         124 :   (let* ((list (if macro-p
    1235          56 :                    byte-compile-macro-environment
    1236         124 :                  byte-compile-function-environment))
    1237         124 :          (env (cdr (assq name list))))
    1238         124 :     (or env
    1239         124 :         (let ((fn name))
    1240         131 :           (while (and (symbolp fn)
    1241         124 :                       (fboundp fn)
    1242         124 :                       (or (symbolp (symbol-function fn))
    1243         124 :                           (consp (symbol-function fn))
    1244         124 :                           (and (not macro-p)
    1245         131 :                                (byte-code-function-p (symbol-function fn)))))
    1246         124 :             (setq fn (symbol-function fn)))
    1247         124 :           (let ((advertised (gethash (if (and (symbolp fn) (fboundp fn))
    1248             :                                          ;; Could be a subr.
    1249         117 :                                          (symbol-function fn)
    1250         124 :                                        fn)
    1251         124 :                                      advertised-signature-table t)))
    1252         124 :             (cond
    1253         124 :              ((listp advertised)
    1254           0 :               (if macro-p
    1255           0 :                   `(macro lambda ,advertised)
    1256           0 :                 `(lambda ,advertised)))
    1257         124 :              ((and (not macro-p) (byte-code-function-p fn)) fn)
    1258         117 :              ((not (consp fn)) nil)
    1259           0 :              ((eq 'macro (car fn)) (cdr fn))
    1260           0 :              (macro-p nil)
    1261           0 :              ((eq 'autoload (car fn)) nil)
    1262         124 :              (t fn)))))))
    1263             : 
    1264             : (defun byte-compile-arglist-signature (arglist)
    1265           0 :   (cond
    1266           0 :    ((listp arglist)
    1267           0 :     (let ((args 0)
    1268             :           opts
    1269             :           restp)
    1270           0 :       (while arglist
    1271           0 :         (cond ((eq (car arglist) '&optional)
    1272           0 :                (or opts (setq opts 0)))
    1273           0 :               ((eq (car arglist) '&rest)
    1274           0 :                (if (cdr arglist)
    1275           0 :                    (setq restp t
    1276           0 :                          arglist nil)))
    1277             :               (t
    1278           0 :                (if opts
    1279           0 :                    (setq opts (1+ opts))
    1280           0 :                  (setq args (1+ args)))))
    1281           0 :         (setq arglist (cdr arglist)))
    1282           0 :       (cons args (if restp nil (if opts (+ args opts) args)))))
    1283             :    ;; Unknown arglist.
    1284           0 :    (t '(0))))
    1285             : 
    1286             : (defun byte-compile--function-signature (f)
    1287             :   ;; Similar to help-function-arglist, except that it returns the info
    1288             :   ;; in a different format.
    1289          63 :   (and (eq 'macro (car-safe f)) (setq f (cdr f)))
    1290             :   ;; Advice wrappers have "catch all" args, so fetch the actual underlying
    1291             :   ;; function to find the real arguments.
    1292          63 :   (while (advice--p f) (setq f (advice--cdr f)))
    1293          63 :   (if (eq (car-safe f) 'declared)
    1294           0 :       (byte-compile-arglist-signature (nth 1 f))
    1295          63 :     (condition-case nil
    1296          63 :         (let ((sig (func-arity f)))
    1297           7 :           (if (numberp (cdr sig)) sig (list (car sig))))
    1298          63 :       (error '(0)))))
    1299             : 
    1300             : (defun byte-compile-arglist-signatures-congruent-p (old new)
    1301           0 :   (not (or
    1302           0 :          (> (car new) (car old))  ; requires more args now
    1303           0 :          (and (null (cdr old))    ; took rest-args, doesn't any more
    1304           0 :               (cdr new))
    1305           0 :          (and (cdr new) (cdr old) ; can't take as many args now
    1306           0 :               (< (cdr new) (cdr old)))
    1307           0 :          )))
    1308             : 
    1309             : (defun byte-compile-arglist-signature-string (signature)
    1310           0 :   (cond ((null (cdr signature))
    1311           0 :          (format "%d+" (car signature)))
    1312           0 :         ((= (car signature) (cdr signature))
    1313           0 :          (format "%d" (car signature)))
    1314           0 :         (t (format "%d-%d" (car signature) (cdr signature)))))
    1315             : 
    1316             : (defun byte-compile-function-warn (f nargs def)
    1317          68 :   (byte-compile-set-symbol-position f)
    1318          68 :   (when (get f 'byte-obsolete-info)
    1319          68 :     (byte-compile-warn-obsolete f))
    1320             : 
    1321             :   ;; Check to see if the function will be available at runtime
    1322             :   ;; and/or remember its arity if it's unknown.
    1323          68 :   (or (and (or def (fboundp f))         ; might be a subr or autoload.
    1324          68 :            (not (memq f byte-compile-noruntime-functions)))
    1325           0 :       (eq f byte-compile-current-form)  ; ## This doesn't work
    1326             :                                         ; with recursion.
    1327             :       ;; It's a currently-undefined function.
    1328             :       ;; Remember number of args in call.
    1329           0 :       (let ((cons (assq f byte-compile-unresolved-functions)))
    1330           0 :         (if cons
    1331           0 :             (or (memq nargs (cdr cons))
    1332           0 :                 (push nargs (cdr cons)))
    1333           0 :           (push (list f nargs)
    1334          68 :                 byte-compile-unresolved-functions)))))
    1335             : 
    1336             : ;; Warn if the form is calling a function with the wrong number of arguments.
    1337             : (defun byte-compile-callargs-warn (form)
    1338          63 :   (let* ((def (or (byte-compile-fdefinition (car form) nil)
    1339          63 :                   (byte-compile-fdefinition (car form) t)))
    1340          63 :          (sig (byte-compile--function-signature def))
    1341          63 :          (ncall (length (cdr form))))
    1342             :     ;; Check many or unevalled from subr-arity.
    1343          63 :     (if (and (cdr-safe sig)
    1344          63 :              (not (numberp (cdr sig))))
    1345          63 :         (setcdr sig nil))
    1346          63 :     (if sig
    1347          63 :         (when (or (< ncall (car sig))
    1348          63 :                 (and (cdr sig) (> ncall (cdr sig))))
    1349           0 :           (byte-compile-set-symbol-position (car form))
    1350           0 :           (byte-compile-warn
    1351             :            "%s called with %d argument%s, but %s %s"
    1352           0 :            (car form) ncall
    1353           0 :            (if (= 1 ncall) "" "s")
    1354           0 :            (if (< ncall (car sig))
    1355             :                "requires"
    1356           0 :              "accepts only")
    1357          63 :            (byte-compile-arglist-signature-string sig))))
    1358          63 :     (byte-compile-format-warn form)
    1359          63 :     (byte-compile-function-warn (car form) (length (cdr form)) def)))
    1360             : 
    1361             : (defun byte-compile-format-warn (form)
    1362             :   "Warn if FORM is `format'-like with inconsistent args.
    1363             : Applies if head of FORM is a symbol with non-nil property
    1364             : `byte-compile-format-like' and first arg is a constant string.
    1365             : Then check the number of format fields matches the number of
    1366             : extra args."
    1367          63 :   (when (and (symbolp (car form))
    1368          63 :              (stringp (nth 1 form))
    1369          63 :              (get (car form) 'byte-compile-format-like))
    1370           0 :     (let ((nfields (with-temp-buffer
    1371           0 :                      (insert (nth 1 form))
    1372           0 :                      (goto-char (point-min))
    1373           0 :                      (let ((i 0) (n 0))
    1374           0 :                        (while (re-search-forward "%." nil t)
    1375           0 :                          (backward-char)
    1376           0 :                          (unless (eq ?% (char-after))
    1377           0 :                            (setq i (if (looking-at "\\([0-9]+\\)\\$")
    1378           0 :                                        (string-to-number (match-string 1) 10)
    1379           0 :                                      (1+ i))
    1380           0 :                                  n (max n i)))
    1381           0 :                          (forward-char))
    1382           0 :                        n)))
    1383           0 :           (nargs (- (length form) 2)))
    1384           0 :       (unless (= nargs nfields)
    1385           0 :         (byte-compile-warn
    1386           0 :          "`%s' called with %d args to fill %d format field(s)" (car form)
    1387          63 :          nargs nfields)))))
    1388             : 
    1389             : (dolist (elt '(format message error))
    1390             :   (put elt 'byte-compile-format-like t))
    1391             : 
    1392             : ;; Warn if a custom definition fails to specify :group, or :type.
    1393             : (defun byte-compile-nogroup-warn (form)
    1394           0 :   (let ((keyword-args (cdr (cdr (cdr (cdr form)))))
    1395           0 :         (name (cadr form)))
    1396           0 :     (when (eq (car-safe name) 'quote)
    1397           0 :       (or (not (eq (car form) 'custom-declare-variable))
    1398           0 :           (plist-get keyword-args :type)
    1399           0 :           (byte-compile-warn
    1400           0 :            "defcustom for `%s' fails to specify type" (cadr name)))
    1401           0 :       (if (and (memq (car form) '(custom-declare-face custom-declare-variable))
    1402           0 :                byte-compile-current-group)
    1403             :           ;; The group will be provided implicitly.
    1404             :           nil
    1405           0 :         (or (and (eq (car form) 'custom-declare-group)
    1406           0 :                  (equal name ''emacs))
    1407           0 :             (plist-get keyword-args :group)
    1408           0 :             (byte-compile-warn
    1409             :              "%s for `%s' fails to specify containing group"
    1410           0 :              (cdr (assq (car form)
    1411             :                         '((custom-declare-group . defgroup)
    1412             :                           (custom-declare-face . defface)
    1413           0 :                           (custom-declare-variable . defcustom))))
    1414           0 :              (cadr name)))
    1415             :         ;; Update the current group, if needed.
    1416           0 :         (if (and byte-compile-current-file ;Only when compiling a whole file.
    1417           0 :                  (eq (car form) 'custom-declare-group))
    1418           0 :             (setq byte-compile-current-group (cadr name)))))))
    1419             : 
    1420             : ;; Warn if the function or macro is being redefined with a different
    1421             : ;; number of arguments.
    1422             : (defun byte-compile-arglist-warn (name arglist macrop)
    1423             :   ;; This is the first definition.  See if previous calls are compatible.
    1424           0 :   (let ((calls (assq name byte-compile-unresolved-functions))
    1425             :         nums sig min max)
    1426           0 :     (when (and calls macrop)
    1427           0 :       (byte-compile-warn "macro `%s' defined too late" name))
    1428           0 :     (setq byte-compile-unresolved-functions
    1429           0 :           (delq calls byte-compile-unresolved-functions))
    1430           0 :     (setq calls (delq t calls))      ;Ignore higher-order uses of the function.
    1431           0 :     (when (cdr calls)
    1432           0 :       (when (and (symbolp name)
    1433           0 :                  (eq (function-get name 'byte-optimizer)
    1434           0 :                      'byte-compile-inline-expand))
    1435           0 :         (byte-compile-warn "defsubst `%s' was used before it was defined"
    1436           0 :                            name))
    1437           0 :       (setq sig (byte-compile-arglist-signature arglist)
    1438           0 :             nums (sort (copy-sequence (cdr calls)) (function <))
    1439           0 :             min (car nums)
    1440           0 :             max (car (nreverse nums)))
    1441           0 :       (when (or (< min (car sig))
    1442           0 :                 (and (cdr sig) (> max (cdr sig))))
    1443           0 :         (byte-compile-set-symbol-position name)
    1444           0 :         (byte-compile-warn
    1445             :          "%s being defined to take %s%s, but was previously called with %s"
    1446           0 :          name
    1447           0 :          (byte-compile-arglist-signature-string sig)
    1448           0 :          (if (equal sig '(1 . 1)) " arg" " args")
    1449           0 :          (byte-compile-arglist-signature-string (cons min max))))))
    1450           0 :   (let* ((old (byte-compile-fdefinition name macrop))
    1451           0 :          (initial (and macrop
    1452           0 :                        (cdr (assq name
    1453           0 :                                   byte-compile-initial-macro-environment)))))
    1454             :     ;; Assumes an element of b-c-i-macro-env that is a symbol points
    1455             :     ;; to a defined function.  (Bug#8646)
    1456           0 :     (and initial (symbolp initial)
    1457           0 :          (setq old (byte-compile-fdefinition initial nil)))
    1458           0 :     (when (and old (not (eq old t)))
    1459           0 :       (let ((sig1 (byte-compile--function-signature old))
    1460           0 :             (sig2 (byte-compile-arglist-signature arglist)))
    1461           0 :         (unless (byte-compile-arglist-signatures-congruent-p sig1 sig2)
    1462           0 :           (byte-compile-set-symbol-position name)
    1463           0 :           (byte-compile-warn
    1464             :            "%s %s used to take %s %s, now takes %s"
    1465           0 :            (if macrop "macro" "function")
    1466           0 :            name
    1467           0 :            (byte-compile-arglist-signature-string sig1)
    1468           0 :            (if (equal sig1 '(1 . 1)) "argument" "arguments")
    1469           0 :            (byte-compile-arglist-signature-string sig2)))))))
    1470             : 
    1471             : (defvar byte-compile-cl-functions nil
    1472             :   "List of functions defined in CL.")
    1473             : 
    1474             : ;; Can't just add this to cl-load-hook, because that runs just before
    1475             : ;; the forms from cl.el get added to load-history.
    1476             : (defun byte-compile-find-cl-functions ()
    1477          12 :   (unless byte-compile-cl-functions
    1478          10 :     (dolist (elt load-history)
    1479        2266 :       (and (byte-compile-cl-file-p (car elt))
    1480           1 :            (dolist (e (cdr elt))
    1481             :              ;; Includes the cl-foo functions that cl autoloads.
    1482         222 :              (when (memq (car-safe e) '(autoload defun))
    1483        2266 :                (push (cdr e) byte-compile-cl-functions)))))))
    1484             : 
    1485             : (defun byte-compile-cl-warn (form)
    1486             :   "Warn if FORM is a call of a function from the CL package."
    1487         201 :   (let ((func (car-safe form)))
    1488         201 :     (if (and byte-compile-cl-functions
    1489         131 :              (memq func byte-compile-cl-functions)
    1490             :              ;; Aliases which won't have been expanded at this point.
    1491             :              ;; These aren't all aliases of subrs, so not trivial to
    1492             :              ;; avoid hardwiring the list.
    1493           0 :              (not (memq func
    1494             :                         '(cl--block-wrapper cl--block-throw
    1495             :                           multiple-value-call nth-value
    1496             :                           copy-seq first second rest endp cl-member
    1497             :                           ;; These are included in generated code
    1498             :                           ;; that can't be called except at compile time
    1499             :                           ;; or unless cl is loaded anyway.
    1500             :                           cl--defsubst-expand cl-struct-setf-expander
    1501             :                           ;; These would sometimes be warned about
    1502             :                           ;; but such warnings are never useful,
    1503             :                           ;; so don't warn about them.
    1504             :                           macroexpand
    1505         201 :                           cl--compiling-file))))
    1506           0 :         (byte-compile-warn "function `%s' from cl package called at runtime"
    1507         201 :                            func)))
    1508         201 :   form)
    1509             : 
    1510             : (defun byte-compile-print-syms (str1 strn syms)
    1511           0 :   (when syms
    1512           0 :     (byte-compile-set-symbol-position (car syms) t))
    1513           0 :   (cond ((and (cdr syms) (not noninteractive))
    1514           0 :          (let* ((str strn)
    1515           0 :                 (L (length str))
    1516             :                 s)
    1517           0 :            (while syms
    1518           0 :              (setq s (symbol-name (pop syms))
    1519           0 :                    L (+ L (length s) 2))
    1520           0 :              (if (< L (1- fill-column))
    1521           0 :                  (setq str (concat str " " s (and syms ",")))
    1522           0 :                (setq str (concat str "\n    " s (and syms ","))
    1523           0 :                      L (+ (length s) 4))))
    1524           0 :            (byte-compile-warn "%s" str)))
    1525           0 :         ((cdr syms)
    1526           0 :          (byte-compile-warn "%s %s"
    1527           0 :                             strn
    1528           0 :                             (mapconcat #'symbol-name syms ", ")))
    1529             : 
    1530           0 :         (syms
    1531           0 :          (byte-compile-warn str1 (car syms)))))
    1532             : 
    1533             : ;; If we have compiled any calls to functions which are not known to be
    1534             : ;; defined, issue a warning enumerating them.
    1535             : ;; `unresolved' in the list `byte-compile-warnings' disables this.
    1536             : (defun byte-compile-warn-about-unresolved-functions ()
    1537           0 :   (when (byte-compile-warning-enabled-p 'unresolved)
    1538           0 :     (let ((byte-compile-current-form :end)
    1539             :           (noruntime nil)
    1540             :           (unresolved nil))
    1541             :       ;; Separate the functions that will not be available at runtime
    1542             :       ;; from the truly unresolved ones.
    1543           0 :       (dolist (f byte-compile-unresolved-functions)
    1544           0 :         (setq f (car f))
    1545           0 :         (when (not (memq f byte-compile-new-defuns))
    1546           0 :           (if (fboundp f) (push f noruntime) (push f unresolved))))
    1547             :       ;; Complain about the no-run-time functions
    1548           0 :       (byte-compile-print-syms
    1549             :        "the function `%s' might not be defined at runtime."
    1550             :        "the following functions might not be defined at runtime:"
    1551           0 :        noruntime)
    1552             :       ;; Complain about the unresolved functions
    1553           0 :       (byte-compile-print-syms
    1554             :        "the function `%s' is not known to be defined."
    1555             :        "the following functions are not known to be defined:"
    1556           0 :        unresolved)))
    1557             :   nil)
    1558             : 
    1559             : 
    1560             : ;; Dynamically bound in byte-compile-from-buffer.
    1561             : ;; NB also used in cl.el and cl-macs.el.
    1562             : (defvar byte-compile--outbuffer)
    1563             : 
    1564             : (defmacro byte-compile-close-variables (&rest body)
    1565             :   (declare (debug t))
    1566           3 :   `(let (;;
    1567             :          ;; Close over these variables to encapsulate the
    1568             :          ;; compilation state
    1569             :          ;;
    1570             :          (byte-compile-macro-environment
    1571             :           ;; Copy it because the compiler may patch into the
    1572             :           ;; macroenvironment.
    1573             :           (copy-alist byte-compile-initial-macro-environment))
    1574             :          (byte-compile--outbuffer nil)
    1575             :          (overriding-plist-environment nil)
    1576             :          (byte-compile-function-environment nil)
    1577             :          (byte-compile-bound-variables nil)
    1578             :          (byte-compile-lexical-variables nil)
    1579             :          (byte-compile-const-variables nil)
    1580             :          (byte-compile-free-references nil)
    1581             :          (byte-compile-free-assignments nil)
    1582             :          ;;
    1583             :          ;; Close over these variables so that `byte-compiler-options'
    1584             :          ;; can change them on a per-file basis.
    1585             :          ;;
    1586             :          (byte-compile-verbose byte-compile-verbose)
    1587             :          (byte-optimize byte-optimize)
    1588             :          (byte-compile-dynamic byte-compile-dynamic)
    1589             :          (byte-compile-dynamic-docstrings
    1590             :           byte-compile-dynamic-docstrings)
    1591             :          ;;             (byte-compile-generate-emacs19-bytecodes
    1592             :          ;;              byte-compile-generate-emacs19-bytecodes)
    1593             :          (byte-compile-warnings byte-compile-warnings)
    1594             :          )
    1595           3 :      ,@body))
    1596             : 
    1597             : (defmacro displaying-byte-compile-warnings (&rest body)
    1598             :   (declare (debug t))
    1599           5 :   `(let* ((--displaying-byte-compile-warnings-fn (lambda () ,@body))
    1600             :           (warning-series-started
    1601             :            (and (markerp warning-series)
    1602             :                 (eq (marker-buffer warning-series)
    1603             :                     (get-buffer byte-compile-log-buffer)))))
    1604             :      (byte-compile-find-cl-functions)
    1605             :      (if (or (eq warning-series 'byte-compile-warning-series)
    1606             :              warning-series-started)
    1607             :          ;; warning-series does come from compilation,
    1608             :          ;; so don't bind it, but maybe do set it.
    1609             :          (let (tem)
    1610             :            ;; Log the file name.  Record position of that text.
    1611             :            (setq tem (byte-compile-log-file))
    1612             :            (unless warning-series-started
    1613             :              (setq warning-series (or tem 'byte-compile-warning-series)))
    1614             :            (if byte-compile-debug
    1615             :                (funcall --displaying-byte-compile-warnings-fn)
    1616             :              (condition-case error-info
    1617             :                  (funcall --displaying-byte-compile-warnings-fn)
    1618             :                (error (byte-compile-report-error error-info)))))
    1619             :        ;; warning-series does not come from compilation, so bind it.
    1620             :        (let ((warning-series
    1621             :               ;; Log the file name.  Record position of that text.
    1622             :               (or (byte-compile-log-file) 'byte-compile-warning-series)))
    1623             :          (if byte-compile-debug
    1624             :              (funcall --displaying-byte-compile-warnings-fn)
    1625             :            (condition-case error-info
    1626             :                (funcall --displaying-byte-compile-warnings-fn)
    1627           5 :              (error (byte-compile-report-error error-info))))))))
    1628             : 
    1629             : ;;;###autoload
    1630             : (defun byte-force-recompile (directory)
    1631             :   "Recompile every `.el' file in DIRECTORY that already has a `.elc' file.
    1632             : Files in subdirectories of DIRECTORY are processed also."
    1633             :   (interactive "DByte force recompile (directory): ")
    1634           0 :   (byte-recompile-directory directory nil t))
    1635             : 
    1636             : ;;;###autoload
    1637             : (defun byte-recompile-directory (directory &optional arg force)
    1638             :   "Recompile every `.el' file in DIRECTORY that needs recompilation.
    1639             : This happens when a `.elc' file exists but is older than the `.el' file.
    1640             : Files in subdirectories of DIRECTORY are processed also.
    1641             : 
    1642             : If the `.elc' file does not exist, normally this function *does not*
    1643             : compile the corresponding `.el' file.  However, if the prefix argument
    1644             : ARG is 0, that means do compile all those files.  A nonzero
    1645             : ARG means ask the user, for each such `.el' file, whether to
    1646             : compile it.  A nonzero ARG also means ask about each subdirectory
    1647             : before scanning it.
    1648             : 
    1649             : If the third argument FORCE is non-nil, recompile every `.el' file
    1650             : that already has a `.elc' file."
    1651             :   (interactive "DByte recompile directory: \nP")
    1652           0 :   (if arg (setq arg (prefix-numeric-value arg)))
    1653           0 :   (if noninteractive
    1654             :       nil
    1655           0 :     (save-some-buffers
    1656             :      nil (lambda ()
    1657           0 :            (let ((file (buffer-file-name)))
    1658           0 :              (and file
    1659           0 :                   (string-match-p emacs-lisp-file-regexp file)
    1660           0 :                   (file-in-directory-p file directory)))))
    1661           0 :     (force-mode-line-update))
    1662           0 :   (with-current-buffer (get-buffer-create byte-compile-log-buffer)
    1663           0 :     (setq default-directory (expand-file-name directory))
    1664             :     ;; compilation-mode copies value of default-directory.
    1665           0 :     (unless (eq major-mode 'compilation-mode)
    1666           0 :       (compilation-mode))
    1667           0 :     (let ((directories (list default-directory))
    1668           0 :           (default-directory default-directory)
    1669             :           (skip-count 0)
    1670             :           (fail-count 0)
    1671             :           (file-count 0)
    1672             :           (dir-count 0)
    1673             :           last-dir)
    1674           0 :       (displaying-byte-compile-warnings
    1675           0 :        (while directories
    1676           0 :          (setq directory (car directories))
    1677           0 :          (message "Checking %s..." directory)
    1678           0 :          (dolist (file (directory-files directory))
    1679           0 :            (let ((source (expand-file-name file directory)))
    1680           0 :              (if (file-directory-p source)
    1681           0 :                  (and (not (member file '("RCS" "CVS")))
    1682           0 :                       (not (eq ?\. (aref file 0)))
    1683           0 :                       (not (file-symlink-p source))
    1684             :                       ;; This file is a subdirectory.  Handle them differently.
    1685           0 :                       (or (null arg) (eq 0 arg)
    1686           0 :                           (y-or-n-p (concat "Check " source "? ")))
    1687           0 :                       (setq directories (nconc directories (list source))))
    1688             :                ;; It is an ordinary file.  Decide whether to compile it.
    1689           0 :                (if (and (string-match emacs-lisp-file-regexp source)
    1690             :                         ;; The next 2 tests avoid compiling lock files
    1691           0 :                         (file-readable-p source)
    1692           0 :                         (not (string-match "\\`\\.#" file))
    1693           0 :                         (not (auto-save-file-name-p source))
    1694           0 :                         (not (string-equal dir-locals-file
    1695           0 :                                            (file-name-nondirectory source))))
    1696           0 :                    (progn (cl-incf
    1697           0 :                            (pcase (byte-recompile-file source force arg)
    1698           0 :                              (`no-byte-compile skip-count)
    1699           0 :                              (`t file-count)
    1700           0 :                              (_ fail-count)))
    1701           0 :                           (or noninteractive
    1702           0 :                               (message "Checking %s..." directory))
    1703           0 :                           (if (not (eq last-dir directory))
    1704           0 :                               (setq last-dir directory
    1705           0 :                                     dir-count (1+ dir-count)))
    1706           0 :                           )))))
    1707           0 :          (setq directories (cdr directories))))
    1708           0 :       (message "Done (Total of %d file%s compiled%s%s%s)"
    1709           0 :                file-count (if (= file-count 1) "" "s")
    1710           0 :                (if (> fail-count 0) (format ", %d failed" fail-count) "")
    1711           0 :                (if (> skip-count 0) (format ", %d skipped" skip-count) "")
    1712           0 :                (if (> dir-count 1)
    1713           0 :                    (format " in %d directories" dir-count) "")))))
    1714             : 
    1715             : (defvar no-byte-compile nil
    1716             :   "Non-nil to prevent byte-compiling of Emacs Lisp code.
    1717             : This is normally set in local file variables at the end of the elisp file:
    1718             : 
    1719             : \;; Local Variables:\n;; no-byte-compile: t\n;; End: ") ;Backslash for compile-main.
    1720             : ;;;###autoload(put 'no-byte-compile 'safe-local-variable 'booleanp)
    1721             : 
    1722             : (defun byte-recompile-file (filename &optional force arg load)
    1723             :   "Recompile FILENAME file if it needs recompilation.
    1724             : This happens when its `.elc' file is older than itself.
    1725             : 
    1726             : If the `.elc' file exists and is up-to-date, normally this function
    1727             : *does not* compile FILENAME.  If the prefix argument FORCE is non-nil,
    1728             : however, it compiles FILENAME even if the destination already
    1729             : exists and is up-to-date.
    1730             : 
    1731             : If the `.elc' file does not exist, normally this function *does not*
    1732             : compile FILENAME.  If optional argument ARG is 0, it compiles
    1733             : the input file even if the `.elc' file does not exist.
    1734             : Any other non-nil value of ARG means to ask the user.
    1735             : 
    1736             : If optional argument LOAD is non-nil, loads the file after compiling.
    1737             : 
    1738             : If compilation is needed, this functions returns the result of
    1739             : `byte-compile-file'; otherwise it returns `no-byte-compile'."
    1740             :   (interactive
    1741           0 :    (let ((file buffer-file-name)
    1742             :          (file-name nil)
    1743             :          (file-dir nil))
    1744           0 :      (and file
    1745           0 :           (derived-mode-p 'emacs-lisp-mode)
    1746           0 :           (setq file-name (file-name-nondirectory file)
    1747           0 :                 file-dir (file-name-directory file)))
    1748           0 :      (list (read-file-name (if current-prefix-arg
    1749             :                                "Byte compile file: "
    1750           0 :                              "Byte recompile file: ")
    1751           0 :                            file-dir file-name nil)
    1752           0 :            current-prefix-arg)))
    1753           0 :   (let ((dest (byte-compile-dest-file filename))
    1754             :         ;; Expand now so we get the current buffer's defaults
    1755           0 :         (filename (expand-file-name filename)))
    1756           0 :     (if (if (file-exists-p dest)
    1757             :             ;; File was already compiled
    1758             :             ;; Compile if forced to, or filename newer
    1759           0 :             (or force
    1760           0 :                 (file-newer-than-file-p filename dest))
    1761           0 :           (and arg
    1762           0 :                (or (eq 0 arg)
    1763           0 :                    (y-or-n-p (concat "Compile "
    1764           0 :                                      filename "? ")))))
    1765           0 :         (progn
    1766           0 :           (if (and noninteractive (not byte-compile-verbose))
    1767           0 :               (message "Compiling %s..." filename))
    1768           0 :           (byte-compile-file filename load))
    1769           0 :       (when load
    1770           0 :         (load (if (file-exists-p dest) dest filename)))
    1771           0 :       'no-byte-compile)))
    1772             : 
    1773             : (defvar byte-compile-level 0            ; bug#13787
    1774             :   "Depth of a recursive byte compilation.")
    1775             : 
    1776             : ;;;###autoload
    1777             : (defun byte-compile-file (filename &optional load)
    1778             :   "Compile a file of Lisp code named FILENAME into a file of byte code.
    1779             : The output file's name is generated by passing FILENAME to the
    1780             : function `byte-compile-dest-file' (which see).
    1781             : With prefix arg (noninteractively: 2nd arg), LOAD the file after compiling.
    1782             : The value is non-nil if there were no errors, nil if errors."
    1783             : ;;  (interactive "fByte compile file: \nP")
    1784             :   (interactive
    1785           0 :    (let ((file buffer-file-name)
    1786             :          (file-dir nil))
    1787           0 :      (and file
    1788           0 :           (derived-mode-p 'emacs-lisp-mode)
    1789           0 :           (setq file-dir (file-name-directory file)))
    1790           0 :      (list (read-file-name (if current-prefix-arg
    1791             :                                "Byte compile and load file: "
    1792           0 :                              "Byte compile file: ")
    1793           0 :                            file-dir buffer-file-name nil)
    1794           0 :            current-prefix-arg)))
    1795             :   ;; Expand now so we get the current buffer's defaults
    1796           0 :   (setq filename (expand-file-name filename))
    1797             : 
    1798             :   ;; If we're compiling a file that's in a buffer and is modified, offer
    1799             :   ;; to save it first.
    1800           0 :   (or noninteractive
    1801           0 :       (let ((b (get-file-buffer (expand-file-name filename))))
    1802           0 :         (if (and b (buffer-modified-p b)
    1803           0 :                  (y-or-n-p (format "Save buffer %s first? " (buffer-name b))))
    1804           0 :             (with-current-buffer b (save-buffer)))))
    1805             : 
    1806             :   ;; Force logging of the file name for each file compiled.
    1807           0 :   (setq byte-compile-last-logged-file nil)
    1808           0 :   (let ((byte-compile-current-file filename)
    1809             :         (byte-compile-current-group nil)
    1810             :         (set-auto-coding-for-load t)
    1811             :         target-file input-buffer output-buffer
    1812             :         byte-compile-dest-file)
    1813           0 :     (setq target-file (byte-compile-dest-file filename))
    1814           0 :     (setq byte-compile-dest-file target-file)
    1815           0 :     (with-current-buffer
    1816             :         ;; It would be cleaner to use a temp buffer, but if there was
    1817             :         ;; an error, we leave this buffer around for diagnostics.
    1818             :         ;; Its name is documented in the lispref.
    1819           0 :         (setq input-buffer (get-buffer-create
    1820           0 :                             (concat " *Compiler Input*"
    1821           0 :                                     (if (zerop byte-compile-level) ""
    1822           0 :                                       (format "-%s" byte-compile-level)))))
    1823           0 :       (erase-buffer)
    1824           0 :       (setq buffer-file-coding-system nil)
    1825             :       ;; Always compile an Emacs Lisp file as multibyte
    1826             :       ;; unless the file itself forces unibyte with -*-coding: raw-text;-*-
    1827           0 :       (set-buffer-multibyte t)
    1828           0 :       (insert-file-contents filename)
    1829             :       ;; Mimic the way after-insert-file-set-coding can make the
    1830             :       ;; buffer unibyte when visiting this file.
    1831           0 :       (when (or (eq last-coding-system-used 'no-conversion)
    1832           0 :                 (eq (coding-system-type last-coding-system-used) 5))
    1833             :         ;; For coding systems no-conversion and raw-text...,
    1834             :         ;; edit the buffer as unibyte.
    1835           0 :         (set-buffer-multibyte nil))
    1836             :       ;; Run hooks including the uncompression hook.
    1837             :       ;; If they change the file name, then change it for the output also.
    1838           0 :       (let ((buffer-file-name filename)
    1839           0 :             (dmm (default-value 'major-mode))
    1840             :             ;; Ignore unsafe local variables.
    1841             :             ;; We only care about a few of them for our purposes.
    1842             :             (enable-local-variables :safe)
    1843             :             (enable-local-eval nil))
    1844           0 :         (unwind-protect
    1845           0 :             (progn
    1846           0 :               (setq-default major-mode 'emacs-lisp-mode)
    1847             :               ;; Arg of t means don't alter enable-local-variables.
    1848           0 :               (delay-mode-hooks (normal-mode t)))
    1849           0 :           (setq-default major-mode dmm))
    1850             :         ;; There may be a file local variable setting (bug#10419).
    1851           0 :         (setq buffer-read-only nil
    1852           0 :               filename buffer-file-name))
    1853             :       ;; Don't inherit lexical-binding from caller (bug#12938).
    1854           0 :       (unless (local-variable-p 'lexical-binding)
    1855           0 :         (setq-local lexical-binding nil))
    1856             :       ;; Set the default directory, in case an eval-when-compile uses it.
    1857           0 :       (setq default-directory (file-name-directory filename)))
    1858             :     ;; Check if the file's local variables explicitly specify not to
    1859             :     ;; compile this file.
    1860           0 :     (if (with-current-buffer input-buffer no-byte-compile)
    1861           0 :         (progn
    1862             :           ;; (message "%s not compiled because of `no-byte-compile: %s'"
    1863             :           ;;       (byte-compile-abbreviate-file filename)
    1864             :           ;;       (with-current-buffer input-buffer no-byte-compile))
    1865           0 :           (when (file-exists-p target-file)
    1866           0 :             (message "%s deleted because of `no-byte-compile: %s'"
    1867           0 :                      (byte-compile-abbreviate-file target-file)
    1868           0 :                      (buffer-local-value 'no-byte-compile input-buffer))
    1869           0 :             (condition-case nil (delete-file target-file) (error nil)))
    1870             :           ;; We successfully didn't compile this file.
    1871           0 :           'no-byte-compile)
    1872           0 :       (when byte-compile-verbose
    1873           0 :         (message "Compiling %s..." filename))
    1874           0 :       (setq byte-compiler-error-flag nil)
    1875             :       ;; It is important that input-buffer not be current at this call,
    1876             :       ;; so that the value of point set in input-buffer
    1877             :       ;; within byte-compile-from-buffer lingers in that buffer.
    1878           0 :       (setq output-buffer
    1879           0 :             (save-current-buffer
    1880           0 :               (let ((byte-compile-level (1+ byte-compile-level)))
    1881           0 :                 (byte-compile-from-buffer input-buffer))))
    1882           0 :       (if byte-compiler-error-flag
    1883             :           nil
    1884           0 :         (when byte-compile-verbose
    1885           0 :           (message "Compiling %s...done" filename))
    1886           0 :         (kill-buffer input-buffer)
    1887           0 :         (with-current-buffer output-buffer
    1888           0 :           (goto-char (point-max))
    1889           0 :           (insert "\n")                       ; aaah, unix.
    1890           0 :           (if (file-writable-p target-file)
    1891             :               ;; We must disable any code conversion here.
    1892           0 :               (progn
    1893           0 :                 (let* ((coding-system-for-write 'no-conversion)
    1894             :                        ;; Write to a tempfile so that if another Emacs
    1895             :                        ;; process is trying to load target-file (eg in a
    1896             :                        ;; parallel bootstrap), it does not risk getting a
    1897             :                        ;; half-finished file.  (Bug#4196)
    1898           0 :                        (tempfile (make-temp-file target-file))
    1899             :                        (kill-emacs-hook
    1900           0 :                         (cons (lambda () (ignore-errors
    1901           0 :                                            (delete-file tempfile)))
    1902           0 :                               kill-emacs-hook)))
    1903           0 :                   (write-region (point-min) (point-max) tempfile nil 1)
    1904             :                   ;; This has the intentional side effect that any
    1905             :                   ;; hard-links to target-file continue to
    1906             :                   ;; point to the old file (this makes it possible
    1907             :                   ;; for installed files to share disk space with
    1908             :                   ;; the build tree, without causing problems when
    1909             :                   ;; emacs-lisp files in the build tree are
    1910             :                   ;; recompiled).  Previously this was accomplished by
    1911             :                   ;; deleting target-file before writing it.
    1912           0 :                   (rename-file tempfile target-file t))
    1913           0 :                 (or noninteractive (message "Wrote %s" target-file)))
    1914             :             ;; This is just to give a better error message than write-region
    1915           0 :             (let ((exists (file-exists-p target-file)))
    1916           0 :               (signal (if exists 'file-error 'file-missing)
    1917           0 :                       (list "Opening output file"
    1918           0 :                             (if exists
    1919             :                                 "Cannot overwrite file"
    1920           0 :                               "Directory not writable or nonexistent")
    1921           0 :                             target-file))))
    1922           0 :           (kill-buffer (current-buffer)))
    1923           0 :         (if (and byte-compile-generate-call-tree
    1924           0 :                  (or (eq t byte-compile-generate-call-tree)
    1925           0 :                      (y-or-n-p (format "Report call tree for %s? "
    1926           0 :                                        filename))))
    1927           0 :             (save-excursion
    1928           0 :               (display-call-tree filename)))
    1929           0 :         (if load
    1930           0 :             (load target-file))
    1931           0 :         t))))
    1932             : 
    1933             : ;;; compiling a single function
    1934             : ;;;###autoload
    1935             : (defun compile-defun (&optional arg)
    1936             :   "Compile and evaluate the current top-level form.
    1937             : Print the result in the echo area.
    1938             : With argument ARG, insert value in current buffer after the form."
    1939             :   (interactive "P")
    1940           0 :   (save-excursion
    1941           0 :     (end-of-defun)
    1942           0 :     (beginning-of-defun)
    1943           0 :     (let* ((byte-compile-current-file nil)
    1944           0 :            (byte-compile-current-buffer (current-buffer))
    1945           0 :            (byte-compile-read-position (point))
    1946           0 :            (byte-compile-last-position byte-compile-read-position)
    1947             :            (byte-compile-last-warned-form 'nothing)
    1948           0 :            (value (eval
    1949           0 :                    (let ((read-with-symbol-positions (current-buffer))
    1950             :                          (read-symbol-positions-list nil))
    1951           0 :                      (displaying-byte-compile-warnings
    1952           0 :                       (byte-compile-sexp
    1953           0 :                        (eval-sexp-add-defvars
    1954           0 :                         (read (current-buffer))
    1955           0 :                         byte-compile-read-position))))
    1956           0 :                    lexical-binding)))
    1957           0 :       (cond (arg
    1958           0 :              (message "Compiling from buffer... done.")
    1959           0 :              (prin1 value (current-buffer))
    1960           0 :              (insert "\n"))
    1961           0 :             ((message "%s" (prin1-to-string value)))))))
    1962             : 
    1963             : (defun byte-compile-from-buffer (inbuffer)
    1964           0 :   (let ((byte-compile-current-buffer inbuffer)
    1965             :         (byte-compile-read-position nil)
    1966             :         (byte-compile-last-position nil)
    1967             :         ;; Prevent truncation of flonums and lists as we read and print them
    1968             :         (float-output-format nil)
    1969             :         (case-fold-search nil)
    1970             :         (print-length nil)
    1971             :         (print-level nil)
    1972             :         ;; Prevent edebug from interfering when we compile
    1973             :         ;; and put the output into a file.
    1974             : ;;      (edebug-all-defs nil)
    1975             : ;;      (edebug-all-forms nil)
    1976             :         ;; Simulate entry to byte-compile-top-level
    1977             :         (byte-compile-jump-tables nil)
    1978             :         (byte-compile-constants nil)
    1979             :         (byte-compile-variables nil)
    1980             :         (byte-compile-tag-number 0)
    1981             :         (byte-compile-depth 0)
    1982             :         (byte-compile-maxdepth 0)
    1983             :         (byte-compile-output nil)
    1984             :         ;; This allows us to get the positions of symbols read; it's
    1985             :         ;; new in Emacs 22.1.
    1986           0 :         (read-with-symbol-positions inbuffer)
    1987             :         (read-symbol-positions-list nil)
    1988             :         ;;        #### This is bound in b-c-close-variables.
    1989             :         ;;        (byte-compile-warnings byte-compile-warnings)
    1990             :         )
    1991           0 :     (byte-compile-close-variables
    1992           0 :      (with-current-buffer
    1993           0 :          (setq byte-compile--outbuffer
    1994           0 :                (get-buffer-create
    1995           0 :                 (concat " *Compiler Output*"
    1996           0 :                         (if (<= byte-compile-level 1) ""
    1997           0 :                           (format "-%s" (1- byte-compile-level))))))
    1998           0 :        (set-buffer-multibyte t)
    1999           0 :        (erase-buffer)
    2000             :        ;;        (emacs-lisp-mode)
    2001           0 :        (setq case-fold-search nil))
    2002           0 :      (displaying-byte-compile-warnings
    2003           0 :       (with-current-buffer inbuffer
    2004           0 :         (and byte-compile-current-file
    2005           0 :              (byte-compile-insert-header byte-compile-current-file
    2006           0 :                                          byte-compile--outbuffer))
    2007           0 :         (goto-char (point-min))
    2008             :         ;; Should we always do this?  When calling multiple files, it
    2009             :         ;; would be useful to delay this warning until all have been
    2010             :         ;; compiled.  A: Yes!  b-c-u-f might contain dross from a
    2011             :         ;; previous byte-compile.
    2012           0 :         (setq byte-compile-unresolved-functions nil)
    2013           0 :         (setq byte-compile-noruntime-functions nil)
    2014           0 :         (setq byte-compile-new-defuns nil)
    2015             : 
    2016             :         ;; Compile the forms from the input buffer.
    2017           0 :         (while (progn
    2018           0 :                  (while (progn (skip-chars-forward " \t\n\^l")
    2019           0 :                                (= (following-char) ?\;))
    2020           0 :                    (forward-line 1))
    2021           0 :                  (not (eobp)))
    2022           0 :           (setq byte-compile-read-position (point)
    2023           0 :                 byte-compile-last-position byte-compile-read-position)
    2024           0 :           (let* ((lread--old-style-backquotes nil)
    2025             :                  (lread--unescaped-character-literals nil)
    2026           0 :                  (form (read inbuffer)))
    2027             :             ;; Warn about the use of old-style backquotes.
    2028           0 :             (when lread--old-style-backquotes
    2029           0 :               (byte-compile-warn "!! The file uses old-style backquotes !!
    2030             : This functionality has been obsolete for more than 10 years already
    2031           0 : and will be removed soon.  See (elisp)Backquote in the manual."))
    2032           0 :             (when lread--unescaped-character-literals
    2033           0 :               (byte-compile-warn
    2034             :                "unescaped character literals %s detected!"
    2035           0 :                (mapconcat (lambda (char) (format "`?%c'" char))
    2036           0 :                           (sort lread--unescaped-character-literals #'<)
    2037           0 :                           ", ")))
    2038           0 :             (byte-compile-toplevel-file-form form)))
    2039             :         ;; Compile pending forms at end of file.
    2040           0 :         (byte-compile-flush-pending)
    2041             :         ;; Make warnings about unresolved functions
    2042             :         ;; give the end of the file as their position.
    2043           0 :         (setq byte-compile-last-position (point-max))
    2044           0 :         (byte-compile-warn-about-unresolved-functions))
    2045             :       ;; Fix up the header at the front of the output
    2046             :       ;; if the buffer contains multibyte characters.
    2047           0 :       (and byte-compile-current-file
    2048           0 :            (with-current-buffer byte-compile--outbuffer
    2049           0 :              (byte-compile-fix-header byte-compile-current-file))))
    2050           0 :      byte-compile--outbuffer)))
    2051             : 
    2052             : (defun byte-compile-fix-header (_filename)
    2053             :   "If the current buffer has any multibyte characters, insert a version test."
    2054           0 :   (when (< (point-max) (position-bytes (point-max)))
    2055           0 :     (goto-char (point-min))
    2056             :     ;; Find the comment that describes the version condition.
    2057           0 :     (search-forward "\n;;; This file uses")
    2058           0 :     (narrow-to-region (line-beginning-position) (point-max))
    2059             :     ;; Find the first line of ballast semicolons.
    2060           0 :     (search-forward ";;;;;;;;;;")
    2061           0 :     (beginning-of-line)
    2062           0 :     (narrow-to-region (point-min) (point))
    2063           0 :     (let ((old-header-end (point))
    2064             :           (minimum-version "23")
    2065             :           delta)
    2066           0 :       (delete-region (point-min) (point-max))
    2067           0 :       (insert
    2068             :        ";;; This file contains utf-8 non-ASCII characters,\n"
    2069             :        ";;; and so cannot be loaded into Emacs 22 or earlier.\n"
    2070             :        ;; Have to check if emacs-version is bound so that this works
    2071             :        ;; in files loaded early in loadup.el.
    2072             :        "(and (boundp 'emacs-version)\n"
    2073             :        ;; If there is a name at the end of emacs-version,
    2074             :        ;; don't try to check the version number.
    2075             :        "     (< (aref emacs-version (1- (length emacs-version))) ?A)\n"
    2076           0 :        (format "     (string-lessp emacs-version \"%s\")\n" minimum-version)
    2077             :        ;; Because the header must fit in a fixed width, we cannot
    2078             :        ;; insert arbitrary-length file names (Bug#11585).
    2079             :        "     (error \"`%s' was compiled for "
    2080           0 :        (format "Emacs %s or later\" #$))\n\n" minimum-version))
    2081             :       ;; Now compensate for any change in size, to make sure all
    2082             :       ;; positions in the file remain valid.
    2083           0 :       (setq delta (- (point-max) old-header-end))
    2084           0 :       (goto-char (point-max))
    2085           0 :       (widen)
    2086           0 :       (delete-char delta))))
    2087             : 
    2088             : (defun byte-compile-insert-header (_filename outbuffer)
    2089             :   "Insert a header at the start of OUTBUFFER.
    2090             : Call from the source buffer."
    2091           0 :   (let ((dynamic-docstrings byte-compile-dynamic-docstrings)
    2092           0 :         (dynamic byte-compile-dynamic)
    2093           0 :         (optimize byte-optimize))
    2094           0 :     (with-current-buffer outbuffer
    2095           0 :       (goto-char (point-min))
    2096             :       ;; The magic number of .elc files is ";ELC", or 0x3B454C43.  After
    2097             :       ;; that is the file-format version number (18, 19, 20, or 23) as a
    2098             :       ;; byte, followed by some nulls.  The primary motivation for doing
    2099             :       ;; this is to get some binary characters up in the first line of
    2100             :       ;; the file so that `diff' will simply say "Binary files differ"
    2101             :       ;; instead of actually doing a diff of two .elc files.  An extra
    2102             :       ;; benefit is that you can add this to /etc/magic:
    2103             :       ;; 0      string          ;ELC            GNU Emacs Lisp compiled file,
    2104             :       ;; >4  byte            x               version %d
    2105           0 :       (insert
    2106             :        ";ELC" 23 "\000\000\000\n"
    2107             :        ";;; Compiled\n"
    2108           0 :        ";;; in Emacs version " emacs-version "\n"
    2109             :        ";;; with"
    2110           0 :        (cond
    2111           0 :         ((eq optimize 'source) " source-level optimization only")
    2112           0 :         ((eq optimize 'byte) " byte-level optimization only")
    2113           0 :         (optimize " all optimizations")
    2114           0 :         (t "out optimization"))
    2115             :        ".\n"
    2116           0 :        (if dynamic ";;; Function definitions are lazy-loaded.\n"
    2117           0 :          "")
    2118             :        "\n;;; This file uses "
    2119           0 :        (if dynamic-docstrings
    2120             :            "dynamic docstrings, first added in Emacs 19.29"
    2121           0 :          "opcodes that do not exist in Emacs 18")
    2122             :        ".\n\n"
    2123             :        ;; Note that byte-compile-fix-header may change this.
    2124             :        ";;; This file does not contain utf-8 non-ASCII characters,\n"
    2125             :        ";;; and so can be loaded in Emacs versions earlier than 23.\n\n"
    2126             :        ;; Insert semicolons as ballast, so that byte-compile-fix-header
    2127             :        ;; can delete them so as to keep the buffer positions
    2128             :        ;; constant for the actual compiled code.
    2129             :        ";;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;\n"
    2130           0 :        ";;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;\n\n"))))
    2131             : 
    2132             : (defun byte-compile-output-file-form (form)
    2133             :   ;; Write the given form to the output buffer, being careful of docstrings
    2134             :   ;; in defvar, defvaralias, defconst, autoload and
    2135             :   ;; custom-declare-variable because make-docfile is so amazingly stupid.
    2136             :   ;; defalias calls are output directly by byte-compile-file-form-defmumble;
    2137             :   ;; it does not pay to first build the defalias in defmumble and then parse
    2138             :   ;; it here.
    2139           0 :   (let ((print-escape-newlines t)
    2140             :         (print-length nil)
    2141             :         (print-level nil)
    2142             :         (print-quoted t)
    2143             :         (print-gensym t)
    2144             :         (print-circle                   ; Handle circular data structures.
    2145           0 :          (not byte-compile-disable-print-circle)))
    2146           0 :     (if (and (memq (car-safe form) '(defvar defvaralias defconst
    2147           0 :                                       autoload custom-declare-variable))
    2148           0 :              (stringp (nth 3 form)))
    2149           0 :         (byte-compile-output-docform nil nil '("\n(" 3 ")") form nil
    2150           0 :                                      (memq (car form)
    2151             :                                            '(defvaralias autoload
    2152           0 :                                               custom-declare-variable)))
    2153           0 :       (princ "\n" byte-compile--outbuffer)
    2154           0 :       (prin1 form byte-compile--outbuffer)
    2155           0 :       nil)))
    2156             : 
    2157             : (defvar byte-compile--for-effect)
    2158             : 
    2159             : (defun byte-compile-output-docform (preface name info form specindex quoted)
    2160             :   "Print a form with a doc string.  INFO is (prefix doc-index postfix).
    2161             : If PREFACE and NAME are non-nil, print them too,
    2162             : before INFO and the FORM but after the doc string itself.
    2163             : If SPECINDEX is non-nil, it is the index in FORM
    2164             : of the function bytecode string.  In that case,
    2165             : we output that argument and the following argument
    2166             : \(the constants vector) together, for lazy loading.
    2167             : QUOTED says that we have to put a quote before the
    2168             : list that represents a doc string reference.
    2169             : `defvaralias', `autoload' and `custom-declare-variable' need that."
    2170             :   ;; We need to examine byte-compile-dynamic-docstrings
    2171             :   ;; in the input buffer (now current), not in the output buffer.
    2172           0 :   (let ((dynamic-docstrings byte-compile-dynamic-docstrings))
    2173           0 :     (with-current-buffer byte-compile--outbuffer
    2174           0 :       (let (position)
    2175             : 
    2176             :         ;; Insert the doc string, and make it a comment with #@LENGTH.
    2177           0 :         (and (>= (nth 1 info) 0)
    2178           0 :              dynamic-docstrings
    2179           0 :              (progn
    2180             :                ;; Make the doc string start at beginning of line
    2181             :                ;; for make-docfile's sake.
    2182           0 :                (insert "\n")
    2183           0 :                (setq position
    2184           0 :                      (byte-compile-output-as-comment
    2185           0 :                       (nth (nth 1 info) form) nil))
    2186             :                ;; If the doc string starts with * (a user variable),
    2187             :                ;; negate POSITION.
    2188           0 :                (if (and (stringp (nth (nth 1 info) form))
    2189           0 :                         (> (length (nth (nth 1 info) form)) 0)
    2190           0 :                         (eq (aref (nth (nth 1 info) form) 0) ?*))
    2191           0 :                    (setq position (- position)))))
    2192             : 
    2193           0 :         (let ((print-continuous-numbering t)
    2194             :               print-number-table
    2195             :               (index 0)
    2196             :               ;; FIXME: The bindings below are only needed for when we're
    2197             :               ;; called from ...-defmumble.
    2198             :               (print-escape-newlines t)
    2199             :               (print-length nil)
    2200             :               (print-level nil)
    2201             :               (print-quoted t)
    2202             :               (print-gensym t)
    2203             :               (print-circle             ; Handle circular data structures.
    2204           0 :                (not byte-compile-disable-print-circle)))
    2205           0 :           (if preface
    2206           0 :               (progn
    2207             :                 ;; FIXME: We don't handle uninterned names correctly.
    2208             :                 ;; E.g. if cl-define-compiler-macro uses uninterned name we get:
    2209             :                 ;;    (defalias '#1=#:foo--cmacro #[514 ...])
    2210             :                 ;;    (put 'foo 'compiler-macro '#:foo--cmacro)
    2211           0 :                 (insert preface)
    2212           0 :                 (prin1 name byte-compile--outbuffer)))
    2213           0 :           (insert (car info))
    2214           0 :           (prin1 (car form) byte-compile--outbuffer)
    2215           0 :           (while (setq form (cdr form))
    2216           0 :             (setq index (1+ index))
    2217           0 :             (insert " ")
    2218           0 :             (cond ((and (numberp specindex) (= index specindex)
    2219             :                         ;; Don't handle the definition dynamically
    2220             :                         ;; if it refers (or might refer)
    2221             :                         ;; to objects already output
    2222             :                         ;; (for instance, gensyms in the arg list).
    2223           0 :                         (let (non-nil)
    2224           0 :                           (when (hash-table-p print-number-table)
    2225           0 :                             (maphash (lambda (_k v) (if v (setq non-nil t)))
    2226           0 :                                      print-number-table))
    2227           0 :                           (not non-nil)))
    2228             :                    ;; Output the byte code and constants specially
    2229             :                    ;; for lazy dynamic loading.
    2230           0 :                    (let ((position
    2231           0 :                           (byte-compile-output-as-comment
    2232           0 :                            (cons (car form) (nth 1 form))
    2233           0 :                            t)))
    2234           0 :                      (princ (format "(#$ . %d) nil" position)
    2235           0 :                             byte-compile--outbuffer)
    2236           0 :                      (setq form (cdr form))
    2237           0 :                      (setq index (1+ index))))
    2238           0 :                   ((= index (nth 1 info))
    2239           0 :                    (if position
    2240           0 :                        (princ (format (if quoted "'(#$ . %d)"  "(#$ . %d)")
    2241           0 :                                       position)
    2242           0 :                               byte-compile--outbuffer)
    2243           0 :                      (let ((print-escape-newlines nil))
    2244           0 :                        (goto-char (prog1 (1+ (point))
    2245           0 :                                     (prin1 (car form)
    2246           0 :                                            byte-compile--outbuffer)))
    2247           0 :                        (insert "\\\n")
    2248           0 :                        (goto-char (point-max)))))
    2249             :                   (t
    2250           0 :                    (prin1 (car form) byte-compile--outbuffer)))))
    2251           0 :         (insert (nth 2 info)))))
    2252             :   nil)
    2253             : 
    2254             : (defun byte-compile-keep-pending (form &optional handler)
    2255           0 :   (if (memq byte-optimize '(t source))
    2256           0 :       (setq form (byte-optimize-form form t)))
    2257           0 :   (if handler
    2258           0 :       (let ((byte-compile--for-effect t))
    2259             :         ;; To avoid consing up monstrously large forms at load time, we split
    2260             :         ;; the output regularly.
    2261           0 :         (and (memq (car-safe form) '(fset defalias))
    2262           0 :              (nthcdr 300 byte-compile-output)
    2263           0 :              (byte-compile-flush-pending))
    2264           0 :         (funcall handler form)
    2265           0 :         (if byte-compile--for-effect
    2266           0 :             (byte-compile-discard)))
    2267           0 :     (byte-compile-form form t))
    2268             :   nil)
    2269             : 
    2270             : (defun byte-compile-flush-pending ()
    2271           0 :   (if byte-compile-output
    2272           0 :       (let ((form (byte-compile-out-toplevel t 'file)))
    2273           0 :         (cond ((eq (car-safe form) 'progn)
    2274           0 :                (mapc 'byte-compile-output-file-form (cdr form)))
    2275           0 :               (form
    2276           0 :                (byte-compile-output-file-form form)))
    2277           0 :         (setq byte-compile-constants nil
    2278             :               byte-compile-variables nil
    2279             :               byte-compile-depth 0
    2280             :               byte-compile-maxdepth 0
    2281             :               byte-compile-output nil
    2282           0 :               byte-compile-jump-tables nil))))
    2283             : 
    2284             : (defvar byte-compile-force-lexical-warnings nil)
    2285             : 
    2286             : (defun byte-compile-preprocess (form &optional _for-effect)
    2287          12 :   (setq form (macroexpand-all form byte-compile-macro-environment))
    2288             :   ;; FIXME: We should run byte-optimize-form here, but it currently does not
    2289             :   ;; recurse through all the code, so we'd have to fix this first.
    2290             :   ;; Maybe a good fix would be to merge byte-optimize-form into
    2291             :   ;; macroexpand-all.
    2292             :   ;; (if (memq byte-optimize '(t source))
    2293             :   ;;     (setq form (byte-optimize-form form for-effect)))
    2294          12 :   (cond
    2295          12 :    (lexical-binding (cconv-closure-convert form))
    2296           0 :    (byte-compile-force-lexical-warnings (cconv-warnings-only form))
    2297          12 :    (t form)))
    2298             : 
    2299             : ;; byte-hunk-handlers cannot call this!
    2300             : (defun byte-compile-toplevel-file-form (top-level-form)
    2301           0 :   (byte-compile-recurse-toplevel
    2302           0 :    top-level-form
    2303             :    (lambda (form)
    2304           0 :      (let ((byte-compile-current-form nil)) ; close over this for warnings.
    2305           0 :        (byte-compile-file-form (byte-compile-preprocess form t))))))
    2306             : 
    2307             : ;; byte-hunk-handlers can call this.
    2308             : (defun byte-compile-file-form (form)
    2309           0 :   (let (handler)
    2310           0 :     (cond ((and (consp form)
    2311           0 :                 (symbolp (car form))
    2312           0 :                 (setq handler (get (car form) 'byte-hunk-handler)))
    2313           0 :            (cond ((setq form (funcall handler form))
    2314           0 :                   (byte-compile-flush-pending)
    2315           0 :                   (byte-compile-output-file-form form))))
    2316             :           (t
    2317           0 :            (byte-compile-keep-pending form)))))
    2318             : 
    2319             : ;; Functions and variables with doc strings must be output separately,
    2320             : ;; so make-docfile can recognize them.  Most other things can be output
    2321             : ;; as byte-code.
    2322             : 
    2323             : (put 'autoload 'byte-hunk-handler 'byte-compile-file-form-autoload)
    2324             : (defun byte-compile-file-form-autoload (form)
    2325           0 :   (and (let ((form form))
    2326           0 :          (while (if (setq form (cdr form)) (macroexp-const-p (car form))))
    2327           0 :          (null form))                        ;Constants only
    2328           0 :        (memq (eval (nth 5 form)) '(t macro)) ;Macro
    2329           0 :        (eval form))                          ;Define the autoload.
    2330             :   ;; Avoid undefined function warnings for the autoload.
    2331           0 :   (pcase (nth 1 form)
    2332             :     (`',(and (pred symbolp) funsym)
    2333             :      ;; Don't add it if it's already defined.  Otherwise, it might
    2334             :      ;; hide the actual definition.  However, do remove any entry from
    2335             :      ;; byte-compile-noruntime-functions, in case we have an autoload
    2336             :      ;; of foo-func following an (eval-when-compile (require 'foo)).
    2337           0 :      (unless (fboundp funsym)
    2338           0 :        (push (cons funsym (cons 'autoload (cdr (cdr form))))
    2339           0 :              byte-compile-function-environment))
    2340             :      ;; If an autoload occurs _before_ the first call to a function,
    2341             :      ;; byte-compile-callargs-warn does not add an entry to
    2342             :      ;; byte-compile-unresolved-functions.  Here we mimic the logic
    2343             :      ;; of byte-compile-callargs-warn so as not to warn if the
    2344             :      ;; autoload comes _after_ the function call.
    2345             :      ;; Alternatively, similar logic could go in
    2346             :      ;; byte-compile-warn-about-unresolved-functions.
    2347           0 :      (if (memq funsym byte-compile-noruntime-functions)
    2348           0 :          (setq byte-compile-noruntime-functions
    2349           0 :                (delq funsym byte-compile-noruntime-functions))
    2350           0 :        (setq byte-compile-unresolved-functions
    2351           0 :              (delq (assq funsym byte-compile-unresolved-functions)
    2352           0 :                    byte-compile-unresolved-functions)))))
    2353           0 :   (if (stringp (nth 3 form))
    2354           0 :       form
    2355             :     ;; No doc string, so we can compile this as a normal form.
    2356           0 :     (byte-compile-keep-pending form 'byte-compile-normal-call)))
    2357             : 
    2358             : (put 'defvar   'byte-hunk-handler 'byte-compile-file-form-defvar)
    2359             : (put 'defconst 'byte-hunk-handler 'byte-compile-file-form-defvar)
    2360             : 
    2361             : (defun byte-compile--declare-var (sym)
    2362           0 :   (when (and (symbolp sym)
    2363           0 :              (not (string-match "[-*/:$]" (symbol-name sym)))
    2364           0 :              (byte-compile-warning-enabled-p 'lexical))
    2365           0 :     (byte-compile-warn "global/dynamic var `%s' lacks a prefix"
    2366           0 :                        sym))
    2367           0 :   (when (memq sym byte-compile-lexical-variables)
    2368           0 :     (setq byte-compile-lexical-variables
    2369           0 :           (delq sym byte-compile-lexical-variables))
    2370           0 :     (byte-compile-warn "Variable `%S' declared after its first use" sym))
    2371           0 :   (push sym byte-compile-bound-variables))
    2372             : 
    2373             : (defun byte-compile-file-form-defvar (form)
    2374           0 :   (let ((sym (nth 1 form)))
    2375           0 :     (byte-compile--declare-var sym)
    2376           0 :     (if (eq (car form) 'defconst)
    2377           0 :         (push sym byte-compile-const-variables)))
    2378           0 :   (if (and (null (cddr form))           ;No `value' provided.
    2379           0 :            (eq (car form) 'defvar))     ;Just a declaration.
    2380             :       nil
    2381           0 :     (cond ((consp (nth 2 form))
    2382           0 :            (setq form (copy-sequence form))
    2383           0 :            (setcar (cdr (cdr form))
    2384           0 :                    (byte-compile-top-level (nth 2 form) nil 'file))))
    2385           0 :     form))
    2386             : 
    2387             : (put 'define-abbrev-table 'byte-hunk-handler
    2388             :      'byte-compile-file-form-defvar-function)
    2389             : (put 'defvaralias 'byte-hunk-handler 'byte-compile-file-form-defvar-function)
    2390             : 
    2391             : (defun byte-compile-file-form-defvar-function (form)
    2392           0 :   (pcase-let (((or `',name (let name nil)) (nth 1 form)))
    2393           0 :     (if name (byte-compile--declare-var name)))
    2394           0 :   (byte-compile-keep-pending form))
    2395             : 
    2396             : (put 'custom-declare-variable 'byte-hunk-handler
    2397             :      'byte-compile-file-form-custom-declare-variable)
    2398             : (defun byte-compile-file-form-custom-declare-variable (form)
    2399           0 :   (when (byte-compile-warning-enabled-p 'callargs)
    2400           0 :     (byte-compile-nogroup-warn form))
    2401           0 :   (byte-compile-file-form-defvar-function form))
    2402             : 
    2403             : (put 'require 'byte-hunk-handler 'byte-compile-file-form-require)
    2404             : (defun byte-compile-file-form-require (form)
    2405           0 :   (let ((args (mapcar 'eval (cdr form)))
    2406           0 :         (hist-orig load-history)
    2407             :         hist-new prov-cons)
    2408           0 :     (apply 'require args)
    2409             : 
    2410             :     ;; Record the functions defined by the require in `byte-compile-new-defuns'.
    2411           0 :     (setq hist-new load-history)
    2412           0 :     (setq prov-cons (cons 'provide (car args)))
    2413           0 :     (while (and hist-new
    2414           0 :                 (not (member prov-cons (car hist-new))))
    2415           0 :       (setq hist-new (cdr hist-new)))
    2416           0 :     (when hist-new
    2417           0 :       (dolist (x (car hist-new))
    2418           0 :         (when (and (consp x)
    2419           0 :                    (memq (car x) '(defun t)))
    2420           0 :           (push (cdr x) byte-compile-new-defuns))))
    2421             : 
    2422           0 :     (when (byte-compile-warning-enabled-p 'cl-functions)
    2423             :       ;; Detect (require 'cl) in a way that works even if cl is already loaded.
    2424           0 :       (if (member (car args) '("cl" cl))
    2425           0 :           (progn
    2426           0 :             (byte-compile-warn "cl package required at runtime")
    2427           0 :             (byte-compile-disable-warning 'cl-functions))
    2428             :         ;; We may have required something that causes cl to be loaded, eg
    2429             :         ;; the uncompiled version of a file that requires cl when compiling.
    2430           0 :         (setq hist-new load-history)
    2431           0 :         (while (and (not byte-compile-cl-functions)
    2432           0 :                     hist-new (not (eq hist-new hist-orig)))
    2433           0 :           (and (byte-compile-cl-file-p (car (pop hist-new)))
    2434           0 :                (byte-compile-find-cl-functions))))))
    2435           0 :   (byte-compile-keep-pending form 'byte-compile-normal-call))
    2436             : 
    2437             : (put 'progn 'byte-hunk-handler 'byte-compile-file-form-progn)
    2438             : (put 'prog1 'byte-hunk-handler 'byte-compile-file-form-progn)
    2439             : (put 'prog2 'byte-hunk-handler 'byte-compile-file-form-progn)
    2440             : (defun byte-compile-file-form-progn (form)
    2441           0 :   (mapc 'byte-compile-file-form (cdr form))
    2442             :   ;; Return nil so the forms are not output twice.
    2443             :   nil)
    2444             : 
    2445             : (put 'with-no-warnings 'byte-hunk-handler
    2446             :      'byte-compile-file-form-with-no-warnings)
    2447             : (defun byte-compile-file-form-with-no-warnings (form)
    2448             :   ;; cf byte-compile-file-form-progn.
    2449           0 :   (let (byte-compile-warnings)
    2450           0 :     (mapc 'byte-compile-file-form (cdr form))
    2451           0 :     nil))
    2452             : 
    2453             : ;; This handler is not necessary, but it makes the output from dont-compile
    2454             : ;; and similar macros cleaner.
    2455             : (put 'eval 'byte-hunk-handler 'byte-compile-file-form-eval)
    2456             : (defun byte-compile-file-form-eval (form)
    2457           0 :   (if (eq (car-safe (nth 1 form)) 'quote)
    2458           0 :       (nth 1 (nth 1 form))
    2459           0 :     (byte-compile-keep-pending form)))
    2460             : 
    2461             : (defun byte-compile-file-form-defmumble (name macro arglist body rest)
    2462             :   "Process a `defalias' for NAME.
    2463             : If MACRO is non-nil, the definition is known to be a macro.
    2464             : ARGLIST is the list of arguments, if it was recognized or t otherwise.
    2465             : BODY of the definition, or t if not recognized.
    2466             : Return non-nil if everything went as planned, or nil to imply that it decided
    2467             : not to take responsibility for the actual compilation of the code."
    2468           0 :   (let* ((this-kind (if macro 'byte-compile-macro-environment
    2469           0 :                       'byte-compile-function-environment))
    2470           0 :          (that-kind (if macro 'byte-compile-function-environment
    2471           0 :                       'byte-compile-macro-environment))
    2472           0 :          (this-one (assq name (symbol-value this-kind)))
    2473           0 :          (that-one (assq name (symbol-value that-kind)))
    2474           0 :          (byte-compile-current-form name)) ; For warnings.
    2475             : 
    2476           0 :     (byte-compile-set-symbol-position name)
    2477           0 :     (push name byte-compile-new-defuns)
    2478             :     ;; When a function or macro is defined, add it to the call tree so that
    2479             :     ;; we can tell when functions are not used.
    2480           0 :     (if byte-compile-generate-call-tree
    2481           0 :         (or (assq name byte-compile-call-tree)
    2482           0 :             (setq byte-compile-call-tree
    2483           0 :                   (cons (list name nil nil) byte-compile-call-tree))))
    2484             : 
    2485           0 :     (if (byte-compile-warning-enabled-p 'redefine)
    2486           0 :         (byte-compile-arglist-warn name arglist macro))
    2487             : 
    2488           0 :     (if byte-compile-verbose
    2489           0 :         (message "Compiling %s... (%s)"
    2490           0 :                  (or byte-compile-current-file "") name))
    2491           0 :     (cond ((not (or macro (listp body)))
    2492             :            ;; We do not know positively if the definition is a macro
    2493             :            ;; or a function, so we shouldn't emit warnings.
    2494             :            ;; This also silences "multiple definition" warnings for defmethods.
    2495             :            nil)
    2496           0 :           (that-one
    2497           0 :            (if (and (byte-compile-warning-enabled-p 'redefine)
    2498             :                     ;; Don't warn when compiling the stubs in byte-run...
    2499           0 :                     (not (assq name byte-compile-initial-macro-environment)))
    2500           0 :                (byte-compile-warn
    2501             :                 "`%s' defined multiple times, as both function and macro"
    2502           0 :                 name))
    2503           0 :            (setcdr that-one nil))
    2504           0 :           (this-one
    2505           0 :            (when (and (byte-compile-warning-enabled-p 'redefine)
    2506             :                       ;; Hack: Don't warn when compiling the magic internal
    2507             :                       ;; byte-compiler macros in byte-run.el...
    2508           0 :                       (not (assq name byte-compile-initial-macro-environment)))
    2509           0 :              (byte-compile-warn "%s `%s' defined multiple times in this file"
    2510           0 :                                 (if macro "macro" "function")
    2511           0 :                                 name)))
    2512           0 :           ((eq (car-safe (symbol-function name))
    2513           0 :                (if macro 'lambda 'macro))
    2514           0 :            (when (byte-compile-warning-enabled-p 'redefine)
    2515           0 :              (byte-compile-warn "%s `%s' being redefined as a %s"
    2516           0 :                                 (if macro "function" "macro")
    2517           0 :                                 name
    2518           0 :                                 (if macro "macro" "function")))
    2519             :            ;; Shadow existing definition.
    2520           0 :            (set this-kind
    2521           0 :                 (cons (cons name nil)
    2522           0 :                       (symbol-value this-kind))))
    2523           0 :           )
    2524             : 
    2525           0 :     (when (and (listp body)
    2526           0 :                (stringp (car body))
    2527           0 :                (symbolp (car-safe (cdr-safe body)))
    2528           0 :                (car-safe (cdr-safe body))
    2529           0 :                (stringp (car-safe (cdr-safe (cdr-safe body)))))
    2530             :       ;; FIXME: We've done that already just above, so this looks wrong!
    2531             :       ;;(byte-compile-set-symbol-position name)
    2532           0 :       (byte-compile-warn "probable `\"' without `\\' in doc string of %s"
    2533           0 :                          name))
    2534             : 
    2535           0 :     (if (not (listp body))
    2536             :         ;; The precise definition requires evaluation to find out, so it
    2537             :         ;; will only be known at runtime.
    2538             :         ;; For a macro, that means we can't use that macro in the same file.
    2539           0 :         (progn
    2540           0 :           (unless macro
    2541           0 :             (push (cons name (if (listp arglist) `(declared ,arglist) t))
    2542           0 :                   byte-compile-function-environment))
    2543             :           ;; Tell the caller that we didn't compile it yet.
    2544           0 :           nil)
    2545             : 
    2546           0 :       (let* ((code (byte-compile-lambda (cons arglist body) t)))
    2547           0 :         (if this-one
    2548             :             ;; A definition in b-c-initial-m-e should always take precedence
    2549             :             ;; during compilation, so don't let it be redefined.  (Bug#8647)
    2550           0 :             (or (and macro
    2551           0 :                      (assq name byte-compile-initial-macro-environment))
    2552           0 :                 (setcdr this-one code))
    2553           0 :           (set this-kind
    2554           0 :                (cons (cons name code)
    2555           0 :                      (symbol-value this-kind))))
    2556             : 
    2557           0 :         (if rest
    2558             :             ;; There are additional args to `defalias' (like maybe a docstring)
    2559             :             ;; that the code below can't handle: punt!
    2560             :             nil
    2561             :           ;; Otherwise, we have a bona-fide defun/defmacro definition, and use
    2562             :           ;; special code to allow dynamic docstrings and byte-code.
    2563           0 :           (byte-compile-flush-pending)
    2564           0 :           (let ((index
    2565             :                  ;; If there's no doc string, provide -1 as the "doc string
    2566             :                  ;; index" so that no element will be treated as a doc string.
    2567           0 :                  (if (not (stringp (car body))) -1 4)))
    2568             :             ;; Output the form by hand, that's much simpler than having
    2569             :             ;; b-c-output-file-form analyze the defalias.
    2570           0 :             (byte-compile-output-docform
    2571             :              "\n(defalias '"
    2572           0 :              name
    2573           0 :              (if macro `(" '(macro . #[" ,index "])") `(" #[" ,index "]"))
    2574           0 :              (append code nil)          ; Turn byte-code-function-p into list.
    2575           0 :              (and (atom code) byte-compile-dynamic
    2576           0 :                   1)
    2577           0 :              nil))
    2578           0 :           (princ ")" byte-compile--outbuffer)
    2579           0 :           t)))))
    2580             : 
    2581             : (defun byte-compile-output-as-comment (exp quoted)
    2582             :   "Print Lisp object EXP in the output file, inside a comment,
    2583             : and return the file (byte) position it will have.
    2584             : If QUOTED is non-nil, print with quoting; otherwise, print without quoting."
    2585           0 :   (with-current-buffer byte-compile--outbuffer
    2586           0 :     (let ((position (point)))
    2587             : 
    2588             :       ;; Insert EXP, and make it a comment with #@LENGTH.
    2589           0 :       (insert " ")
    2590           0 :       (if quoted
    2591           0 :           (prin1 exp byte-compile--outbuffer)
    2592           0 :         (princ exp byte-compile--outbuffer))
    2593           0 :       (goto-char position)
    2594             :       ;; Quote certain special characters as needed.
    2595             :       ;; get_doc_string in doc.c does the unquoting.
    2596           0 :       (while (search-forward "\^A" nil t)
    2597           0 :         (replace-match "\^A\^A" t t))
    2598           0 :       (goto-char position)
    2599           0 :       (while (search-forward "\000" nil t)
    2600           0 :         (replace-match "\^A0" t t))
    2601           0 :       (goto-char position)
    2602           0 :       (while (search-forward "\037" nil t)
    2603           0 :         (replace-match "\^A_" t t))
    2604           0 :       (goto-char (point-max))
    2605           0 :       (insert "\037")
    2606           0 :       (goto-char position)
    2607           0 :       (insert "#@" (format "%d" (- (position-bytes (point-max))
    2608           0 :                                    (position-bytes position))))
    2609             : 
    2610             :       ;; Save the file position of the object.
    2611             :       ;; Note we add 1 to skip the space that we inserted before the actual doc
    2612             :       ;; string, and subtract point-min to convert from an 1-origin Emacs
    2613             :       ;; position to a file position.
    2614           0 :       (prog1
    2615           0 :           (- (position-bytes (point)) (point-min) -1)
    2616           0 :         (goto-char (point-max))))))
    2617             : 
    2618             : (defun byte-compile--reify-function (fun)
    2619             :   "Return an expression which will evaluate to a function value FUN.
    2620             : FUN should be either a `lambda' value or a `closure' value."
    2621           7 :   (pcase-let* (((or (and `(lambda ,args . ,body) (let env nil))
    2622             :                     `(closure ,env ,args . ,body))
    2623           7 :                 fun)
    2624             :                (preamble nil)
    2625             :                (renv ()))
    2626             :     ;; Split docstring and `interactive' form from body.
    2627           7 :     (when (stringp (car body))
    2628           7 :       (push (pop body) preamble))
    2629           7 :     (when (eq (car-safe (car body)) 'interactive)
    2630           7 :       (push (pop body) preamble))
    2631             :     ;; Turn the function's closed vars (if any) into local let bindings.
    2632           7 :     (dolist (binding env)
    2633          42 :       (cond
    2634          42 :        ((consp binding)
    2635             :         ;; We check shadowing by the args, so that the `let' can be moved
    2636             :         ;; within the lambda, which can then be unfolded.  FIXME: Some of those
    2637             :         ;; bindings might be unused in `body'.
    2638           0 :         (unless (memq (car binding) args) ;Shadowed.
    2639           0 :           (push `(,(car binding) ',(cdr binding)) renv)))
    2640          42 :        ((eq binding t))
    2641          70 :        (t (push `(defvar ,binding) body))))
    2642           7 :     (if (null renv)
    2643           7 :         `(lambda ,args ,@preamble ,@body)
    2644           7 :       `(lambda ,args ,@preamble (let ,(nreverse renv) ,@body)))))
    2645             : 
    2646             : ;;;###autoload
    2647             : (defun byte-compile (form)
    2648             :   "If FORM is a symbol, byte-compile its function definition.
    2649             : If FORM is a lambda or a macro, byte-compile it as a function."
    2650          12 :   (displaying-byte-compile-warnings
    2651          12 :    (byte-compile-close-variables
    2652          12 :     (let* ((lexical-binding lexical-binding)
    2653          12 :            (fun (if (symbolp form)
    2654           7 :                     (symbol-function form)
    2655          12 :                   form))
    2656          12 :            (macro (eq (car-safe fun) 'macro)))
    2657          12 :       (if macro
    2658          12 :           (setq fun (cdr fun)))
    2659          12 :       (cond
    2660             :        ;; Up until Emacs-24.1, byte-compile silently did nothing when asked to
    2661             :        ;; compile something invalid.  So let's tune down the complaint from an
    2662             :        ;; error to a simple message for the known case where signaling an error
    2663             :        ;; causes problems.
    2664          12 :        ((byte-code-function-p fun)
    2665           0 :         (message "Function %s is already compiled"
    2666           0 :                  (if (symbolp form) form "provided"))
    2667           0 :         fun)
    2668             :        (t
    2669          12 :         (when (or (symbolp form) (eq (car-safe fun) 'closure))
    2670             :           ;; `fun' is a function *value*, so try to recover its corresponding
    2671             :           ;; source code.
    2672           7 :           (setq lexical-binding (eq (car fun) 'closure))
    2673          12 :           (setq fun (byte-compile--reify-function fun)))
    2674             :         ;; Expand macros.
    2675          12 :         (setq fun (byte-compile-preprocess fun))
    2676          12 :         (setq fun (byte-compile-top-level fun nil 'eval))
    2677          12 :         (if macro (push 'macro fun))
    2678          12 :         (if (symbolp form)
    2679           7 :             (fset form fun)
    2680          12 :           fun)))))))
    2681             : 
    2682             : (defun byte-compile-sexp (sexp)
    2683             :   "Compile and return SEXP."
    2684           0 :   (displaying-byte-compile-warnings
    2685           0 :    (byte-compile-close-variables
    2686           0 :     (byte-compile-top-level (byte-compile-preprocess sexp)))))
    2687             : 
    2688             : (defun byte-compile-check-lambda-list (list)
    2689             :   "Check lambda-list LIST for errors."
    2690          24 :   (let (vars)
    2691          72 :     (while list
    2692          48 :       (let ((arg (car list)))
    2693          48 :         (when (symbolp arg)
    2694          48 :           (byte-compile-set-symbol-position arg))
    2695          48 :         (cond ((or (not (symbolp arg))
    2696          48 :                    (macroexp--const-symbol-p arg t))
    2697           0 :                (error "Invalid lambda variable %s" arg))
    2698          48 :               ((eq arg '&rest)
    2699           5 :                (unless (cdr list)
    2700           5 :                  (error "&rest without variable name"))
    2701           5 :                (when (cddr list)
    2702           5 :                  (error "Garbage following &rest VAR in lambda-list")))
    2703          43 :               ((eq arg '&optional)
    2704           4 :                (when (or (null (cdr list))
    2705           4 :                          (memq (cadr list) '(&optional &rest)))
    2706           4 :                  (error "Variable name missing after &optional"))
    2707           4 :                (when (memq '&optional (cddr list))
    2708           4 :                  (error "Duplicate &optional")))
    2709          39 :               ((memq arg vars)
    2710           0 :                (byte-compile-warn "repeated variable %s in lambda-list" arg))
    2711             :               (t
    2712          78 :                (push arg vars))))
    2713          48 :       (setq list (cdr list)))))
    2714             : 
    2715             : 
    2716             : (defun byte-compile-arglist-vars (arglist)
    2717             :   "Return a list of the variables in the lambda argument list ARGLIST."
    2718          24 :   (remq '&rest (remq '&optional arglist)))
    2719             : 
    2720             : (defun byte-compile-make-lambda-lexenv (args)
    2721             :   "Return a new lexical environment for a lambda expression FORM."
    2722          24 :   (let* ((lexenv nil)
    2723             :          (stackpos 0))
    2724             :     ;; Add entries for each argument.
    2725          24 :     (dolist (arg args)
    2726          78 :       (push (cons arg stackpos) lexenv)
    2727          39 :       (setq stackpos (1+ stackpos)))
    2728             :     ;; Return the new lexical environment.
    2729          24 :     lexenv))
    2730             : 
    2731             : (defun byte-compile-make-args-desc (arglist)
    2732          24 :   (let ((mandatory 0)
    2733             :         nonrest (rest 0))
    2734          50 :     (while (and arglist (not (memq (car arglist) '(&optional &rest))))
    2735          26 :       (setq mandatory (1+ mandatory))
    2736          26 :       (setq arglist (cdr arglist)))
    2737          24 :     (setq nonrest mandatory)
    2738          24 :     (when (eq (car arglist) '&optional)
    2739           4 :       (setq arglist (cdr arglist))
    2740          12 :       (while (and arglist (not (eq (car arglist) '&rest)))
    2741           8 :         (setq nonrest (1+ nonrest))
    2742          24 :         (setq arglist (cdr arglist))))
    2743          24 :     (when arglist
    2744          24 :       (setq rest 1))
    2745          24 :     (if (> mandatory 127)
    2746           0 :         (byte-compile-report-error "Too many (>127) mandatory arguments")
    2747          24 :       (logior mandatory
    2748          24 :               (lsh nonrest 8)
    2749          24 :               (lsh rest 7)))))
    2750             : 
    2751             : 
    2752             : (defun byte-compile-lambda (fun &optional add-lambda reserved-csts)
    2753             :   "Byte-compile a lambda-expression and return a valid function.
    2754             : The value is usually a compiled function but may be the original
    2755             : lambda-expression.
    2756             : When ADD-LAMBDA is non-nil, the symbol `lambda' is added as head
    2757             : of the list FUN and `byte-compile-set-symbol-position' is not called.
    2758             : Use this feature to avoid calling `byte-compile-set-symbol-position'
    2759             : for symbols generated by the byte compiler itself."
    2760          24 :   (if add-lambda
    2761           0 :       (setq fun (cons 'lambda fun))
    2762          24 :     (unless (eq 'lambda (car-safe fun))
    2763          24 :       (error "Not a lambda list: %S" fun))
    2764          24 :     (byte-compile-set-symbol-position 'lambda))
    2765          24 :   (byte-compile-check-lambda-list (nth 1 fun))
    2766          24 :   (let* ((arglist (nth 1 fun))
    2767          24 :          (arglistvars (byte-compile-arglist-vars arglist))
    2768             :          (byte-compile-bound-variables
    2769          24 :           (append (if (not lexical-binding) arglistvars)
    2770          24 :                   byte-compile-bound-variables))
    2771          24 :          (body (cdr (cdr fun)))
    2772          24 :          (doc (if (stringp (car body))
    2773           1 :                   (prog1 (car body)
    2774             :                     ;; Discard the doc string
    2775             :                     ;; unless it is the last element of the body.
    2776           1 :                     (if (cdr body)
    2777          24 :                         (setq body (cdr body))))))
    2778          24 :          (int (assq 'interactive body)))
    2779             :     ;; Process the interactive spec.
    2780          24 :     (when int
    2781           0 :       (byte-compile-set-symbol-position 'interactive)
    2782             :       ;; Skip (interactive) if it is in front (the most usual location).
    2783           0 :       (if (eq int (car body))
    2784           0 :           (setq body (cdr body)))
    2785           0 :       (cond ((consp (cdr int))
    2786           0 :              (if (cdr (cdr int))
    2787           0 :                  (byte-compile-warn "malformed interactive spec: %s"
    2788           0 :                                     (prin1-to-string int)))
    2789             :              ;; If the interactive spec is a call to `list', don't
    2790             :              ;; compile it, because `call-interactively' looks at the
    2791             :              ;; args of `list'.  Actually, compile it to get warnings,
    2792             :              ;; but don't use the result.
    2793           0 :              (let* ((form (nth 1 int))
    2794           0 :                     (newform (byte-compile-top-level form)))
    2795           0 :                (while (memq (car-safe form) '(let let* progn save-excursion))
    2796           0 :                  (while (consp (cdr form))
    2797           0 :                    (setq form (cdr form)))
    2798           0 :                  (setq form (car form)))
    2799           0 :                (if (and (eq (car-safe form) 'list)
    2800             :                         ;; The spec is evalled in callint.c in dynamic-scoping
    2801             :                         ;; mode, so just leaving the form unchanged would mean
    2802             :                         ;; it won't be eval'd in the right mode.
    2803           0 :                         (not lexical-binding))
    2804             :                    nil
    2805           0 :                  (setq int `(interactive ,newform)))))
    2806           0 :             ((cdr int)
    2807           0 :              (byte-compile-warn "malformed interactive spec: %s"
    2808          24 :                                 (prin1-to-string int)))))
    2809             :     ;; Process the body.
    2810          24 :     (let ((compiled
    2811          24 :            (byte-compile-top-level (cons 'progn body) nil 'lambda
    2812             :                                    ;; If doing lexical binding, push a new
    2813             :                                    ;; lexical environment containing just the
    2814             :                                    ;; args (since lambda expressions should be
    2815             :                                    ;; closed by now).
    2816          24 :                                    (and lexical-binding
    2817          24 :                                         (byte-compile-make-lambda-lexenv
    2818          24 :                                          arglistvars))
    2819          24 :                                    reserved-csts)))
    2820             :       ;; Build the actual byte-coded function.
    2821          24 :       (cl-assert (eq 'byte-code (car-safe compiled)))
    2822          24 :       (apply #'make-byte-code
    2823          24 :              (if lexical-binding
    2824          24 :                  (byte-compile-make-args-desc arglist)
    2825          24 :                arglist)
    2826          24 :              (append
    2827             :               ;; byte-string, constants-vector, stack depth
    2828          24 :               (cdr compiled)
    2829             :               ;; optionally, the doc string.
    2830          24 :               (cond ((and lexical-binding arglist)
    2831             :                      ;; byte-compile-make-args-desc lost the args's names,
    2832             :                      ;; so preserve them in the docstring.
    2833          17 :                      (list (help-add-fundoc-usage doc arglist)))
    2834           7 :                     ((or doc int)
    2835          24 :                      (list doc)))
    2836             :               ;; optionally, the interactive spec.
    2837          24 :               (if int
    2838          24 :                   (list (nth 1 int))))))))
    2839             : 
    2840             : (defvar byte-compile-reserved-constants 0)
    2841             : 
    2842             : (defun byte-compile-constants-vector ()
    2843             :   ;; Builds the constants-vector from the current variables and constants.
    2844             :   ;;   This modifies the constants from (const . nil) to (const . offset).
    2845             :   ;; To keep the byte-codes to look up the vector as short as possible:
    2846             :   ;;   First 6 elements are vars, as there are one-byte varref codes for those.
    2847             :   ;;   Next up to byte-constant-limit are constants, still with one-byte codes.
    2848             :   ;;   Next variables again, to get 2-byte codes for variable lookup.
    2849             :   ;;   The rest of the constants and variables need 3-byte byte-codes.
    2850          24 :   (let* ((i (1- byte-compile-reserved-constants))
    2851          24 :          (rest (nreverse byte-compile-variables)) ; nreverse because the first
    2852          24 :          (other (nreverse byte-compile-constants)) ; vars often are used most.
    2853             :          ret tmp
    2854             :          (limits '(5                    ; Use the 1-byte varref codes,
    2855             :                    63  ; 1-constlim     ;  1-byte byte-constant codes,
    2856             :                    255                  ;  2-byte varref codes,
    2857             :                    65535                ;  3-byte codes for the rest.
    2858             :                    65535))              ;  twice since we step when we swap.
    2859             :          limit)
    2860          80 :     (while (or rest other)
    2861          56 :       (setq limit (car limits))
    2862        1165 :       (while (and rest (< i limit))
    2863        1109 :         (cond
    2864        1109 :          ((numberp (car rest))
    2865          20 :           (cl-assert (< (car rest) byte-compile-reserved-constants)))
    2866        1089 :          ((setq tmp (assq (car (car rest)) ret))
    2867           0 :           (setcdr (car rest) (cdr tmp)))
    2868             :          (t
    2869        1089 :           (setcdr (car rest) (setq i (1+ i)))
    2870        1109 :           (setq ret (cons (car rest) ret))))
    2871        1109 :         (setq rest (cdr rest)))
    2872          56 :       (setq limits (cdr limits)         ;Step
    2873          56 :             rest (prog1 other           ;&Swap.
    2874          56 :                    (setq other rest))))
    2875          24 :     (apply 'vector (nreverse (mapcar 'car ret)))))
    2876             : 
    2877             : ;; Given an expression FORM, compile it and return an equivalent byte-code
    2878             : ;; expression (a call to the function byte-code).
    2879             : (defun byte-compile-top-level (form &optional for-effect output-type
    2880             :                                     lexenv reserved-csts)
    2881             :   ;; OUTPUT-TYPE advises about how form is expected to be used:
    2882             :   ;;    'eval or nil    -> a single form,
    2883             :   ;;    'progn or t     -> a list of forms,
    2884             :   ;;    'lambda         -> body of a lambda,
    2885             :   ;;    'file           -> used at file-level.
    2886          36 :   (let ((byte-compile--for-effect for-effect)
    2887             :         (byte-compile-constants nil)
    2888             :         (byte-compile-variables nil)
    2889             :         (byte-compile-tag-number 0)
    2890             :         (byte-compile-depth 0)
    2891             :         (byte-compile-maxdepth 0)
    2892          36 :         (byte-compile--lexical-environment lexenv)
    2893          36 :         (byte-compile-reserved-constants (or reserved-csts 0))
    2894             :         (byte-compile-output nil)
    2895             :         (byte-compile-jump-tables nil))
    2896          36 :     (if (memq byte-optimize '(t source))
    2897          36 :         (setq form (byte-optimize-form form byte-compile--for-effect)))
    2898          42 :     (while (and (eq (car-safe form) 'progn) (null (cdr (cdr form))))
    2899          36 :       (setq form (nth 1 form)))
    2900             :     ;; Set up things for a lexically-bound function.
    2901          36 :     (when (and lexical-binding (eq output-type 'lambda))
    2902             :       ;; See how many arguments there are, and set the current stack depth
    2903             :       ;; accordingly.
    2904          24 :       (setq byte-compile-depth (length byte-compile--lexical-environment))
    2905             :       ;; If there are args, output a tag to record the initial
    2906             :       ;; stack-depth for the optimizer.
    2907          24 :       (when (> byte-compile-depth 0)
    2908          36 :         (byte-compile-out-tag (byte-compile-make-tag))))
    2909             :     ;; Now compile FORM
    2910          36 :     (byte-compile-form form byte-compile--for-effect)
    2911          36 :     (byte-compile-out-toplevel byte-compile--for-effect output-type)))
    2912             : 
    2913             : (defun byte-compile-out-toplevel (&optional for-effect output-type)
    2914          36 :   (if for-effect
    2915             :       ;; The stack is empty. Push a value to be returned from (byte-code ..).
    2916           0 :       (if (eq (car (car byte-compile-output)) 'byte-discard)
    2917           0 :           (setq byte-compile-output (cdr byte-compile-output))
    2918           0 :         (byte-compile-push-constant
    2919             :          ;; Push any constant - preferably one which already is used, and
    2920             :          ;; a number or symbol - ie not some big sequence.  The return value
    2921             :          ;; isn't returned, but it would be a shame if some textually large
    2922             :          ;; constant was not optimized away because we chose to return it.
    2923           0 :          (and (not (assq nil byte-compile-constants)) ; Nil is often there.
    2924           0 :               (let ((tmp (reverse byte-compile-constants)))
    2925           0 :                 (while (and tmp (not (or (symbolp (caar tmp))
    2926           0 :                                          (numberp (caar tmp)))))
    2927           0 :                   (setq tmp (cdr tmp)))
    2928          36 :                 (caar tmp))))))
    2929          36 :   (byte-compile-out 'byte-return 0)
    2930          36 :   (setq byte-compile-output (nreverse byte-compile-output))
    2931          36 :   (if (memq byte-optimize '(t byte))
    2932          15 :       (setq byte-compile-output
    2933          36 :             (byte-optimize-lapcode byte-compile-output)))
    2934             : 
    2935             :   ;; Decompile trivial functions:
    2936             :   ;; only constants and variables, or a single funcall except in lambdas.
    2937             :   ;; Except for Lisp_Compiled objects, forms like (foo "hi")
    2938             :   ;; are still quicker than (byte-code "..." [foo "hi"] 2).
    2939             :   ;; Note that even (quote foo) must be parsed just as any subr by the
    2940             :   ;; interpreter, so quote should be compiled into byte-code in some contexts.
    2941             :   ;; What to leave uncompiled:
    2942             :   ;;    lambda  -> never.  we used to leave it uncompiled if the body was
    2943             :   ;;               a single atom, but that causes confusion if the docstring
    2944             :   ;;               uses the (file . pos) syntax.  Besides, now that we have
    2945             :   ;;               the Lisp_Compiled type, the compiled form is faster.
    2946             :   ;;    eval    -> atom, quote or (function atom atom atom)
    2947             :   ;;    progn   -> as <<same-as-eval>> or (progn <<same-as-eval>> atom)
    2948             :   ;;    file    -> as progn, but takes both quotes and atoms, and longer forms.
    2949          36 :   (let (rest
    2950          36 :         (maycall (not (eq output-type 'lambda))) ; t if we may make a funcall.
    2951             :         tmp body)
    2952          36 :     (cond
    2953             :      ;; #### This should be split out into byte-compile-nontrivial-function-p.
    2954          36 :      ((or (eq output-type 'lambda)
    2955          12 :           (nthcdr (if (eq output-type 'file) 50 8) byte-compile-output)
    2956          12 :           (assq 'TAG byte-compile-output) ; Not necessary, but speeds up a bit.
    2957          12 :           (not (setq tmp (assq 'byte-return byte-compile-output)))
    2958          12 :           (progn
    2959          12 :             (setq rest (nreverse
    2960          12 :                         (cdr (memq tmp (reverse byte-compile-output)))))
    2961          12 :             (while
    2962          24 :                 (cond
    2963          24 :                  ((memq (car (car rest)) '(byte-varref byte-constant))
    2964          12 :                   (setq tmp (car (cdr (car rest))))
    2965          12 :                   (if (if (eq (car (car rest)) 'byte-constant)
    2966          12 :                           (or (consp tmp)
    2967          12 :                               (and (symbolp tmp)
    2968          12 :                                    (not (macroexp--const-symbol-p tmp)))))
    2969           0 :                       (if maycall
    2970           0 :                           (setq body (cons (list 'quote tmp) body)))
    2971          12 :                     (setq body (cons tmp body))))
    2972          12 :                  ((and maycall
    2973             :                        ;; Allow a funcall if at most one atom follows it.
    2974          12 :                        (null (nthcdr 3 rest))
    2975          12 :                        (setq tmp (get (car (car rest)) 'byte-opcode-invert))
    2976           0 :                        (or (null (cdr rest))
    2977           0 :                            (and (memq output-type '(file progn t))
    2978           0 :                                 (cdr (cdr rest))
    2979           0 :                                 (eq (car (nth 1 rest)) 'byte-discard)
    2980          12 :                                 (progn (setq rest (cdr rest)) t))))
    2981           0 :                   (setq maycall nil)    ; Only allow one real function call.
    2982           0 :                   (setq body (nreverse body))
    2983           0 :                   (setq body (list
    2984           0 :                               (if (and (eq tmp 'funcall)
    2985           0 :                                        (eq (car-safe (car body)) 'quote)
    2986           0 :                                        (symbolp (nth 1 (car body))))
    2987           0 :                                   (cons (nth 1 (car body)) (cdr body))
    2988           0 :                                 (cons tmp body))))
    2989           0 :                   (or (eq output-type 'file)
    2990          24 :                       (not (delq nil (mapcar 'consp (cdr (car body))))))))
    2991          12 :               (setq rest (cdr rest)))
    2992          36 :             rest))
    2993          24 :       (let ((byte-compile-vector (byte-compile-constants-vector)))
    2994          24 :         (list 'byte-code (byte-compile-lapcode byte-compile-output)
    2995          24 :               byte-compile-vector byte-compile-maxdepth)))
    2996             :      ;; it's a trivial function
    2997          12 :      ((cdr body) (cons 'progn (nreverse body)))
    2998          36 :      ((car body)))))
    2999             : 
    3000             : ;; Given BODY, compile it and return a new body.
    3001             : (defun byte-compile-top-level-body (body &optional for-effect)
    3002           0 :   (setq body
    3003           0 :         (byte-compile-top-level (cons 'progn body) for-effect t))
    3004           0 :   (cond ((eq (car-safe body) 'progn)
    3005           0 :          (cdr body))
    3006           0 :         (body
    3007           0 :          (list body))))
    3008             : 
    3009             : ;; Special macro-expander used during byte-compilation.
    3010             : (defun byte-compile-macroexpand-declare-function (fn file &rest args)
    3011             :   (declare (advertised-calling-convention
    3012             :             (fn file &optional arglist fileonly) nil))
    3013           0 :   (let ((gotargs (and (consp args) (listp (car args))))
    3014           0 :         (unresolved (assq fn byte-compile-unresolved-functions)))
    3015           0 :     (when unresolved          ; function was called before declaration
    3016           0 :       (if (and gotargs (byte-compile-warning-enabled-p 'callargs))
    3017           0 :           (byte-compile-arglist-warn fn (car args) nil)
    3018           0 :         (setq byte-compile-unresolved-functions
    3019           0 :               (delq unresolved byte-compile-unresolved-functions))))
    3020           0 :     (push (cons fn (if gotargs
    3021           0 :                        (list 'declared (car args))
    3022           0 :                      t))                     ; Arglist not specified.
    3023           0 :           byte-compile-function-environment))
    3024             :   ;; We are stating that it _will_ be defined at runtime.
    3025           0 :   (setq byte-compile-noruntime-functions
    3026           0 :         (delq fn byte-compile-noruntime-functions))
    3027             :   ;; Delegate the rest to the normal macro definition.
    3028           0 :   (macroexpand `(declare-function ,fn ,file ,@args)))
    3029             : 
    3030             : 
    3031             : ;; This is the recursive entry point for compiling each subform of an
    3032             : ;; expression.
    3033             : ;; If for-effect is non-nil, byte-compile-form will output a byte-discard
    3034             : ;; before terminating (ie no value will be left on the stack).
    3035             : ;; A byte-compile handler may, when byte-compile--for-effect is non-nil, choose
    3036             : ;; output code which does not leave a value on the stack, and then set
    3037             : ;; byte-compile--for-effect to nil (to prevent byte-compile-form from
    3038             : ;; outputting the byte-discard).
    3039             : ;; If a handler wants to call another handler, it should do so via
    3040             : ;; byte-compile-form, or take extreme care to handle byte-compile--for-effect
    3041             : ;; correctly.  (Use byte-compile-form-do-effect to reset the
    3042             : ;; byte-compile--for-effect flag too.)
    3043             : ;;
    3044             : (defun byte-compile-form (form &optional for-effect)
    3045        2897 :   (let ((byte-compile--for-effect for-effect))
    3046        2897 :     (cond
    3047        2897 :      ((not (consp form))
    3048        1247 :       (cond ((or (not (symbolp form)) (macroexp--const-symbol-p form))
    3049        1004 :              (when (symbolp form)
    3050        1004 :                (byte-compile-set-symbol-position form))
    3051        1004 :              (byte-compile-constant form))
    3052         243 :             ((and byte-compile--for-effect byte-compile-delete-errors)
    3053           0 :              (when (symbolp form)
    3054           0 :                (byte-compile-set-symbol-position form))
    3055           0 :              (setq byte-compile--for-effect nil))
    3056             :             (t
    3057        1247 :              (byte-compile-variable-ref form))))
    3058        1650 :      ((symbolp (car form))
    3059        1650 :       (let* ((fn (car form))
    3060        1650 :              (handler (get fn 'byte-compile))
    3061             :              (interactive-only
    3062        1650 :               (or (get fn 'interactive-only)
    3063        1650 :                   (memq fn byte-compile-interactive-only-functions))))
    3064        1650 :         (when (memq fn '(set symbol-value run-hooks ;; add-to-list
    3065             :                              add-hook remove-hook run-hook-with-args
    3066             :                              run-hook-with-args-until-success
    3067        1650 :                              run-hook-with-args-until-failure))
    3068           0 :           (pcase (cdr form)
    3069             :             (`(',var . ,_)
    3070           0 :              (when (assq var byte-compile-lexical-variables)
    3071           0 :                (byte-compile-report-error
    3072        1650 :                 (format-message "%s cannot use lexical var `%s'" fn var))))))
    3073        1650 :         (when (macroexp--const-symbol-p fn)
    3074        1650 :           (byte-compile-warn "`%s' called as a function" fn))
    3075        1650 :         (when (and (byte-compile-warning-enabled-p 'interactive-only)
    3076        1650 :                    interactive-only)
    3077           0 :           (byte-compile-warn "`%s' is for interactive use only%s"
    3078           0 :                              fn
    3079           0 :                              (cond ((stringp interactive-only)
    3080           0 :                                     (format "; %s"
    3081           0 :                                             (substitute-command-keys
    3082           0 :                                              interactive-only)))
    3083           0 :                                    ((and (symbolp 'interactive-only)
    3084           0 :                                          (not (eq interactive-only t)))
    3085           0 :                                     (format-message "; use `%s' instead."
    3086           0 :                                                     interactive-only))
    3087        1650 :                                    (t "."))))
    3088        1650 :         (if (eq (car-safe (symbol-function (car form))) 'macro)
    3089           0 :             (byte-compile-report-error
    3090        1650 :              (format "Forgot to expand macro %s in %S" (car form) form)))
    3091        1650 :         (if (and handler
    3092             :                  ;; Make sure that function exists.
    3093         730 :                  (and (functionp handler)
    3094             :                       ;; Ignore obsolete byte-compile function used by former
    3095             :                       ;; CL code to handle compiler macros (we do it
    3096             :                       ;; differently now).
    3097        1650 :                       (not (eq handler 'cl-byte-compile-compiler-macro))))
    3098         730 :             (funcall handler form)
    3099        1650 :           (byte-compile-normal-call form))
    3100        1650 :         (if (byte-compile-warning-enabled-p 'cl-functions)
    3101        1650 :             (byte-compile-cl-warn form))))
    3102           0 :      ((and (byte-code-function-p (car form))
    3103           0 :            (memq byte-optimize '(t lap)))
    3104           0 :       (byte-compile-unfold-bcf form))
    3105           0 :      ((and (eq (car-safe (car form)) 'lambda)
    3106             :            ;; if the form comes out the same way it went in, that's
    3107             :            ;; because it was malformed, and we couldn't unfold it.
    3108           0 :            (not (eq form (setq form (byte-compile-unfold-lambda form)))))
    3109           0 :       (byte-compile-form form byte-compile--for-effect)
    3110           0 :       (setq byte-compile--for-effect nil))
    3111        2897 :      ((byte-compile-normal-call form)))
    3112        2897 :     (if byte-compile--for-effect
    3113        2897 :         (byte-compile-discard))))
    3114             : 
    3115             : (defun byte-compile-normal-call (form)
    3116         920 :   (when (and (byte-compile-warning-enabled-p 'callargs)
    3117         920 :              (symbolp (car form)))
    3118          63 :     (if (memq (car form)
    3119             :               '(custom-declare-group custom-declare-variable
    3120          63 :                                      custom-declare-face))
    3121          63 :         (byte-compile-nogroup-warn form))
    3122         920 :     (byte-compile-callargs-warn form))
    3123         920 :   (if byte-compile-generate-call-tree
    3124         920 :       (byte-compile-annotate-call-tree form))
    3125         920 :   (when (and byte-compile--for-effect (eq (car form) 'mapcar)
    3126         920 :              (byte-compile-warning-enabled-p 'mapcar))
    3127           0 :     (byte-compile-set-symbol-position 'mapcar)
    3128           0 :     (byte-compile-warn
    3129         920 :      "`mapcar' called for effect; use `mapc' or `dolist' instead"))
    3130         920 :   (byte-compile-push-constant (car form))
    3131         920 :   (mapc 'byte-compile-form (cdr form))  ; wasteful, but faster.
    3132         920 :   (byte-compile-out 'byte-call (length (cdr form))))
    3133             : 
    3134             : 
    3135             : ;; Splice the given lap code into the current instruction stream.
    3136             : ;; If it has any labels in it, you're responsible for making sure there
    3137             : ;; are no collisions, and that byte-compile-tag-number is reasonable
    3138             : ;; after this is spliced in.  The provided list is destroyed.
    3139             : (defun byte-compile-inline-lapcode (lap end-depth)
    3140             :   ;; "Replay" the operations: we used to just do
    3141             :   ;; (setq byte-compile-output (nconc (nreverse lap) byte-compile-output))
    3142             :   ;; but that fails to update byte-compile-depth, so we had to assume
    3143             :   ;; that `lap' ends up adding exactly 1 element to the stack.  This
    3144             :   ;; happens to be true for byte-code generated by bytecomp.el without
    3145             :   ;; lexical-binding, but it's not true in general, and it's not true for
    3146             :   ;; code output by bytecomp.el with lexical-binding.
    3147             :   ;; We also restore the value of `byte-compile-depth' and remove TAG depths
    3148             :   ;; accordingly when inlining lapcode containing lap-code, exactly as
    3149             :   ;; documented in `byte-compile-cond-jump-table'.
    3150           0 :   (let ((endtag (byte-compile-make-tag))
    3151             :         last-jump-tag ;; last TAG we have jumped to
    3152             :         last-depth ;; last value of `byte-compile-depth'
    3153             :         last-constant ;; value of the last constant encountered
    3154             :         last-switch ;; whether the last op encountered was byte-switch
    3155             :         switch-tags ;; a list of tags that byte-switch could jump to
    3156             :         ;; a list of tags byte-switch will jump to, if the value doesn't
    3157             :         ;; match any entry in the hash table
    3158             :         switch-default-tags)
    3159           0 :     (dolist (op lap)
    3160           0 :       (cond
    3161           0 :        ((eq (car op) 'TAG)
    3162           0 :         (when (or (member op switch-tags) (member op switch-default-tags))
    3163             :           ;; This TAG is used in a jump table, this means the last goto
    3164             :           ;; was to a done/default TAG, and thus it's cddr should be set to nil.
    3165           0 :           (when last-jump-tag
    3166           0 :             (setcdr (cdr last-jump-tag) nil))
    3167             :           ;; Also, restore the value of `byte-compile-depth' to what it was
    3168             :           ;; before the last goto.
    3169           0 :           (setq byte-compile-depth last-depth
    3170           0 :                 last-jump-tag nil))
    3171           0 :         (byte-compile-out-tag op))
    3172           0 :        ((memq (car op) byte-goto-ops)
    3173           0 :         (setq last-depth byte-compile-depth
    3174           0 :               last-jump-tag (cdr op))
    3175           0 :         (byte-compile-goto (car op) (cdr op))
    3176           0 :         (when last-switch
    3177             :           ;; The last op was byte-switch, this goto jumps to a "default" TAG
    3178             :           ;; (when no value in the jump table is satisfied).
    3179           0 :           (push (cdr op) switch-default-tags)
    3180           0 :           (setcdr (cdr (cdr op)) nil)
    3181           0 :           (setq byte-compile-depth last-depth
    3182           0 :                 last-switch nil)))
    3183           0 :        ((eq (car op) 'byte-return)
    3184           0 :         (byte-compile-discard (- byte-compile-depth end-depth) t)
    3185           0 :         (byte-compile-goto 'byte-goto endtag))
    3186             :        (t
    3187           0 :         (when (eq (car op) 'byte-switch)
    3188             :           ;; The last constant is a jump table.
    3189           0 :           (push last-constant byte-compile-jump-tables)
    3190           0 :           (setq last-switch t)
    3191             :           ;; Push all TAGs in the jump to switch-tags.
    3192           0 :           (maphash #'(lambda (_k tag)
    3193           0 :                        (push tag switch-tags))
    3194           0 :                    last-constant))
    3195           0 :         (setq last-constant (and (eq (car op) 'byte-constant) (cadr op)))
    3196           0 :         (setq last-depth byte-compile-depth)
    3197           0 :         (byte-compile-out (car op) (cdr op)))))
    3198           0 :     (byte-compile-out-tag endtag)))
    3199             : 
    3200             : (defun byte-compile-unfold-bcf (form)
    3201             :   "Inline call to byte-code-functions."
    3202           0 :   (let* ((byte-compile-bound-variables byte-compile-bound-variables)
    3203           0 :          (fun (car form))
    3204           0 :          (fargs (aref fun 0))
    3205           0 :          (start-depth byte-compile-depth)
    3206           0 :          (fmax2 (if (numberp fargs) (lsh fargs -7)))     ;2*max+rest.
    3207             :          ;; (fmin (if (numberp fargs) (logand fargs 127)))
    3208           0 :          (alen (length (cdr form)))
    3209             :          (dynbinds ())
    3210             :          lap)
    3211           0 :     (fetch-bytecode fun)
    3212           0 :     (setq lap (byte-decompile-bytecode-1 (aref fun 1) (aref fun 2) t))
    3213             :     ;; optimized switch bytecode makes it impossible to guess the correct
    3214             :     ;; `byte-compile-depth', which can result in incorrect inlined code.
    3215             :     ;; therefore, we do not inline code that uses the `byte-switch'
    3216             :     ;; instruction.
    3217           0 :     (if (assq 'byte-switch lap)
    3218           0 :         (byte-compile-normal-call form)
    3219           0 :       (mapc 'byte-compile-form (cdr form))
    3220           0 :       (unless fmax2
    3221             :         ;; Old-style byte-code.
    3222           0 :         (cl-assert (listp fargs))
    3223           0 :         (while fargs
    3224           0 :           (pcase (car fargs)
    3225           0 :             (`&optional (setq fargs (cdr fargs)))
    3226           0 :             (`&rest (setq fmax2 (+ (* 2 (length dynbinds)) 1))
    3227           0 :                     (push (cadr fargs) dynbinds)
    3228           0 :                     (setq fargs nil))
    3229           0 :             (_ (push (pop fargs) dynbinds))))
    3230           0 :         (unless fmax2 (setq fmax2 (* 2 (length dynbinds)))))
    3231           0 :       (cond
    3232           0 :        ((<= (+ alen alen) fmax2)
    3233             :         ;; Add missing &optional (or &rest) arguments.
    3234           0 :         (dotimes (_ (- (/ (1+ fmax2) 2) alen))
    3235           0 :           (byte-compile-push-constant nil)))
    3236           0 :        ((zerop (logand fmax2 1))
    3237           0 :         (byte-compile-report-error
    3238           0 :          (format "Too many arguments for inlined function %S" form))
    3239           0 :         (byte-compile-discard (- alen (/ fmax2 2))))
    3240             :        (t
    3241             :         ;; Turn &rest args into a list.
    3242           0 :         (let ((n (- alen (/ (1- fmax2) 2))))
    3243           0 :           (cl-assert (> n 0) nil "problem: fmax2=%S alen=%S n=%S" fmax2 alen n)
    3244           0 :           (if (< n 5)
    3245           0 :               (byte-compile-out
    3246           0 :                (aref [byte-list1 byte-list2 byte-list3 byte-list4] (1- n))
    3247           0 :                0)
    3248           0 :             (byte-compile-out 'byte-listN n)))))
    3249           0 :       (mapc #'byte-compile-dynamic-variable-bind dynbinds)
    3250           0 :       (byte-compile-inline-lapcode lap (1+ start-depth))
    3251             :       ;; Unbind dynamic variables.
    3252           0 :       (when dynbinds
    3253           0 :         (byte-compile-out 'byte-unbind (length dynbinds)))
    3254           0 :       (cl-assert (eq byte-compile-depth (1+ start-depth))
    3255           0 :                  nil "Wrong depth start=%s end=%s" start-depth byte-compile-depth))))
    3256             : 
    3257             : (defun byte-compile-check-variable (var access-type)
    3258             :   "Do various error checks before a use of the variable VAR."
    3259         277 :   (when (symbolp var)
    3260         277 :     (byte-compile-set-symbol-position var))
    3261         277 :   (cond ((or (not (symbolp var)) (macroexp--const-symbol-p var))
    3262           0 :          (when (byte-compile-warning-enabled-p 'constants)
    3263           0 :            (byte-compile-warn (if (eq access-type 'let-bind)
    3264             :                                   "attempt to let-bind %s `%s'"
    3265           0 :                                 "variable reference to %s `%s'")
    3266           0 :                               (if (symbolp var) "constant" "nonvariable")
    3267           0 :                               (prin1-to-string var))))
    3268         277 :         ((let ((od (get var 'byte-obsolete-variable)))
    3269         277 :            (and od
    3270           1 :                 (not (memq var byte-compile-not-obsolete-vars))
    3271           1 :                 (not (memq var byte-compile-global-not-obsolete-vars))
    3272           1 :                 (or (pcase (nth 1 od)
    3273           0 :                       (`set (not (eq access-type 'reference)))
    3274           0 :                       (`get (eq access-type 'reference))
    3275         277 :                       (_ t)))))
    3276         277 :          (byte-compile-warn-obsolete var))))
    3277             : 
    3278             : (defsubst byte-compile-dynamic-variable-op (base-op var)
    3279          60 :   (let ((tmp (assq var byte-compile-variables)))
    3280          60 :     (unless tmp
    3281          29 :       (setq tmp (list var))
    3282          60 :       (push tmp byte-compile-variables))
    3283          60 :     (byte-compile-out base-op tmp)))
    3284             : 
    3285             : (defun byte-compile-dynamic-variable-bind (var)
    3286             :   "Generate code to bind the lexical variable VAR to the top-of-stack value."
    3287          11 :   (byte-compile-check-variable var 'let-bind)
    3288          22 :   (push var byte-compile-bound-variables)
    3289          11 :   (byte-compile-dynamic-variable-op 'byte-varbind var))
    3290             : 
    3291             : (defun byte-compile-variable-ref (var)
    3292             :   "Generate code to push the value of the variable VAR on the stack."
    3293         243 :   (byte-compile-check-variable var 'reference)
    3294         243 :   (let ((lex-binding (assq var byte-compile--lexical-environment)))
    3295         243 :     (if lex-binding
    3296             :         ;; VAR is lexically bound
    3297         203 :         (byte-compile-stack-ref (cdr lex-binding))
    3298             :       ;; VAR is dynamically bound
    3299          40 :       (unless (or (not (byte-compile-warning-enabled-p 'free-vars))
    3300           2 :                   (boundp var)
    3301           0 :                   (memq var byte-compile-bound-variables)
    3302          40 :                   (memq var byte-compile-free-references))
    3303           0 :         (byte-compile-warn "reference to free variable `%S'" var)
    3304          40 :         (push var byte-compile-free-references))
    3305         243 :       (byte-compile-dynamic-variable-op 'byte-varref var))))
    3306             : 
    3307             : (defun byte-compile-variable-set (var)
    3308             :   "Generate code to set the variable VAR from the top-of-stack value."
    3309          23 :   (byte-compile-check-variable var 'assign)
    3310          23 :   (let ((lex-binding (assq var byte-compile--lexical-environment)))
    3311          23 :     (if lex-binding
    3312             :         ;; VAR is lexically bound.
    3313          14 :         (byte-compile-stack-set (cdr lex-binding))
    3314             :       ;; VAR is dynamically bound.
    3315           9 :       (unless (or (not (byte-compile-warning-enabled-p 'free-vars))
    3316           0 :                   (boundp var)
    3317           0 :                   (memq var byte-compile-bound-variables)
    3318           9 :                   (memq var byte-compile-free-assignments))
    3319           0 :         (byte-compile-warn "assignment to free variable `%s'" var)
    3320           9 :         (push var byte-compile-free-assignments))
    3321          23 :       (byte-compile-dynamic-variable-op 'byte-varset var))))
    3322             : 
    3323             : (defmacro byte-compile-get-constant (const)
    3324           1 :   `(or (if (stringp ,const)
    3325             :            ;; In a string constant, treat properties as significant.
    3326             :            (let (result)
    3327             :              (dolist (elt byte-compile-constants)
    3328           1 :                (if (equal-including-properties (car elt) ,const)
    3329             :                    (setq result elt)))
    3330             :              result)
    3331           1 :          (assq ,const byte-compile-constants))
    3332             :        (car (setq byte-compile-constants
    3333           1 :                   (cons (list ,const) byte-compile-constants)))))
    3334             : 
    3335             : ;; Use this when the value of a form is a constant.
    3336             : ;; This obeys byte-compile--for-effect.
    3337             : (defun byte-compile-constant (const)
    3338        2097 :   (if byte-compile--for-effect
    3339          39 :       (setq byte-compile--for-effect nil)
    3340        2058 :     (when (symbolp const)
    3341        2058 :       (byte-compile-set-symbol-position const))
    3342        2097 :     (byte-compile-out 'byte-constant (byte-compile-get-constant const))))
    3343             : 
    3344             : ;; Use this for a constant that is not the value of its containing form.
    3345             : ;; This ignores byte-compile--for-effect.
    3346             : (defun byte-compile-push-constant (const)
    3347         920 :   (let ((byte-compile--for-effect nil))
    3348         920 :     (inline (byte-compile-constant const))))
    3349             : 
    3350             : ;; Compile those primitive ordinary functions
    3351             : ;; which have special byte codes just for speed.
    3352             : 
    3353             : (defmacro byte-defop-compiler (function &optional compile-handler)
    3354             :   "Add a compiler-form for FUNCTION.
    3355             : If function is a symbol, then the variable \"byte-SYMBOL\" must name
    3356             : the opcode to be used.  If function is a list, the first element
    3357             : is the function and the second element is the bytecode-symbol.
    3358             : The second element may be nil, meaning there is no opcode.
    3359             : COMPILE-HANDLER is the function to use to compile this byte-op, or
    3360             : may be the abbreviations 0, 1, 2, 3, 0-1, or 1-2.
    3361             : If it is nil, then the handler is \"byte-compile-SYMBOL.\""
    3362         129 :   (let (opcode)
    3363         129 :     (if (symbolp function)
    3364          74 :         (setq opcode (intern (concat "byte-" (symbol-name function))))
    3365          55 :       (setq opcode (car (cdr function))
    3366         129 :             function (car function)))
    3367         129 :     (let ((fnform
    3368         129 :            (list 'put (list 'quote function) ''byte-compile
    3369         129 :                  (list 'quote
    3370         129 :                        (or (cdr (assq compile-handler
    3371             :                                       '((0 . byte-compile-no-args)
    3372             :                                         (1 . byte-compile-one-arg)
    3373             :                                         (2 . byte-compile-two-args)
    3374             :                                         (2-and . byte-compile-and-folded)
    3375             :                                         (3 . byte-compile-three-args)
    3376             :                                         (0-1 . byte-compile-zero-or-one-arg)
    3377             :                                         (1-2 . byte-compile-one-or-two-args)
    3378             :                                         (2-3 . byte-compile-two-or-three-args)
    3379         129 :                                         )))
    3380          52 :                            compile-handler
    3381          32 :                            (intern (concat "byte-compile-"
    3382         129 :                                            (symbol-name function))))))))
    3383         129 :       (if opcode
    3384          92 :           (list 'progn fnform
    3385          92 :                 (list 'put (list 'quote function)
    3386          92 :                       ''byte-opcode (list 'quote opcode))
    3387          92 :                 (list 'put (list 'quote opcode)
    3388          92 :                       ''byte-opcode-invert (list 'quote function)))
    3389         129 :         fnform))))
    3390             : 
    3391             : (defmacro byte-defop-compiler-1 (function &optional compile-handler)
    3392          37 :   (list 'byte-defop-compiler (list function nil) compile-handler))
    3393             : 
    3394             : 
    3395             : (put 'byte-call 'byte-opcode-invert 'funcall)
    3396             : (put 'byte-list1 'byte-opcode-invert 'list)
    3397             : (put 'byte-list2 'byte-opcode-invert 'list)
    3398             : (put 'byte-list3 'byte-opcode-invert 'list)
    3399             : (put 'byte-list4 'byte-opcode-invert 'list)
    3400             : (put 'byte-listN 'byte-opcode-invert 'list)
    3401             : (put 'byte-concat2 'byte-opcode-invert 'concat)
    3402             : (put 'byte-concat3 'byte-opcode-invert 'concat)
    3403             : (put 'byte-concat4 'byte-opcode-invert 'concat)
    3404             : (put 'byte-concatN 'byte-opcode-invert 'concat)
    3405             : (put 'byte-insertN 'byte-opcode-invert 'insert)
    3406             : 
    3407             : (byte-defop-compiler point              0)
    3408             : ;;(byte-defop-compiler mark             0) ;; obsolete
    3409             : (byte-defop-compiler point-max          0)
    3410             : (byte-defop-compiler point-min          0)
    3411             : (byte-defop-compiler following-char     0)
    3412             : (byte-defop-compiler preceding-char     0)
    3413             : (byte-defop-compiler current-column     0)
    3414             : (byte-defop-compiler eolp               0)
    3415             : (byte-defop-compiler eobp               0)
    3416             : (byte-defop-compiler bolp               0)
    3417             : (byte-defop-compiler bobp               0)
    3418             : (byte-defop-compiler current-buffer     0)
    3419             : ;;(byte-defop-compiler read-char        0) ;; obsolete
    3420             : ;; (byte-defop-compiler interactive-p   0) ;; Obsolete.
    3421             : (byte-defop-compiler widen              0)
    3422             : (byte-defop-compiler end-of-line    0-1)
    3423             : (byte-defop-compiler forward-char   0-1)
    3424             : (byte-defop-compiler forward-line   0-1)
    3425             : (byte-defop-compiler symbolp            1)
    3426             : (byte-defop-compiler consp              1)
    3427             : (byte-defop-compiler stringp            1)
    3428             : (byte-defop-compiler listp              1)
    3429             : (byte-defop-compiler not                1)
    3430             : (byte-defop-compiler (null byte-not)    1)
    3431             : (byte-defop-compiler car                1)
    3432             : (byte-defop-compiler cdr                1)
    3433             : (byte-defop-compiler length             1)
    3434             : (byte-defop-compiler symbol-value       1)
    3435             : (byte-defop-compiler symbol-function    1)
    3436             : (byte-defop-compiler (1+ byte-add1)     1)
    3437             : (byte-defop-compiler (1- byte-sub1)     1)
    3438             : (byte-defop-compiler goto-char          1)
    3439             : (byte-defop-compiler char-after         0-1)
    3440             : (byte-defop-compiler set-buffer         1)
    3441             : ;;(byte-defop-compiler set-mark         1) ;; obsolete
    3442             : (byte-defop-compiler forward-word       0-1)
    3443             : (byte-defop-compiler char-syntax        1)
    3444             : (byte-defop-compiler nreverse           1)
    3445             : (byte-defop-compiler car-safe           1)
    3446             : (byte-defop-compiler cdr-safe           1)
    3447             : (byte-defop-compiler numberp            1)
    3448             : (byte-defop-compiler integerp           1)
    3449             : (byte-defop-compiler skip-chars-forward     1-2)
    3450             : (byte-defop-compiler skip-chars-backward    1-2)
    3451             : (byte-defop-compiler eq                 2)
    3452             : (byte-defop-compiler memq               2)
    3453             : (byte-defop-compiler cons               2)
    3454             : (byte-defop-compiler aref               2)
    3455             : (byte-defop-compiler set                2)
    3456             : (byte-defop-compiler (= byte-eqlsign)   2-and)
    3457             : (byte-defop-compiler (< byte-lss)    2-and)
    3458             : (byte-defop-compiler (> byte-gtr)    2-and)
    3459             : (byte-defop-compiler (<= byte-leq)   2-and)
    3460             : (byte-defop-compiler (>= byte-geq)   2-and)
    3461             : (byte-defop-compiler get                2)
    3462             : (byte-defop-compiler nth                2)
    3463             : (byte-defop-compiler substring          2-3)
    3464             : (byte-defop-compiler (move-marker byte-set-marker) 2-3)
    3465             : (byte-defop-compiler set-marker 2-3)
    3466             : (byte-defop-compiler match-beginning    1)
    3467             : (byte-defop-compiler match-end  1)
    3468             : (byte-defop-compiler upcase             1)
    3469             : (byte-defop-compiler downcase           1)
    3470             : (byte-defop-compiler string=            2)
    3471             : (byte-defop-compiler string<         2)
    3472             : (byte-defop-compiler (string-equal byte-string=) 2)
    3473             : (byte-defop-compiler (string-lessp byte-string<) 2)
    3474             : (byte-defop-compiler equal              2)
    3475             : (byte-defop-compiler nthcdr             2)
    3476             : (byte-defop-compiler elt                2)
    3477             : (byte-defop-compiler member             2)
    3478             : (byte-defop-compiler assq               2)
    3479             : (byte-defop-compiler (rplaca byte-setcar) 2)
    3480             : (byte-defop-compiler (rplacd byte-setcdr) 2)
    3481             : (byte-defop-compiler setcar             2)
    3482             : (byte-defop-compiler setcdr             2)
    3483             : (byte-defop-compiler buffer-substring   2)
    3484             : (byte-defop-compiler delete-region      2)
    3485             : (byte-defop-compiler narrow-to-region   2)
    3486             : (byte-defop-compiler (% byte-rem)       2)
    3487             : (byte-defop-compiler aset               3)
    3488             : 
    3489             : (byte-defop-compiler max                byte-compile-associative)
    3490             : (byte-defop-compiler min                byte-compile-associative)
    3491             : (byte-defop-compiler (+ byte-plus)      byte-compile-associative)
    3492             : (byte-defop-compiler (* byte-mult)      byte-compile-associative)
    3493             : 
    3494             : ;;####(byte-defop-compiler move-to-column       1)
    3495             : (byte-defop-compiler-1 interactive byte-compile-noop)
    3496             : 
    3497             : 
    3498             : (defun byte-compile-subr-wrong-args (form n)
    3499           0 :   (byte-compile-set-symbol-position (car form))
    3500           0 :   (byte-compile-warn "`%s' called with %d arg%s, but requires %s"
    3501           0 :                      (car form) (length (cdr form))
    3502           0 :                      (if (= 1 (length (cdr form))) "" "s") n)
    3503             :   ;; Get run-time wrong-number-of-args error.
    3504           0 :   (byte-compile-normal-call form))
    3505             : 
    3506             : (defun byte-compile-no-args (form)
    3507           0 :   (if (not (= (length form) 1))
    3508           0 :       (byte-compile-subr-wrong-args form "none")
    3509           0 :     (byte-compile-out (get (car form) 'byte-opcode) 0)))
    3510             : 
    3511             : (defun byte-compile-one-arg (form)
    3512         149 :   (if (not (= (length form) 2))
    3513           0 :       (byte-compile-subr-wrong-args form 1)
    3514         149 :     (byte-compile-form (car (cdr form)))  ;; Push the argument
    3515         149 :     (byte-compile-out (get (car form) 'byte-opcode) 0)))
    3516             : 
    3517             : (defun byte-compile-two-args (form)
    3518          58 :   (if (not (= (length form) 3))
    3519           0 :       (byte-compile-subr-wrong-args form 2)
    3520          58 :     (byte-compile-form (car (cdr form)))  ;; Push the arguments
    3521          58 :     (byte-compile-form (nth 2 form))
    3522          58 :     (byte-compile-out (get (car form) 'byte-opcode) 0)))
    3523             : 
    3524             : (defun byte-compile-and-folded (form)
    3525             :   "Compile calls to functions like `<='.
    3526             : These implicitly `and' together a bunch of two-arg bytecodes."
    3527           1 :   (let ((l (length form)))
    3528           1 :     (cond
    3529           1 :      ((< l 3) (byte-compile-form `(progn ,(nth 1 form) t)))
    3530           1 :      ((= l 3) (byte-compile-two-args form))
    3531           0 :      ((cl-every #'macroexp-copyable-p (nthcdr 2 form))
    3532           0 :       (byte-compile-form `(and (,(car form) ,(nth 1 form) ,(nth 2 form))
    3533           0 :                                (,(car form) ,@(nthcdr 2 form)))))
    3534           1 :      (t (byte-compile-normal-call form)))))
    3535             : 
    3536             : (defun byte-compile-three-args (form)
    3537           0 :   (if (not (= (length form) 4))
    3538           0 :       (byte-compile-subr-wrong-args form 3)
    3539           0 :     (byte-compile-form (car (cdr form)))  ;; Push the arguments
    3540           0 :     (byte-compile-form (nth 2 form))
    3541           0 :     (byte-compile-form (nth 3 form))
    3542           0 :     (byte-compile-out (get (car form) 'byte-opcode) 0)))
    3543             : 
    3544             : (defun byte-compile-zero-or-one-arg (form)
    3545           0 :   (let ((len (length form)))
    3546           0 :     (cond ((= len 1) (byte-compile-one-arg (append form '(nil))))
    3547           0 :           ((= len 2) (byte-compile-one-arg form))
    3548           0 :           (t (byte-compile-subr-wrong-args form "0-1")))))
    3549             : 
    3550             : (defun byte-compile-one-or-two-args (form)
    3551           0 :   (let ((len (length form)))
    3552           0 :     (cond ((= len 2) (byte-compile-two-args (append form '(nil))))
    3553           0 :           ((= len 3) (byte-compile-two-args form))
    3554           0 :           (t (byte-compile-subr-wrong-args form "1-2")))))
    3555             : 
    3556             : (defun byte-compile-two-or-three-args (form)
    3557           0 :   (let ((len (length form)))
    3558           0 :     (cond ((= len 3) (byte-compile-three-args (append form '(nil))))
    3559           0 :           ((= len 4) (byte-compile-three-args form))
    3560           0 :           (t (byte-compile-subr-wrong-args form "2-3")))))
    3561             : 
    3562             : (defun byte-compile-noop (_form)
    3563           0 :   (byte-compile-constant nil))
    3564             : 
    3565             : (defun byte-compile-discard (&optional num preserve-tos)
    3566             :   "Output byte codes to discard the NUM entries at the top of the stack.
    3567             : NUM defaults to 1.
    3568             : If PRESERVE-TOS is non-nil, preserve the top-of-stack value, as if it were
    3569             : popped before discarding the num values, and then pushed back again after
    3570             : discarding."
    3571          82 :   (if (and (null num) (not preserve-tos))
    3572             :       ;; common case
    3573          49 :       (byte-compile-out 'byte-discard)
    3574             :     ;; general case
    3575          33 :     (unless num
    3576          33 :       (setq num 1))
    3577          33 :     (when (and preserve-tos (> num 0))
    3578             :       ;; Preserve the top-of-stack value by writing it directly to the stack
    3579             :       ;; location which will be at the top-of-stack after popping.
    3580          31 :       (byte-compile-stack-set (1- (- byte-compile-depth num)))
    3581             :       ;; Now we actually discard one less value, since we want to keep
    3582             :       ;; the eventual TOS
    3583          33 :       (setq num (1- num)))
    3584          46 :     (while (> num 0)
    3585          13 :       (byte-compile-out 'byte-discard)
    3586          82 :       (setq num (1- num)))))
    3587             : 
    3588             : (defun byte-compile-stack-ref (stack-pos)
    3589             :   "Output byte codes to push the value at stack position STACK-POS."
    3590         203 :   (let ((dist (- byte-compile-depth (1+ stack-pos))))
    3591         203 :     (if (zerop dist)
    3592             :         ;; A simple optimization
    3593          18 :         (byte-compile-out 'byte-dup)
    3594             :       ;; normal case
    3595         203 :       (byte-compile-out 'byte-stack-ref dist))))
    3596             : 
    3597             : (defun byte-compile-stack-set (stack-pos)
    3598             :   "Output byte codes to store the TOS value at stack position STACK-POS."
    3599          45 :   (byte-compile-out 'byte-stack-set (- byte-compile-depth (1+ stack-pos))))
    3600             : 
    3601             : (byte-defop-compiler-1 internal-make-closure byte-compile-make-closure)
    3602             : (byte-defop-compiler-1 internal-get-closed-var byte-compile-get-closed-var)
    3603             : 
    3604             : (defun byte-compile-make-closure (form)
    3605             :   "Byte-compile the special `internal-make-closure' form."
    3606          12 :   (if byte-compile--for-effect (setq byte-compile--for-effect nil)
    3607          12 :     (let* ((vars (nth 1 form))
    3608          12 :            (env (nth 2 form))
    3609          12 :            (docstring-exp (nth 3 form))
    3610          12 :            (body (nthcdr 4 form))
    3611             :            (fun
    3612          12 :             (byte-compile-lambda `(lambda ,vars . ,body) nil (length env))))
    3613          12 :       (cl-assert (or (> (length env) 0)
    3614          12 :                      docstring-exp))    ;Otherwise, we don't need a closure.
    3615          12 :       (cl-assert (byte-code-function-p fun))
    3616          12 :       (byte-compile-form `(make-byte-code
    3617          12 :                            ',(aref fun 0) ',(aref fun 1)
    3618          12 :                            (vconcat (vector . ,env) ',(aref fun 2))
    3619          65 :                            ,@(let ((rest (nthcdr 3 (mapcar (lambda (x) `',x) fun))))
    3620          12 :                                (if docstring-exp
    3621           0 :                                    `(,(car rest)
    3622           0 :                                      ,docstring-exp
    3623           0 :                                      ,@(cddr rest))
    3624          12 :                                  rest)))))))
    3625             : 
    3626             : (defun byte-compile-get-closed-var (form)
    3627             :   "Byte-compile the special `internal-get-closed-var' form."
    3628          94 :   (if byte-compile--for-effect (setq byte-compile--for-effect nil)
    3629          94 :     (byte-compile-out 'byte-constant (nth 1 form))))
    3630             : 
    3631             : ;; Compile a function that accepts one or more args and is right-associative.
    3632             : ;; We do it by left-associativity so that the operations
    3633             : ;; are done in the same order as in interpreted code.
    3634             : ;; We treat the one-arg case, as in (+ x), like (+ x 0).
    3635             : ;; in order to convert markers to numbers, and trigger expected errors.
    3636             : (defun byte-compile-associative (form)
    3637           0 :   (if (cdr form)
    3638           0 :       (let ((opcode (get (car form) 'byte-opcode))
    3639             :             args)
    3640           0 :         (if (and (< 3 (length form))
    3641           0 :                  (memq opcode (list (get '+ 'byte-opcode)
    3642           0 :                                     (get '* 'byte-opcode))))
    3643             :             ;; Don't use binary operations for > 2 operands, as that
    3644             :             ;; may cause overflow/truncation in float operations.
    3645           0 :             (byte-compile-normal-call form)
    3646           0 :           (setq args (copy-sequence (cdr form)))
    3647           0 :           (byte-compile-form (car args))
    3648           0 :           (setq args (cdr args))
    3649           0 :           (or args (setq args '(0)
    3650           0 :                          opcode (get '+ 'byte-opcode)))
    3651           0 :           (dolist (arg args)
    3652           0 :             (byte-compile-form arg)
    3653           0 :             (byte-compile-out opcode 0))))
    3654           0 :     (byte-compile-constant (eval form))))
    3655             : 
    3656             : 
    3657             : ;; more complicated compiler macros
    3658             : 
    3659             : (byte-defop-compiler char-before)
    3660             : (byte-defop-compiler backward-char)
    3661             : (byte-defop-compiler backward-word)
    3662             : (byte-defop-compiler list)
    3663             : (byte-defop-compiler concat)
    3664             : (byte-defop-compiler fset)
    3665             : (byte-defop-compiler (indent-to-column byte-indent-to) byte-compile-indent-to)
    3666             : (byte-defop-compiler indent-to)
    3667             : (byte-defop-compiler insert)
    3668             : (byte-defop-compiler-1 function byte-compile-function-form)
    3669             : (byte-defop-compiler-1 - byte-compile-minus)
    3670             : (byte-defop-compiler (/ byte-quo) byte-compile-quo)
    3671             : (byte-defop-compiler nconc)
    3672             : 
    3673             : ;; Is this worth it?  Both -before and -after are written in C.
    3674             : (defun byte-compile-char-before (form)
    3675           0 :   (cond ((or (= 1 (length form))
    3676           0 :              (and (= 2 (length form)) (not (nth 1 form))))
    3677           0 :          (byte-compile-form '(char-after (1- (point)))))
    3678           0 :         ((= 2 (length form))
    3679           0 :          (byte-compile-form (list 'char-after (if (numberp (nth 1 form))
    3680           0 :                                                   (1- (nth 1 form))
    3681           0 :                                                 `(1- (or ,(nth 1 form)
    3682           0 :                                                          (point)))))))
    3683           0 :         (t (byte-compile-subr-wrong-args form "0-1"))))
    3684             : 
    3685             : ;; backward-... ==> forward-... with negated argument.
    3686             : ;; Is this worth it?  Both -backward and -forward are written in C.
    3687             : (defun byte-compile-backward-char (form)
    3688           0 :   (cond ((or (= 1 (length form))
    3689           0 :              (and (= 2 (length form)) (not (nth 1 form))))
    3690           0 :          (byte-compile-form '(forward-char -1)))
    3691           0 :         ((= 2 (length form))
    3692           0 :          (byte-compile-form (list 'forward-char (if (numberp (nth 1 form))
    3693           0 :                                                     (- (nth 1 form))
    3694           0 :                                                   `(- (or ,(nth 1 form) 1))))))
    3695           0 :         (t (byte-compile-subr-wrong-args form "0-1"))))
    3696             : 
    3697             : (defun byte-compile-backward-word (form)
    3698           0 :   (cond ((or (= 1 (length form))
    3699           0 :              (and (= 2 (length form)) (not (nth 1 form))))
    3700           0 :          (byte-compile-form '(forward-word -1)))
    3701           0 :         ((= 2 (length form))
    3702           0 :          (byte-compile-form (list 'forward-word (if (numberp (nth 1 form))
    3703           0 :                                                     (- (nth 1 form))
    3704           0 :                                                   `(- (or ,(nth 1 form) 1))))))
    3705           0 :         (t (byte-compile-subr-wrong-args form "0-1"))))
    3706             : 
    3707             : (defun byte-compile-list (form)
    3708          14 :   (let ((count (length (cdr form))))
    3709          14 :     (cond ((= count 0)
    3710           0 :            (byte-compile-constant nil))
    3711          14 :           ((< count 5)
    3712          13 :            (mapc 'byte-compile-form (cdr form))
    3713          13 :            (byte-compile-out
    3714          13 :             (aref [byte-list1 byte-list2 byte-list3 byte-list4] (1- count)) 0))
    3715           1 :           ((< count 256)
    3716           1 :            (mapc 'byte-compile-form (cdr form))
    3717           1 :            (byte-compile-out 'byte-listN count))
    3718          14 :           (t (byte-compile-normal-call form)))))
    3719             : 
    3720             : (defun byte-compile-concat (form)
    3721           0 :   (let ((count (length (cdr form))))
    3722           0 :     (cond ((and (< 1 count) (< count 5))
    3723           0 :            (mapc 'byte-compile-form (cdr form))
    3724           0 :            (byte-compile-out
    3725           0 :             (aref [byte-concat2 byte-concat3 byte-concat4] (- count 2))
    3726           0 :             0))
    3727             :           ;; Concat of one arg is not a no-op if arg is not a string.
    3728           0 :           ((= count 0)
    3729           0 :            (byte-compile-form ""))
    3730           0 :           ((< count 256)
    3731           0 :            (mapc 'byte-compile-form (cdr form))
    3732           0 :            (byte-compile-out 'byte-concatN count))
    3733           0 :           ((byte-compile-normal-call form)))))
    3734             : 
    3735             : (defun byte-compile-minus (form)
    3736           0 :   (let ((len (length form)))
    3737           0 :     (cond
    3738           0 :      ((= 1 len) (byte-compile-constant 0))
    3739           0 :      ((= 2 len)
    3740           0 :       (byte-compile-form (cadr form))
    3741           0 :       (byte-compile-out 'byte-negate 0))
    3742           0 :      ((= 3 len)
    3743           0 :       (byte-compile-form (nth 1 form))
    3744           0 :       (byte-compile-form (nth 2 form))
    3745           0 :       (byte-compile-out 'byte-diff 0))
    3746             :      ;; Don't use binary operations for > 2 operands, as that may
    3747             :      ;; cause overflow/truncation in float operations.
    3748           0 :      (t (byte-compile-normal-call form)))))
    3749             : 
    3750             : (defun byte-compile-quo (form)
    3751           0 :   (let ((len (length form)))
    3752           0 :     (cond ((< len 2)
    3753           0 :            (byte-compile-subr-wrong-args form "1 or more"))
    3754           0 :           ((= len 3)
    3755           0 :            (byte-compile-two-args form))
    3756             :           (t
    3757             :            ;; Don't use binary operations for > 2 operands, as that
    3758             :            ;; may cause overflow/truncation in float operations.
    3759           0 :            (byte-compile-normal-call form)))))
    3760             : 
    3761             : (defun byte-compile-nconc (form)
    3762           0 :   (let ((len (length form)))
    3763           0 :     (cond ((= len 1)
    3764           0 :            (byte-compile-constant nil))
    3765           0 :           ((= len 2)
    3766             :            ;; nconc of one arg is a noop, even if that arg isn't a list.
    3767           0 :            (byte-compile-form (nth 1 form)))
    3768             :           (t
    3769           0 :            (byte-compile-form (car (setq form (cdr form))))
    3770           0 :            (while (setq form (cdr form))
    3771           0 :              (byte-compile-form (car form))
    3772           0 :              (byte-compile-out 'byte-nconc 0))))))
    3773             : 
    3774             : (defun byte-compile-fset (form)
    3775             :   ;; warn about forms like (fset 'foo '(lambda () ...))
    3776             :   ;; (where the lambda expression is non-trivial...)
    3777           0 :   (let ((fn (nth 2 form))
    3778             :         body)
    3779           0 :     (if (and (eq (car-safe fn) 'quote)
    3780           0 :              (eq (car-safe (setq fn (nth 1 fn))) 'lambda))
    3781           0 :         (progn
    3782           0 :           (setq body (cdr (cdr fn)))
    3783           0 :           (if (stringp (car body)) (setq body (cdr body)))
    3784           0 :           (if (eq 'interactive (car-safe (car body))) (setq body (cdr body)))
    3785           0 :           (if (and (consp (car body))
    3786           0 :                    (not (eq 'byte-code (car (car body)))))
    3787           0 :               (byte-compile-warn
    3788             :       "A quoted lambda form is the second argument of `fset'.  This is probably
    3789             :      not what you want, as that lambda cannot be compiled.  Consider using
    3790           0 :      the syntax #'(lambda (...) ...) instead.")))))
    3791           0 :   (byte-compile-two-args form))
    3792             : 
    3793             : ;; (function foo) must compile like 'foo, not like (symbol-function 'foo).
    3794             : ;; Otherwise it will be incompatible with the interpreter,
    3795             : ;; and (funcall (function foo)) will lose with autoloads.
    3796             : 
    3797             : (defun byte-compile-function-form (form)
    3798          17 :   (let ((f (nth 1 form)))
    3799          17 :     (when (and (symbolp f)
    3800          17 :                (byte-compile-warning-enabled-p 'callargs))
    3801          17 :       (byte-compile-function-warn f t (byte-compile-fdefinition f nil)))
    3802             : 
    3803          17 :     (byte-compile-constant (if (eq 'lambda (car-safe f))
    3804          12 :                                (byte-compile-lambda f)
    3805          17 :                              f))))
    3806             : 
    3807             : (defun byte-compile-indent-to (form)
    3808           0 :   (let ((len (length form)))
    3809           0 :     (cond ((= len 2)
    3810           0 :            (byte-compile-form (car (cdr form)))
    3811           0 :            (byte-compile-out 'byte-indent-to 0))
    3812           0 :           ((= len 3)
    3813             :            ;; no opcode for 2-arg case.
    3814           0 :            (byte-compile-normal-call form))
    3815             :           (t
    3816           0 :            (byte-compile-subr-wrong-args form "1-2")))))
    3817             : 
    3818             : (defun byte-compile-insert (form)
    3819           0 :   (cond ((null (cdr form))
    3820           0 :          (byte-compile-constant nil))
    3821           0 :         ((<= (length form) 256)
    3822           0 :          (mapc 'byte-compile-form (cdr form))
    3823           0 :          (if (cdr (cdr form))
    3824           0 :              (byte-compile-out 'byte-insertN (length (cdr form)))
    3825           0 :            (byte-compile-out 'byte-insert 0)))
    3826           0 :         ((memq t (mapcar 'consp (cdr (cdr form))))
    3827           0 :          (byte-compile-normal-call form))
    3828             :         ;; We can split it; there is no function call after inserting 1st arg.
    3829             :         (t
    3830           0 :          (while (setq form (cdr form))
    3831           0 :            (byte-compile-form (car form))
    3832           0 :            (byte-compile-out 'byte-insert 0)
    3833           0 :            (if (cdr form)
    3834           0 :                (byte-compile-discard))))))
    3835             : 
    3836             : 
    3837             : (byte-defop-compiler-1 setq)
    3838             : (byte-defop-compiler-1 setq-default)
    3839             : (byte-defop-compiler-1 quote)
    3840             : 
    3841             : (defun byte-compile-setq (form)
    3842          23 :   (let* ((args (cdr form))
    3843          23 :          (len (length args)))
    3844          23 :     (if (= (logand len 1) 1)
    3845           0 :         (progn
    3846           0 :           (byte-compile-report-error
    3847           0 :            (format-message
    3848           0 :             "missing value for `%S' at end of setq" (car (last args))))
    3849           0 :           (byte-compile-form
    3850           0 :            `(signal 'wrong-number-of-arguments '(setq ,len))
    3851           0 :            byte-compile--for-effect))
    3852          23 :       (if args
    3853          46 :           (while args
    3854          23 :             (byte-compile-form (car (cdr args)))
    3855          23 :             (or byte-compile--for-effect (cdr (cdr args))
    3856          23 :                 (byte-compile-out 'byte-dup 0))
    3857          23 :             (byte-compile-variable-set (car args))
    3858          23 :             (setq args (cdr (cdr args))))
    3859             :         ;; (setq), with no arguments.
    3860          23 :         (byte-compile-form nil byte-compile--for-effect)))
    3861          23 :     (setq byte-compile--for-effect nil)))
    3862             : 
    3863             : (defun byte-compile-setq-default (form)
    3864           0 :   (setq form (cdr form))
    3865           0 :   (if (null form)                       ; (setq-default), with no arguments
    3866           0 :       (byte-compile-form nil byte-compile--for-effect)
    3867           0 :     (if (> (length form) 2)
    3868           0 :         (let ((setters ()))
    3869           0 :           (while (consp form)
    3870           0 :             (push `(setq-default ,(pop form) ,(pop form)) setters))
    3871           0 :           (byte-compile-form (cons 'progn (nreverse setters))))
    3872           0 :       (let ((var (car form)))
    3873           0 :         (and (or (not (symbolp var))
    3874           0 :                  (macroexp--const-symbol-p var t))
    3875           0 :              (byte-compile-warning-enabled-p 'constants)
    3876           0 :              (byte-compile-warn
    3877             :               "variable assignment to %s `%s'"
    3878           0 :               (if (symbolp var) "constant" "nonvariable")
    3879           0 :               (prin1-to-string var)))
    3880           0 :         (byte-compile-normal-call `(set-default ',var ,@(cdr form)))))))
    3881             : 
    3882             : (byte-defop-compiler-1 set-default)
    3883             : (defun byte-compile-set-default (form)
    3884           0 :   (let ((varexp (car-safe (cdr-safe form))))
    3885           0 :     (if (eq (car-safe varexp) 'quote)
    3886             :         ;; If the varexp is constant, compile it as a setq-default
    3887             :         ;; so we get more warnings.
    3888           0 :         (byte-compile-setq-default `(setq-default ,(car-safe (cdr varexp))
    3889           0 :                                                   ,@(cddr form)))
    3890           0 :       (byte-compile-normal-call form))))
    3891             : 
    3892             : (defun byte-compile-quote (form)
    3893         156 :   (byte-compile-constant (car (cdr form))))
    3894             : 
    3895             : ;;; control structures
    3896             : 
    3897             : (defun byte-compile-body (body &optional for-effect)
    3898         197 :   (while (cdr body)
    3899          86 :     (byte-compile-form (car body) t)
    3900         111 :     (setq body (cdr body)))
    3901         111 :   (byte-compile-form (car body) for-effect))
    3902             : 
    3903             : (defsubst byte-compile-body-do-effect (body)
    3904          67 :   (byte-compile-body body byte-compile--for-effect)
    3905          67 :   (setq byte-compile--for-effect nil))
    3906             : 
    3907             : (defsubst byte-compile-form-do-effect (form)
    3908          72 :   (byte-compile-form form byte-compile--for-effect)
    3909          72 :   (setq byte-compile--for-effect nil))
    3910             : 
    3911             : (byte-defop-compiler-1 inline byte-compile-progn)
    3912             : (byte-defop-compiler-1 progn)
    3913             : (byte-defop-compiler-1 prog1)
    3914             : (byte-defop-compiler-1 prog2)
    3915             : (byte-defop-compiler-1 if)
    3916             : (byte-defop-compiler-1 cond)
    3917             : (byte-defop-compiler-1 and)
    3918             : (byte-defop-compiler-1 or)
    3919             : (byte-defop-compiler-1 while)
    3920             : (byte-defop-compiler-1 funcall)
    3921             : (byte-defop-compiler-1 let)
    3922             : (byte-defop-compiler-1 let* byte-compile-let)
    3923             : 
    3924             : (defun byte-compile-progn (form)
    3925          27 :   (byte-compile-body-do-effect (cdr form)))
    3926             : 
    3927             : (defun byte-compile-prog1 (form)
    3928           0 :   (byte-compile-form-do-effect (car (cdr form)))
    3929           0 :   (byte-compile-body (cdr (cdr form)) t))
    3930             : 
    3931             : (defun byte-compile-prog2 (form)
    3932           0 :   (byte-compile-form (nth 1 form) t)
    3933           0 :   (byte-compile-form-do-effect (nth 2 form))
    3934           0 :   (byte-compile-body (cdr (cdr (cdr form))) t))
    3935             : 
    3936             : (defmacro byte-compile-goto-if (cond discard tag)
    3937           6 :   `(byte-compile-goto
    3938           6 :     (if ,cond
    3939           6 :         (if ,discard 'byte-goto-if-not-nil 'byte-goto-if-not-nil-else-pop)
    3940           6 :       (if ,discard 'byte-goto-if-nil 'byte-goto-if-nil-else-pop))
    3941           6 :     ,tag))
    3942             : 
    3943             : ;; Return the list of items in CONDITION-PARAM that match PRED-LIST.
    3944             : ;; Only return items that are not in ONLY-IF-NOT-PRESENT.
    3945             : (defun byte-compile-find-bound-condition (condition-param
    3946             :                                           pred-list
    3947             :                                           &optional only-if-not-present)
    3948         286 :   (let ((result nil)
    3949             :         (nth-one nil)
    3950             :         (cond-list
    3951         286 :          (if (memq (car-safe condition-param) pred-list)
    3952             :              ;; The condition appears by itself.
    3953           0 :              (list condition-param)
    3954             :            ;; If the condition is an `and', look for matches among the
    3955             :            ;; `and' arguments.
    3956         286 :            (when (eq 'and (car-safe condition-param))
    3957         286 :              (cdr condition-param)))))
    3958             : 
    3959         286 :     (dolist (crt cond-list)
    3960           0 :       (when (and (memq (car-safe crt) pred-list)
    3961           0 :                  (eq 'quote (car-safe (setq nth-one (nth 1 crt))))
    3962             :                  ;; Ignore if the symbol is already on the unresolved
    3963             :                  ;; list.
    3964           0 :                  (not (assq (nth 1 nth-one) ; the relevant symbol
    3965           0 :                             only-if-not-present)))
    3966         286 :         (push (nth 1 (nth 1 crt)) result)))
    3967         286 :     result))
    3968             : 
    3969             : (defmacro byte-compile-maybe-guarded (condition &rest body)
    3970             :   "Execute forms in BODY, potentially guarded by CONDITION.
    3971             : CONDITION is a variable whose value is a test in an `if' or `cond'.
    3972             : BODY is the code to compile in the first arm of the if or the body of
    3973             : the cond clause.  If CONDITION's value is of the form (fboundp \\='foo)
    3974             : or (boundp \\='foo), the relevant warnings from BODY about foo's
    3975             : being undefined (or obsolete) will be suppressed.
    3976             : 
    3977             : If CONDITION's value is (not (featurep \\='emacs)) or (featurep \\='xemacs),
    3978             : that suppresses all warnings during execution of BODY."
    3979             :   (declare (indent 1) (debug t))
    3980           7 :   `(let* ((fbound-list (byte-compile-find-bound-condition
    3981           7 :                         ,condition '(fboundp functionp)
    3982             :                         byte-compile-unresolved-functions))
    3983             :           (bound-list (byte-compile-find-bound-condition
    3984           7 :                        ,condition '(boundp default-boundp)))
    3985             :           ;; Maybe add to the bound list.
    3986             :           (byte-compile-bound-variables
    3987             :            (append bound-list byte-compile-bound-variables)))
    3988             :      (unwind-protect
    3989             :          ;; If things not being bound at all is ok, so must them being
    3990             :          ;; obsolete.  Note that we add to the existing lists since Tramp
    3991             :          ;; (ab)uses this feature.
    3992             :          ;; FIXME: If `foo' is obsoleted by `bar', the code below
    3993             :          ;; correctly arranges to silence the warnings after testing
    3994             :          ;; existence of `foo', but the warning should also be
    3995             :          ;; silenced after testing the existence of `bar'.
    3996             :          (let ((byte-compile-not-obsolete-vars
    3997             :                 (append byte-compile-not-obsolete-vars bound-list))
    3998             :                (byte-compile-not-obsolete-funcs
    3999             :                 (append byte-compile-not-obsolete-funcs fbound-list)))
    4000           7 :            ,@body)
    4001             :        ;; Maybe remove the function symbol from the unresolved list.
    4002             :        (dolist (fbound fbound-list)
    4003             :          (when fbound
    4004             :            (setq byte-compile-unresolved-functions
    4005             :                  (delq (assq fbound byte-compile-unresolved-functions)
    4006           7 :                        byte-compile-unresolved-functions)))))))
    4007             : 
    4008             : (defun byte-compile-if (form)
    4009          50 :   (byte-compile-form (car (cdr form)))
    4010             :   ;; Check whether we have `(if (fboundp ...' or `(if (boundp ...'
    4011             :   ;; and avoid warnings about the relevant symbols in the consequent.
    4012          50 :   (let ((clause (nth 1 form))
    4013          50 :         (donetag (byte-compile-make-tag)))
    4014          50 :     (if (null (nthcdr 3 form))
    4015             :         ;; No else-forms
    4016          22 :         (progn
    4017          22 :           (byte-compile-goto-if nil byte-compile--for-effect donetag)
    4018          44 :           (byte-compile-maybe-guarded clause
    4019          22 :             (byte-compile-form (nth 2 form) byte-compile--for-effect))
    4020          22 :           (byte-compile-out-tag donetag))
    4021          28 :       (let ((elsetag (byte-compile-make-tag)))
    4022          28 :         (byte-compile-goto 'byte-goto-if-nil elsetag)
    4023          56 :         (byte-compile-maybe-guarded clause
    4024          28 :           (byte-compile-form (nth 2 form) byte-compile--for-effect))
    4025          28 :         (byte-compile-goto 'byte-goto donetag)
    4026          28 :         (byte-compile-out-tag elsetag)
    4027          56 :         (byte-compile-maybe-guarded (list 'not clause)
    4028          28 :           (byte-compile-body (cdr (cdr (cdr form))) byte-compile--for-effect))
    4029          50 :         (byte-compile-out-tag donetag))))
    4030          50 :   (setq byte-compile--for-effect nil))
    4031             : 
    4032             : (defun byte-compile-cond-vars (obj1 obj2)
    4033             :   ;; We make sure that of OBJ1 and OBJ2, one of them is a symbol,
    4034             :   ;; and the other is a constant expression whose value can be
    4035             :   ;; compared with `eq' (with `macroexp-const-p').
    4036           5 :   (or
    4037           5 :    (and (symbolp obj1) (macroexp-const-p obj2) (cons obj1 obj2))
    4038           5 :    (and (symbolp obj2) (macroexp-const-p obj1) (cons obj2 obj1))))
    4039             : 
    4040             : (defun byte-compile-cond-jump-table-info (clauses)
    4041             :   "If CLAUSES is a `cond' form where:
    4042             : The condition for each clause is of the form (TEST VAR VALUE).
    4043             : VAR is a variable.
    4044             : TEST and VAR are the same throughout all conditions.
    4045             : VALUE satisfies `macroexp-const-p'.
    4046             : 
    4047             : Return a list of the form ((TEST . VAR)  ((VALUE BODY) ...))"
    4048           5 :   (let ((cases '())
    4049             :         (ok t)
    4050             :         prev-var prev-test)
    4051           5 :     (and (catch 'break
    4052           5 :            (dolist (clause (cdr clauses) ok)
    4053           5 :              (let* ((condition (car clause))
    4054           5 :                     (test (car-safe condition))
    4055           5 :                     (vars (when (consp condition)
    4056           5 :                             (byte-compile-cond-vars (cadr condition) (cl-caddr condition))))
    4057           5 :                     (obj1 (car-safe vars))
    4058           5 :                     (obj2 (cdr-safe vars))
    4059           5 :                     (body (cdr-safe clause)))
    4060           5 :                (unless prev-var
    4061           5 :                  (setq prev-var obj1))
    4062           5 :                (unless prev-test
    4063           5 :                  (setq prev-test test))
    4064           5 :                (if (and obj1 (memq test '(eq eql equal))
    4065           0 :                         (consp condition)
    4066           0 :                         (eq test prev-test)
    4067           0 :                         (eq obj1 prev-var)
    4068             :                         ;; discard duplicate clauses
    4069           5 :                         (not (assq obj2 cases)))
    4070           0 :                    (push (list (if (consp obj2) (eval obj2) obj2) body) cases)
    4071           5 :                  (if (and (macroexp-const-p condition) condition)
    4072           0 :                      (progn (push (list 'default (or body `(,condition))) cases)
    4073           0 :                             (throw 'break t))
    4074           5 :                    (setq ok nil)
    4075           5 :                    (throw 'break nil))))))
    4076           5 :          (list (cons prev-test prev-var) (nreverse cases)))))
    4077             : 
    4078             : (defun byte-compile-cond-jump-table (clauses)
    4079           5 :   (let* ((table-info (byte-compile-cond-jump-table-info clauses))
    4080           5 :          (test (caar table-info))
    4081           5 :          (var (cdar table-info))
    4082           5 :          (cases (cadr table-info))
    4083             :          jump-table test-obj body tag donetag default-tag default-case)
    4084           5 :     (when (and cases (not (= (length cases) 1)))
    4085             :       ;; TODO: Once :linear-search is implemented for `make-hash-table'
    4086             :       ;; set it to `t' for cond forms with a small number of cases.
    4087           0 :       (setq jump-table (make-hash-table :test test
    4088             :                                         :purecopy t
    4089           0 :                                         :size (if (assq 'default cases)
    4090           0 :                                                   (1- (length cases))
    4091           0 :                                                 (length cases)))
    4092           0 :             default-tag (byte-compile-make-tag)
    4093           0 :             donetag (byte-compile-make-tag))
    4094             :       ;; The structure of byte-switch code:
    4095             :       ;;
    4096             :       ;; varref var
    4097             :       ;; constant #s(hash-table purecopy t data (val1 (TAG1) val2 (TAG2)))
    4098             :       ;; switch
    4099             :       ;; goto DEFAULT-TAG
    4100             :       ;; TAG1
    4101             :       ;; <clause body>
    4102             :       ;; goto DONETAG
    4103             :       ;; TAG2
    4104             :       ;; <clause body>
    4105             :       ;; goto DONETAG
    4106             :       ;; DEFAULT-TAG
    4107             :       ;; <body for `t' clause, if any (else `constant nil')>
    4108             :       ;; DONETAG
    4109             : 
    4110           0 :       (byte-compile-variable-ref var)
    4111           0 :       (byte-compile-push-constant jump-table)
    4112           0 :       (byte-compile-out 'byte-switch)
    4113             : 
    4114             :       ;; When the opcode argument is `byte-goto', `byte-compile-goto' sets
    4115             :       ;; `byte-compile-depth' to `nil'. However, we need `byte-compile-depth'
    4116             :       ;; to be non-nil for generating tags for all cases. Since
    4117             :       ;; `byte-compile-depth' will increase by at most 1 after compiling
    4118             :       ;; all of the clause (which is further enforced by cl-assert below)
    4119             :       ;; it should be safe to preserve it's value.
    4120           0 :       (let ((byte-compile-depth byte-compile-depth))
    4121           0 :         (byte-compile-goto 'byte-goto default-tag))
    4122             : 
    4123           0 :       (when (assq 'default cases)
    4124           0 :         (setq default-case (cadr (assq 'default cases))
    4125           0 :               cases (butlast cases 1)))
    4126             : 
    4127           0 :       (dolist (case cases)
    4128           0 :         (setq tag (byte-compile-make-tag)
    4129           0 :               test-obj (nth 0 case)
    4130           0 :               body (nth 1 case))
    4131           0 :         (byte-compile-out-tag tag)
    4132           0 :         (puthash test-obj tag jump-table)
    4133             : 
    4134           0 :         (let ((byte-compile-depth byte-compile-depth)
    4135           0 :               (init-depth byte-compile-depth))
    4136             :           ;; Since `byte-compile-body' might increase `byte-compile-depth'
    4137             :           ;; by 1, not preserving it's value will cause it to potentially
    4138             :           ;; increase by one for every clause body compiled, causing
    4139             :           ;; depth/tag conflicts or violating asserts down the road.
    4140             :           ;; To make sure `byte-compile-body' itself doesn't violate this,
    4141             :           ;; we use `cl-assert'.
    4142           0 :           (if (null body)
    4143           0 :               (byte-compile-form t byte-compile--for-effect)
    4144           0 :             (byte-compile-body body byte-compile--for-effect))
    4145           0 :           (cl-assert (or (= byte-compile-depth init-depth)
    4146           0 :                          (= byte-compile-depth (1+ init-depth))))
    4147           0 :           (byte-compile-goto 'byte-goto donetag)
    4148           0 :           (setcdr (cdr donetag) nil)))
    4149             : 
    4150           0 :       (byte-compile-out-tag default-tag)
    4151           0 :       (if default-case
    4152           0 :           (byte-compile-body-do-effect default-case)
    4153           0 :         (byte-compile-constant nil))
    4154           0 :       (byte-compile-out-tag donetag)
    4155           5 :       (push jump-table byte-compile-jump-tables))))
    4156             : 
    4157             : (defun byte-compile-cond (clauses)
    4158           5 :   (or (and byte-compile-cond-use-jump-table
    4159           5 :            (byte-compile-cond-jump-table clauses))
    4160           5 :     (let ((donetag (byte-compile-make-tag))
    4161             :           nexttag clause)
    4162          21 :       (while (setq clauses (cdr clauses))
    4163          16 :         (setq clause (car clauses))
    4164          16 :         (cond ((or (eq (car clause) t)
    4165          14 :                    (and (eq (car-safe (car clause)) 'quote)
    4166          16 :                         (car-safe (cdr-safe (car clause)))))
    4167             :                ;; Unconditional clause
    4168           2 :                (setq clause (cons t clause)
    4169           2 :                      clauses nil))
    4170          14 :               ((cdr clauses)
    4171          11 :                (byte-compile-form (car clause))
    4172          11 :                (if (null (cdr clause))
    4173             :                    ;; First clause is a singleton.
    4174           0 :                    (byte-compile-goto-if t byte-compile--for-effect donetag)
    4175          11 :                  (setq nexttag (byte-compile-make-tag))
    4176          11 :                  (byte-compile-goto 'byte-goto-if-nil nexttag)
    4177          22 :                  (byte-compile-maybe-guarded (car clause)
    4178          11 :                    (byte-compile-body (cdr clause) byte-compile--for-effect))
    4179          11 :                  (byte-compile-goto 'byte-goto donetag)
    4180          16 :                  (byte-compile-out-tag nexttag)))))
    4181             :       ;; Last clause
    4182           5 :       (let ((guard (car clause)))
    4183           5 :         (and (cdr clause) (not (eq guard t))
    4184           1 :              (progn (byte-compile-form guard)
    4185           1 :                     (byte-compile-goto-if nil byte-compile--for-effect donetag)
    4186           5 :                     (setq clause (cdr clause))))
    4187          10 :         (byte-compile-maybe-guarded guard
    4188           5 :           (byte-compile-body-do-effect clause)))
    4189           5 :       (byte-compile-out-tag donetag))))
    4190             : 
    4191             : (defun byte-compile-and (form)
    4192          19 :   (let ((failtag (byte-compile-make-tag))
    4193          19 :         (args (cdr form)))
    4194          19 :     (if (null args)
    4195           0 :         (byte-compile-form-do-effect t)
    4196          19 :       (byte-compile-and-recursion args failtag))))
    4197             : 
    4198             : ;; Handle compilation of a nontrivial `and' call.
    4199             : ;; We use tail recursion so we can use byte-compile-maybe-guarded.
    4200             : (defun byte-compile-and-recursion (rest failtag)
    4201          44 :   (if (cdr rest)
    4202          25 :       (progn
    4203          25 :         (byte-compile-form (car rest))
    4204          25 :         (byte-compile-goto-if nil byte-compile--for-effect failtag)
    4205          50 :         (byte-compile-maybe-guarded (car rest)
    4206          25 :           (byte-compile-and-recursion (cdr rest) failtag)))
    4207          19 :     (byte-compile-form-do-effect (car rest))
    4208          44 :     (byte-compile-out-tag failtag)))
    4209             : 
    4210             : (defun byte-compile-or (form)
    4211          18 :   (let ((wintag (byte-compile-make-tag))
    4212          18 :         (args (cdr form)))
    4213          18 :     (if (null args)
    4214           0 :         (byte-compile-form-do-effect nil)
    4215          18 :       (byte-compile-or-recursion args wintag))))
    4216             : 
    4217             : ;; Handle compilation of a nontrivial `or' call.
    4218             : ;; We use tail recursion so we can use byte-compile-maybe-guarded.
    4219             : (defun byte-compile-or-recursion (rest wintag)
    4220          42 :   (if (cdr rest)
    4221          24 :       (progn
    4222          24 :         (byte-compile-form (car rest))
    4223          24 :         (byte-compile-goto-if t byte-compile--for-effect wintag)
    4224          48 :         (byte-compile-maybe-guarded (list 'not (car rest))
    4225          24 :           (byte-compile-or-recursion (cdr rest) wintag)))
    4226          18 :     (byte-compile-form-do-effect (car rest))
    4227          42 :     (byte-compile-out-tag wintag)))
    4228             : 
    4229             : (defun byte-compile-while (form)
    4230           5 :   (let ((endtag (byte-compile-make-tag))
    4231           5 :         (looptag (byte-compile-make-tag)))
    4232           5 :     (byte-compile-out-tag looptag)
    4233           5 :     (byte-compile-form (car (cdr form)))
    4234           5 :     (byte-compile-goto-if nil byte-compile--for-effect endtag)
    4235           5 :     (byte-compile-body (cdr (cdr form)) t)
    4236           5 :     (byte-compile-goto 'byte-goto looptag)
    4237           5 :     (byte-compile-out-tag endtag)
    4238           5 :     (setq byte-compile--for-effect nil)))
    4239             : 
    4240             : (defun byte-compile-funcall (form)
    4241          13 :   (if (cdr form)
    4242          13 :       (progn
    4243          13 :         (mapc 'byte-compile-form (cdr form))
    4244          13 :         (byte-compile-out 'byte-call (length (cdr (cdr form)))))
    4245           0 :     (byte-compile-report-error
    4246           0 :      (format-message "`funcall' called with no arguments"))
    4247           0 :     (byte-compile-form '(signal 'wrong-number-of-arguments '(funcall 0))
    4248          13 :                        byte-compile--for-effect)))
    4249             : 
    4250             : 
    4251             : ;; let binding
    4252             : 
    4253             : (defun byte-compile-push-binding-init (clause)
    4254             :   "Emit byte-codes to push the initialization value for CLAUSE on the stack.
    4255             : Return the offset in the form (VAR . OFFSET)."
    4256          55 :   (let* ((var (if (consp clause) (car clause) clause)))
    4257             :     ;; We record the stack position even of dynamic bindings; we'll put
    4258             :     ;; them in the proper place later.
    4259          55 :     (prog1 (cons var byte-compile-depth)
    4260          55 :       (if (consp clause)
    4261          55 :           (byte-compile-form (cadr clause))
    4262          55 :         (byte-compile-push-constant nil)))))
    4263             : 
    4264             : (defun byte-compile-not-lexical-var-p (var)
    4265         155 :   (or (not (symbolp var))
    4266         155 :       (special-variable-p var)
    4267         137 :       (memq var byte-compile-bound-variables)
    4268         133 :       (memq var '(nil t))
    4269         155 :       (keywordp var)))
    4270             : 
    4271             : (defun byte-compile-bind (var init-lexenv)
    4272             :   "Emit byte-codes to bind VAR and update `byte-compile--lexical-environment'.
    4273             : INIT-LEXENV should be a lexical-environment alist describing the
    4274             : positions of the init value that have been pushed on the stack.
    4275             : Return non-nil if the TOS value was popped."
    4276             :   ;; The mix of lexical and dynamic bindings mean that we may have to
    4277             :   ;; juggle things on the stack, to move them to TOS for
    4278             :   ;; dynamic binding.
    4279          55 :   (if (and lexical-binding (not (byte-compile-not-lexical-var-p var)))
    4280             :       ;; VAR is a simple stack-allocated lexical variable.
    4281          44 :       (progn (push (assq var init-lexenv)
    4282          88 :                    byte-compile--lexical-environment)
    4283          44 :              nil)
    4284             :     ;; VAR should be dynamically bound.
    4285          11 :     (while (assq var byte-compile--lexical-environment)
    4286             :       ;; This dynamic binding shadows a lexical binding.
    4287           0 :       (setq byte-compile--lexical-environment
    4288           0 :             (remq (assq var byte-compile--lexical-environment)
    4289          11 :                   byte-compile--lexical-environment)))
    4290          11 :     (cond
    4291          11 :      ((eq var (caar init-lexenv))
    4292             :       ;; VAR is dynamic and is on the top of the
    4293             :       ;; stack, so we can just bind it like usual.
    4294          11 :       (byte-compile-dynamic-variable-bind var)
    4295             :       t)
    4296             :      (t
    4297             :       ;; VAR is dynamic, but we have to get its
    4298             :       ;; value out of the middle of the stack.
    4299           0 :       (let ((stack-pos (cdr (assq var init-lexenv))))
    4300           0 :         (byte-compile-stack-ref stack-pos)
    4301           0 :         (byte-compile-dynamic-variable-bind var)
    4302             :         ;; Now we have to store nil into its temporary
    4303             :         ;; stack position so it doesn't prevent the value from being GC'd.
    4304             :         ;; FIXME: Not worth the trouble.
    4305             :         ;; (byte-compile-push-constant nil)
    4306             :         ;; (byte-compile-stack-set stack-pos)
    4307           0 :         )
    4308          55 :       nil))))
    4309             : 
    4310             : (defun byte-compile-unbind (clauses init-lexenv preserve-body-value)
    4311             :   "Emit byte-codes to unbind the variables bound by CLAUSES.
    4312             : CLAUSES is a `let'-style variable binding list.  INIT-LEXENV should be a
    4313             : lexical-environment alist describing the positions of the init value that
    4314             : have been pushed on the stack.  If PRESERVE-BODY-VALUE is true,
    4315             : then an additional value on the top of the stack, above any lexical binding
    4316             : slots, is preserved, so it will be on the top of the stack after all
    4317             : binding slots have been popped."
    4318             :   ;; Unbind dynamic variables.
    4319          35 :   (let ((num-dynamic-bindings 0))
    4320          35 :     (dolist (clause clauses)
    4321          55 :       (unless (assq (if (consp clause) (car clause) clause)
    4322          55 :                     byte-compile--lexical-environment)
    4323          55 :         (setq num-dynamic-bindings (1+ num-dynamic-bindings))))
    4324          35 :     (unless (zerop num-dynamic-bindings)
    4325          35 :       (byte-compile-out 'byte-unbind num-dynamic-bindings)))
    4326             :   ;; Pop lexical variables off the stack, possibly preserving the
    4327             :   ;; return value of the body.
    4328          35 :   (when init-lexenv
    4329             :     ;; INIT-LEXENV contains all init values left on the stack.
    4330          35 :     (byte-compile-discard (length init-lexenv) preserve-body-value)))
    4331             : 
    4332             : (defun byte-compile-let (form)
    4333             :   "Generate code for the `let' or `let*' form FORM."
    4334          35 :   (let ((clauses (cadr form))
    4335             :         (init-lexenv nil)
    4336          35 :         (is-let (eq (car form) 'let)))
    4337          35 :     (when is-let
    4338             :       ;; First compute the binding values in the old scope.
    4339          18 :       (dolist (var clauses)
    4340          60 :         (push (byte-compile-push-binding-init var) init-lexenv)))
    4341             :     ;; New scope.
    4342          35 :     (let ((byte-compile-bound-variables byte-compile-bound-variables)
    4343             :           (byte-compile--lexical-environment
    4344          35 :            byte-compile--lexical-environment))
    4345             :       ;; Bind the variables.
    4346             :       ;; For `let', do it in reverse order, because it makes no
    4347             :       ;; semantic difference, but it is a lot more efficient since the
    4348             :       ;; values are now in reverse order on the stack.
    4349          35 :       (dolist (var (if is-let (reverse clauses) clauses))
    4350          55 :         (unless is-let
    4351          55 :           (push (byte-compile-push-binding-init var) init-lexenv))
    4352          55 :         (let ((var (if (consp var) (car var) var)))
    4353          55 :           (if (byte-compile-bind var init-lexenv)
    4354          55 :               (pop init-lexenv))))
    4355             :       ;; Emit the body.
    4356          35 :       (let ((init-stack-depth byte-compile-depth))
    4357          35 :         (byte-compile-body-do-effect (cdr (cdr form)))
    4358             :         ;; Unbind both lexical and dynamic variables.
    4359          35 :         (cl-assert (or (eq byte-compile-depth init-stack-depth)
    4360          35 :                        (eq byte-compile-depth (1+ init-stack-depth))))
    4361          35 :         (byte-compile-unbind clauses init-lexenv
    4362          35 :                              (> byte-compile-depth init-stack-depth))))))
    4363             : 
    4364             : 
    4365             : 
    4366             : (byte-defop-compiler-1 /= byte-compile-negated)
    4367             : (byte-defop-compiler-1 atom byte-compile-negated)
    4368             : (byte-defop-compiler-1 nlistp byte-compile-negated)
    4369             : 
    4370             : (put '/= 'byte-compile-negated-op '=)
    4371             : (put 'atom 'byte-compile-negated-op 'consp)
    4372             : (put 'nlistp 'byte-compile-negated-op 'listp)
    4373             : 
    4374             : (defun byte-compile-negated (form)
    4375           0 :   (byte-compile-form-do-effect (byte-compile-negation-optimizer form)))
    4376             : 
    4377             : ;; Even when optimization is off, /= is optimized to (not (= ...)).
    4378             : (defun byte-compile-negation-optimizer (form)
    4379             :   ;; an optimizer for forms where <form1> is less efficient than (not <form2>)
    4380           0 :   (byte-compile-set-symbol-position (car form))
    4381           0 :   (list 'not
    4382           0 :     (cons (or (get (car form) 'byte-compile-negated-op)
    4383           0 :               (error
    4384             :                "Compiler error: `%s' has no `byte-compile-negated-op' property"
    4385           0 :                (car form)))
    4386           0 :           (cdr form))))
    4387             : 
    4388             : ;;; other tricky macro-like special-forms
    4389             : 
    4390             : (byte-defop-compiler-1 catch)
    4391             : (byte-defop-compiler-1 unwind-protect)
    4392             : (byte-defop-compiler-1 condition-case)
    4393             : (byte-defop-compiler-1 save-excursion)
    4394             : (byte-defop-compiler-1 save-current-buffer)
    4395             : (byte-defop-compiler-1 save-restriction)
    4396             : ;; (byte-defop-compiler-1 save-window-excursion)      ;Obsolete: now a macro.
    4397             : ;; (byte-defop-compiler-1 with-output-to-temp-buffer) ;Obsolete: now a macro.
    4398             : 
    4399             : (defvar byte-compile--use-old-handlers nil
    4400             :   "If nil, use new byte codes introduced in Emacs-24.4.")
    4401             : 
    4402             : (defun byte-compile-catch (form)
    4403           0 :   (byte-compile-form (car (cdr form)))
    4404           0 :   (if (not byte-compile--use-old-handlers)
    4405           0 :       (let ((endtag (byte-compile-make-tag)))
    4406           0 :         (byte-compile-goto 'byte-pushcatch endtag)
    4407           0 :         (byte-compile-body (cddr form) nil)
    4408           0 :         (byte-compile-out 'byte-pophandler)
    4409           0 :         (byte-compile-out-tag endtag))
    4410           0 :     (pcase (cddr form)
    4411             :       (`(:fun-body ,f)
    4412           0 :        (byte-compile-form `(list 'funcall ,f)))
    4413             :       (body
    4414           0 :        (byte-compile-push-constant
    4415           0 :         (byte-compile-top-level (cons 'progn body) byte-compile--for-effect))))
    4416           0 :     (byte-compile-out 'byte-catch 0)))
    4417             : 
    4418             : (defun byte-compile-unwind-protect (form)
    4419           0 :   (pcase (cddr form)
    4420             :     (`(:fun-body ,f)
    4421           0 :      (byte-compile-form
    4422           0 :       (if byte-compile--use-old-handlers `(list (list 'funcall ,f)) f)))
    4423             :     (handlers
    4424           0 :      (if byte-compile--use-old-handlers
    4425           0 :          (byte-compile-push-constant
    4426           0 :           (byte-compile-top-level-body handlers t))
    4427           0 :        (byte-compile-form `#'(lambda () ,@handlers)))))
    4428           0 :   (byte-compile-out 'byte-unwind-protect 0)
    4429           0 :   (byte-compile-form-do-effect (car (cdr form)))
    4430           0 :   (byte-compile-out 'byte-unbind 1))
    4431             : 
    4432             : (defun byte-compile-condition-case (form)
    4433           0 :   (if byte-compile--use-old-handlers
    4434           0 :       (byte-compile-condition-case--old form)
    4435           0 :     (byte-compile-condition-case--new form)))
    4436             : 
    4437             : (defun byte-compile-condition-case--old (form)
    4438           0 :   (let* ((var (nth 1 form))
    4439           0 :          (fun-bodies (eq var :fun-body))
    4440             :          (byte-compile-bound-variables
    4441           0 :           (if (and var (not fun-bodies))
    4442           0 :               (cons var byte-compile-bound-variables)
    4443           0 :             byte-compile-bound-variables)))
    4444           0 :     (byte-compile-set-symbol-position 'condition-case)
    4445           0 :     (unless (symbolp var)
    4446           0 :       (byte-compile-warn
    4447           0 :        "`%s' is not a variable-name or nil (in condition-case)" var))
    4448           0 :     (if fun-bodies (setq var (make-symbol "err")))
    4449           0 :     (byte-compile-push-constant var)
    4450           0 :     (if fun-bodies
    4451           0 :         (byte-compile-form `(list 'funcall ,(nth 2 form)))
    4452           0 :       (byte-compile-push-constant
    4453           0 :        (byte-compile-top-level (nth 2 form) byte-compile--for-effect)))
    4454           0 :     (let ((compiled-clauses
    4455           0 :            (mapcar
    4456             :             (lambda (clause)
    4457           0 :               (let ((condition (car clause)))
    4458           0 :                 (cond ((not (or (symbolp condition)
    4459           0 :                                 (and (listp condition)
    4460           0 :                                      (let ((ok t))
    4461           0 :                                        (dolist (sym condition)
    4462           0 :                                          (if (not (symbolp sym))
    4463           0 :                                              (setq ok nil)))
    4464           0 :                                        ok))))
    4465           0 :                        (byte-compile-warn
    4466             :                         "`%S' is not a condition name or list of such (in condition-case)"
    4467           0 :                         condition))
    4468             :                       ;; (not (or (eq condition 't)
    4469             :                       ;;         (and (stringp (get condition 'error-message))
    4470             :                       ;;              (consp (get condition
    4471             :                       ;;                          'error-conditions)))))
    4472             :                       ;; (byte-compile-warn
    4473             :                       ;;   "`%s' is not a known condition name
    4474             :                       ;;   (in condition-case)"
    4475             :                       ;;   condition))
    4476           0 :                       )
    4477           0 :                 (if fun-bodies
    4478           0 :                     `(list ',condition (list 'funcall ,(cadr clause) ',var))
    4479           0 :                   (cons condition
    4480           0 :                         (byte-compile-top-level-body
    4481           0 :                          (cdr clause) byte-compile--for-effect)))))
    4482           0 :             (cdr (cdr (cdr form))))))
    4483           0 :       (if fun-bodies
    4484           0 :           (byte-compile-form `(list ,@compiled-clauses))
    4485           0 :         (byte-compile-push-constant compiled-clauses)))
    4486           0 :     (byte-compile-out 'byte-condition-case 0)))
    4487             : 
    4488             : (defun byte-compile-condition-case--new (form)
    4489           0 :   (let* ((var (nth 1 form))
    4490           0 :          (body (nth 2 form))
    4491           0 :          (depth byte-compile-depth)
    4492           0 :          (clauses (mapcar (lambda (clause)
    4493           0 :                             (cons (byte-compile-make-tag) clause))
    4494           0 :                           (nthcdr 3 form)))
    4495           0 :          (endtag (byte-compile-make-tag)))
    4496           0 :     (byte-compile-set-symbol-position 'condition-case)
    4497           0 :     (unless (symbolp var)
    4498           0 :       (byte-compile-warn
    4499           0 :        "`%s' is not a variable-name or nil (in condition-case)" var))
    4500             : 
    4501           0 :     (dolist (clause (reverse clauses))
    4502           0 :       (let ((condition (nth 1 clause)))
    4503           0 :         (unless (consp condition) (setq condition (list condition)))
    4504           0 :         (dolist (c condition)
    4505           0 :           (unless (and c (symbolp c))
    4506           0 :             (byte-compile-warn
    4507           0 :              "`%S' is not a condition name (in condition-case)" c))
    4508             :           ;; In reality, the `error-conditions' property is only required
    4509             :           ;; for the argument to `signal', not to `condition-case'.
    4510             :           ;;(unless (consp (get c 'error-conditions))
    4511             :           ;;  (byte-compile-warn
    4512             :           ;;   "`%s' is not a known condition name (in condition-case)"
    4513             :           ;;   c))
    4514           0 :           )
    4515           0 :         (byte-compile-push-constant condition))
    4516           0 :       (byte-compile-goto 'byte-pushconditioncase (car clause)))
    4517             : 
    4518           0 :     (byte-compile-form body) ;; byte-compile--for-effect
    4519           0 :     (dolist (_ clauses) (byte-compile-out 'byte-pophandler))
    4520           0 :     (byte-compile-goto 'byte-goto endtag)
    4521             : 
    4522           0 :     (while clauses
    4523           0 :       (let ((clause (pop clauses))
    4524           0 :             (byte-compile-bound-variables byte-compile-bound-variables)
    4525             :             (byte-compile--lexical-environment
    4526           0 :              byte-compile--lexical-environment))
    4527           0 :         (setq byte-compile-depth (1+ depth))
    4528           0 :         (byte-compile-out-tag (pop clause))
    4529           0 :         (dolist (_ clauses) (byte-compile-out 'byte-pophandler))
    4530           0 :         (cond
    4531           0 :          ((null var) (byte-compile-discard))
    4532           0 :          (lexical-binding
    4533           0 :           (push (cons var (1- byte-compile-depth))
    4534           0 :                 byte-compile--lexical-environment))
    4535           0 :          (t (byte-compile-dynamic-variable-bind var)))
    4536           0 :         (byte-compile-body (cdr clause)) ;; byte-compile--for-effect
    4537           0 :         (cond
    4538           0 :          ((null var) nil)
    4539           0 :          (lexical-binding (byte-compile-discard 1 'preserve-tos))
    4540           0 :          (t (byte-compile-out 'byte-unbind 1)))
    4541           0 :         (byte-compile-goto 'byte-goto endtag)))
    4542             : 
    4543           0 :     (byte-compile-out-tag endtag)))
    4544             : 
    4545             : (defun byte-compile-save-excursion (form)
    4546           0 :   (if (and (eq 'set-buffer (car-safe (car-safe (cdr form))))
    4547           0 :            (byte-compile-warning-enabled-p 'suspicious))
    4548           0 :       (byte-compile-warn
    4549           0 :        "Use `with-current-buffer' rather than save-excursion+set-buffer"))
    4550           0 :   (byte-compile-out 'byte-save-excursion 0)
    4551           0 :   (byte-compile-body-do-effect (cdr form))
    4552           0 :   (byte-compile-out 'byte-unbind 1))
    4553             : 
    4554             : (defun byte-compile-save-restriction (form)
    4555           0 :   (byte-compile-out 'byte-save-restriction 0)
    4556           0 :   (byte-compile-body-do-effect (cdr form))
    4557           0 :   (byte-compile-out 'byte-unbind 1))
    4558             : 
    4559             : (defun byte-compile-save-current-buffer (form)
    4560           0 :   (byte-compile-out 'byte-save-current-buffer 0)
    4561           0 :   (byte-compile-body-do-effect (cdr form))
    4562           0 :   (byte-compile-out 'byte-unbind 1))
    4563             : 
    4564             : ;;; top-level forms elsewhere
    4565             : 
    4566             : (byte-defop-compiler-1 defvar)
    4567             : (byte-defop-compiler-1 defconst byte-compile-defvar)
    4568             : (byte-defop-compiler-1 autoload)
    4569             : (byte-defop-compiler-1 lambda byte-compile-lambda-form)
    4570             : 
    4571             : ;; If foo.el declares `toto' as obsolete, it is likely that foo.el will
    4572             : ;; actually use `toto' in order for this obsolete variable to still work
    4573             : ;; correctly, so paradoxically, while byte-compiling foo.el, the presence
    4574             : ;; of a make-obsolete-variable call for `toto' is an indication that `toto'
    4575             : ;; should not trigger obsolete-warnings in foo.el.
    4576             : (byte-defop-compiler-1 make-obsolete-variable)
    4577             : (defun byte-compile-make-obsolete-variable (form)
    4578           0 :   (when (eq 'quote (car-safe (nth 1 form)))
    4579           0 :     (push (nth 1 (nth 1 form)) byte-compile-global-not-obsolete-vars))
    4580           0 :   (byte-compile-normal-call form))
    4581             : 
    4582             : (defconst byte-compile-tmp-var (make-symbol "def-tmp-var"))
    4583             : 
    4584             : (defun byte-compile-defvar (form)
    4585             :   ;; This is not used for file-level defvar/consts.
    4586          35 :   (when (and (symbolp (nth 1 form))
    4587          35 :              (not (string-match "[-*/:$]" (symbol-name (nth 1 form))))
    4588          35 :              (byte-compile-warning-enabled-p 'lexical))
    4589           0 :     (byte-compile-warn "global/dynamic var `%s' lacks a prefix"
    4590          35 :                        (nth 1 form)))
    4591          35 :   (let ((fun (nth 0 form))
    4592          35 :         (var (nth 1 form))
    4593          35 :         (value (nth 2 form))
    4594          35 :         (string (nth 3 form)))
    4595          35 :     (byte-compile-set-symbol-position fun)
    4596          35 :     (when (or (> (length form) 4)
    4597          35 :               (and (eq fun 'defconst) (null (cddr form))))
    4598           0 :       (let ((ncall (length (cdr form))))
    4599           0 :         (byte-compile-warn
    4600             :          "`%s' called with %d argument%s, but %s %s"
    4601           0 :          fun ncall
    4602           0 :          (if (= 1 ncall) "" "s")
    4603           0 :          (if (< ncall 2) "requires" "accepts only")
    4604          35 :          "2-3")))
    4605          70 :     (push var byte-compile-bound-variables)
    4606          35 :     (if (eq fun 'defconst)
    4607          35 :         (push var byte-compile-const-variables))
    4608          35 :     (when (and string (not (stringp string)))
    4609           0 :       (byte-compile-warn "third arg to `%s %s' is not a string: %s"
    4610          35 :                          fun var string))
    4611          35 :     (byte-compile-form-do-effect
    4612          35 :      (if (cddr form)  ; `value' provided
    4613             :          ;; Quote with `quote' to prevent byte-compiling the body,
    4614             :          ;; which would lead to an inf-loop.
    4615           0 :          `(funcall '(lambda (,byte-compile-tmp-var)
    4616           0 :                       (,fun ,var ,byte-compile-tmp-var ,@(nthcdr 3 form)))
    4617           0 :                    ,value)
    4618          35 :         (if (eq fun 'defconst)
    4619             :             ;; This will signal an appropriate error at runtime.
    4620           0 :             `(eval ',form)
    4621             :           ;; A simple (defvar foo) just returns foo.
    4622          35 :           `',var)))))
    4623             : 
    4624             : (defun byte-compile-autoload (form)
    4625           0 :   (byte-compile-set-symbol-position 'autoload)
    4626           0 :   (and (macroexp-const-p (nth 1 form))
    4627           0 :        (macroexp-const-p (nth 5 form))
    4628           0 :        (memq (eval (nth 5 form)) '(t macro))  ; macro-p
    4629           0 :        (not (fboundp (eval (nth 1 form))))
    4630           0 :        (byte-compile-warn
    4631             :         "The compiler ignores `autoload' except at top level.  You should
    4632             :      probably put the autoload of the macro `%s' at top-level."
    4633           0 :         (eval (nth 1 form))))
    4634           0 :   (byte-compile-normal-call form))
    4635             : 
    4636             : ;; Lambdas in valid places are handled as special cases by various code.
    4637             : ;; The ones that remain are errors.
    4638             : (defun byte-compile-lambda-form (_form)
    4639           0 :   (byte-compile-set-symbol-position 'lambda)
    4640           0 :   (error "`lambda' used as function name is invalid"))
    4641             : 
    4642             : ;; Compile normally, but deal with warnings for the function being defined.
    4643             : (put 'defalias 'byte-hunk-handler 'byte-compile-file-form-defalias)
    4644             : ;; Used for eieio--defalias as well.
    4645             : (defun byte-compile-file-form-defalias (form)
    4646             :   ;; For the compilation itself, we could largely get rid of this hunk-handler,
    4647             :   ;; if it weren't for the fact that we need to figure out when a defalias
    4648             :   ;; defines a macro, so as to add it to byte-compile-macro-environment.
    4649             :   ;;
    4650             :   ;; FIXME: we also use this hunk-handler to implement the function's dynamic
    4651             :   ;; docstring feature.  We could actually implement it more elegantly in
    4652             :   ;; byte-compile-lambda so it applies to all lambdas, but the problem is that
    4653             :   ;; the resulting .elc format will not be recognized by make-docfile, so
    4654             :   ;; either we stop using DOC for the docstrings of preloaded elc files (at the
    4655             :   ;; cost of around 24KB on 32bit hosts, double on 64bit hosts) or we need to
    4656             :   ;; build DOC in a more clever way (e.g. handle anonymous elements).
    4657           0 :   (let ((byte-compile-free-references nil)
    4658             :         (byte-compile-free-assignments nil))
    4659           0 :     (pcase form
    4660             :       ;; Decompose `form' into:
    4661             :       ;; - `name' is the name of the defined function.
    4662             :       ;; - `arg' is the expression to which it is defined.
    4663             :       ;; - `rest' is the rest of the arguments.
    4664             :       (`(,_ ',name ,arg . ,rest)
    4665           0 :        (pcase-let*
    4666             :            ;; `macro' is non-nil if it defines a macro.
    4667             :            ;; `fun' is the function part of `arg' (defaults to `arg').
    4668             :            (((or (and (or `(cons 'macro ,fun) `'(macro . ,fun)) (let macro t))
    4669           0 :                  (and (let fun arg) (let macro nil)))
    4670           0 :              arg)
    4671             :             ;; `lam' is the lambda expression in `fun' (or nil if not
    4672             :             ;; recognized).
    4673             :             ((or `(,(or `quote `function) ,lam) (let lam nil))
    4674           0 :              fun)
    4675             :             ;; `arglist' is the list of arguments (or t if not recognized).
    4676             :             ;; `body' is the body of `lam' (or t if not recognized).
    4677             :             ((or `(lambda ,arglist . ,body)
    4678             :                  ;; `(closure ,_ ,arglist . ,body)
    4679             :                  (and `(internal-make-closure ,arglist . ,_) (let body t))
    4680             :                  (and (let arglist t) (let body t)))
    4681           0 :              lam))
    4682           0 :          (unless (byte-compile-file-form-defmumble
    4683           0 :                   name macro arglist body rest)
    4684           0 :            (when macro
    4685           0 :              (if (null fun)
    4686           0 :                  (message "Macro %s unrecognized, won't work in file" name)
    4687           0 :                (message "Macro %s partly recognized, trying our luck" name)
    4688           0 :                (push (cons name (eval fun))
    4689           0 :                      byte-compile-macro-environment)))
    4690           0 :            (byte-compile-keep-pending form))))
    4691             : 
    4692             :       ;; We used to just do: (byte-compile-normal-call form)
    4693             :       ;; But it turns out that this fails to optimize the code.
    4694             :       ;; So instead we now do the same as what other byte-hunk-handlers do,
    4695             :       ;; which is to call back byte-compile-file-form and then return nil.
    4696             :       ;; Except that we can't just call byte-compile-file-form since it would
    4697             :       ;; call us right back.
    4698           0 :       (_ (byte-compile-keep-pending form)))))
    4699             : 
    4700             : (byte-defop-compiler-1 with-no-warnings byte-compile-no-warnings)
    4701             : (defun byte-compile-no-warnings (form)
    4702           0 :   (let (byte-compile-warnings)
    4703           0 :     (byte-compile-form (cons 'progn (cdr form)))))
    4704             : 
    4705             : ;; Warn about misuses of make-variable-buffer-local.
    4706             : (byte-defop-compiler-1 make-variable-buffer-local
    4707             :                        byte-compile-make-variable-buffer-local)
    4708             : (defun byte-compile-make-variable-buffer-local (form)
    4709           0 :   (if (and (eq (car-safe (car-safe (cdr-safe form))) 'quote)
    4710           0 :            (byte-compile-warning-enabled-p 'make-local))
    4711           0 :       (byte-compile-warn
    4712           0 :        "`make-variable-buffer-local' not called at toplevel"))
    4713           0 :   (byte-compile-normal-call form))
    4714             : (put 'make-variable-buffer-local
    4715             :      'byte-hunk-handler 'byte-compile-form-make-variable-buffer-local)
    4716             : (defun byte-compile-form-make-variable-buffer-local (form)
    4717           0 :   (byte-compile-keep-pending form 'byte-compile-normal-call))
    4718             : 
    4719             : (put 'function-put 'byte-hunk-handler 'byte-compile-define-symbol-prop)
    4720             : (put 'define-symbol-prop 'byte-hunk-handler 'byte-compile-define-symbol-prop)
    4721             : (defun byte-compile-define-symbol-prop (form)
    4722           0 :   (pcase form
    4723             :     ((and `(,op ,fun ,prop ,val)
    4724           0 :           (guard (and (macroexp-const-p fun)
    4725           0 :                       (macroexp-const-p prop)
    4726           0 :                       (or (macroexp-const-p val)
    4727             :                           ;; Also accept anonymous functions, since
    4728             :                           ;; we're at top-level which implies they're
    4729             :                           ;; also constants.
    4730           0 :                           (pcase val (`(function (lambda . ,_)) t))))))
    4731           0 :      (byte-compile-push-constant op)
    4732           0 :      (byte-compile-form fun)
    4733           0 :      (byte-compile-form prop)
    4734           0 :      (let* ((fun (eval fun))
    4735           0 :             (prop (eval prop))
    4736           0 :             (val (if (macroexp-const-p val)
    4737           0 :                      (eval val)
    4738           0 :                    (byte-compile-lambda (cadr val)))))
    4739           0 :        (push `(,fun
    4740           0 :                . (,prop ,val ,@(alist-get fun overriding-plist-environment)))
    4741           0 :              overriding-plist-environment)
    4742           0 :        (byte-compile-push-constant val)
    4743           0 :        (byte-compile-out 'byte-call 3)
    4744           0 :        nil))
    4745             : 
    4746           0 :     (_ (byte-compile-keep-pending form))))
    4747             : 
    4748             : ;;; tags
    4749             : 
    4750             : ;; Note: Most operations will strip off the 'TAG, but it speeds up
    4751             : ;; optimization to have the 'TAG as a part of the tag.
    4752             : ;; Tags will be (TAG . (tag-number . stack-depth)).
    4753             : (defun byte-compile-make-tag ()
    4754         158 :   (list 'TAG (setq byte-compile-tag-number (1+ byte-compile-tag-number))))
    4755             : 
    4756             : 
    4757             : (defun byte-compile-out-tag (tag)
    4758         158 :   (setq byte-compile-output (cons tag byte-compile-output))
    4759         158 :   (if (cdr (cdr tag))
    4760         136 :       (progn
    4761             :         ;; ## remove this someday
    4762         136 :         (and byte-compile-depth
    4763          92 :              (not (= (cdr (cdr tag)) byte-compile-depth))
    4764         136 :              (error "Compiler bug: depth conflict at tag %d" (car (cdr tag))))
    4765         136 :         (setq byte-compile-depth (cdr (cdr tag))))
    4766         158 :     (setcdr (cdr tag) byte-compile-depth)))
    4767             : 
    4768             : (defun byte-compile-goto (opcode tag)
    4769         320 :   (push (cons opcode tag) byte-compile-output)
    4770         160 :   (setcdr (cdr tag) (if (memq opcode byte-goto-always-pop-ops)
    4771          41 :                         (1- byte-compile-depth)
    4772         160 :                       byte-compile-depth))
    4773         160 :   (setq byte-compile-depth (and (not (eq opcode 'byte-goto))
    4774         160 :                                 (1- byte-compile-depth))))
    4775             : 
    4776             : (defun byte-compile-stack-adjustment (op operand)
    4777             :   "Return the amount by which an operation adjusts the stack.
    4778             : OP and OPERAND are as passed to `byte-compile-out'."
    4779        3699 :   (if (memq op '(byte-call byte-discardN byte-discardN-preserve-tos))
    4780             :       ;; For calls, OPERAND is the number of args, so we pop OPERAND + 1
    4781             :       ;; elements, and the push the result, for a total of -OPERAND.
    4782             :       ;; For discardN*, of course, we just pop OPERAND elements.
    4783         933 :       (- operand)
    4784        2766 :     (or (aref byte-stack+-info (symbol-value op))
    4785             :         ;; Ops with a nil entry in `byte-stack+-info' are byte-codes
    4786             :         ;; that take OPERAND values off the stack and push a result, for
    4787             :         ;; a total of 1 - OPERAND
    4788        3699 :         (- 1 operand))))
    4789             : 
    4790             : (defun byte-compile-out (op &optional operand)
    4791        7470 :   (push (cons op operand) byte-compile-output)
    4792        3735 :   (if (eq op 'byte-return)
    4793             :       ;; This is actually an unnecessary case, because there should be no
    4794             :       ;; more ops behind byte-return.
    4795          36 :       (setq byte-compile-depth nil)
    4796        3699 :     (setq byte-compile-depth
    4797        3699 :           (+ byte-compile-depth (byte-compile-stack-adjustment op operand)))
    4798        3699 :     (setq byte-compile-maxdepth (max byte-compile-depth byte-compile-maxdepth))
    4799             :     ;;(if (< byte-compile-depth 0) (error "Compiler error: stack underflow"))
    4800        3735 :     ))
    4801             : 
    4802             : ;;; call tree stuff
    4803             : 
    4804             : (defun byte-compile-annotate-call-tree (form)
    4805           0 :   (let (entry)
    4806             :     ;; annotate the current call
    4807           0 :     (if (setq entry (assq (car form) byte-compile-call-tree))
    4808           0 :         (or (memq byte-compile-current-form (nth 1 entry)) ;callers
    4809           0 :             (setcar (cdr entry)
    4810           0 :                     (cons byte-compile-current-form (nth 1 entry))))
    4811           0 :       (setq byte-compile-call-tree
    4812           0 :             (cons (list (car form) (list byte-compile-current-form) nil)
    4813           0 :                   byte-compile-call-tree)))
    4814             :     ;; annotate the current function
    4815           0 :     (if (setq entry (assq byte-compile-current-form byte-compile-call-tree))
    4816           0 :         (or (memq (car form) (nth 2 entry)) ;called
    4817           0 :             (setcar (cdr (cdr entry))
    4818           0 :                     (cons (car form) (nth 2 entry))))
    4819           0 :       (setq byte-compile-call-tree
    4820           0 :             (cons (list byte-compile-current-form nil (list (car form)))
    4821           0 :                   byte-compile-call-tree)))
    4822           0 :     ))
    4823             : 
    4824             : ;; Renamed from byte-compile-report-call-tree
    4825             : ;; to avoid interfering with completion of byte-compile-file.
    4826             : ;;;###autoload
    4827             : (defun display-call-tree (&optional filename)
    4828             :   "Display a call graph of a specified file.
    4829             : This lists which functions have been called, what functions called
    4830             : them, and what functions they call.  The list includes all functions
    4831             : whose definitions have been compiled in this Emacs session, as well as
    4832             : all functions called by those functions.
    4833             : 
    4834             : The call graph does not include macros, inline functions, or
    4835             : primitives that the byte-code interpreter knows about directly
    4836             : \(`eq', `cons', etc.).
    4837             : 
    4838             : The call tree also lists those functions which are not known to be called
    4839             : \(that is, to which no calls have been compiled), and which cannot be
    4840             : invoked interactively."
    4841             :   (interactive)
    4842           0 :   (message "Generating call tree...")
    4843           0 :   (with-output-to-temp-buffer "*Call-Tree*"
    4844           0 :     (set-buffer "*Call-Tree*")
    4845           0 :     (erase-buffer)
    4846           0 :     (message "Generating call tree... (sorting on %s)"
    4847           0 :              byte-compile-call-tree-sort)
    4848           0 :     (insert "Call tree for "
    4849           0 :             (cond ((null byte-compile-current-file) (or filename "???"))
    4850           0 :                   ((stringp byte-compile-current-file)
    4851           0 :                    byte-compile-current-file)
    4852           0 :                   (t (buffer-name byte-compile-current-file)))
    4853             :             " sorted on "
    4854           0 :             (prin1-to-string byte-compile-call-tree-sort)
    4855           0 :             ":\n\n")
    4856           0 :     (if byte-compile-call-tree-sort
    4857           0 :         (setq byte-compile-call-tree
    4858           0 :               (sort byte-compile-call-tree
    4859           0 :                     (pcase byte-compile-call-tree-sort
    4860             :                       (`callers
    4861           0 :                        (lambda (x y) (< (length (nth 1 x))
    4862           0 :                                    (length (nth 1 y)))))
    4863             :                       (`calls
    4864           0 :                        (lambda (x y) (< (length (nth 2 x))
    4865           0 :                                    (length (nth 2 y)))))
    4866             :                       (`calls+callers
    4867           0 :                        (lambda (x y) (< (+ (length (nth 1 x))
    4868           0 :                                       (length (nth 2 x)))
    4869           0 :                                    (+ (length (nth 1 y))
    4870           0 :                                       (length (nth 2 y))))))
    4871             :                       (`name
    4872           0 :                        (lambda (x y) (string< (car x) (car y))))
    4873           0 :                       (_ (error "`byte-compile-call-tree-sort': `%s' - unknown sort mode"
    4874           0 :                                 byte-compile-call-tree-sort))))))
    4875           0 :     (message "Generating call tree...")
    4876           0 :     (let ((rest byte-compile-call-tree)
    4877           0 :           (b (current-buffer))
    4878             :           f p
    4879             :           callers calls)
    4880           0 :       (while rest
    4881           0 :         (prin1 (car (car rest)) b)
    4882           0 :         (setq callers (nth 1 (car rest))
    4883           0 :               calls (nth 2 (car rest)))
    4884           0 :         (insert "\t"
    4885           0 :           (cond ((not (fboundp (setq f (car (car rest)))))
    4886           0 :                  (if (null f)
    4887             :                      " <top level>";; shouldn't insert nil then, actually -sk
    4888           0 :                    " <not defined>"))
    4889           0 :                 ((subrp (setq f (symbol-function f)))
    4890             :                  " <subr>")
    4891           0 :                 ((symbolp f)
    4892           0 :                  (format " ==> %s" f))
    4893           0 :                 ((byte-code-function-p f)
    4894             :                  "<compiled function>")
    4895           0 :                 ((not (consp f))
    4896             :                  "<malformed function>")
    4897           0 :                 ((eq 'macro (car f))
    4898           0 :                  (if (or (byte-code-function-p (cdr f))
    4899           0 :                          (assq 'byte-code (cdr (cdr (cdr f)))))
    4900             :                      " <compiled macro>"
    4901           0 :                    " <macro>"))
    4902           0 :                 ((assq 'byte-code (cdr (cdr f)))
    4903             :                  "<compiled lambda>")
    4904           0 :                 ((eq 'lambda (car f))
    4905             :                  "<function>")
    4906           0 :                 (t "???"))
    4907           0 :           (format " (%d callers + %d calls = %d)"
    4908             :                   ;; Does the optimizer eliminate common subexpressions?-sk
    4909           0 :                   (length callers)
    4910           0 :                   (length calls)
    4911           0 :                   (+ (length callers) (length calls)))
    4912           0 :           "\n")
    4913           0 :         (if callers
    4914           0 :             (progn
    4915           0 :               (insert "  called by:\n")
    4916           0 :               (setq p (point))
    4917           0 :               (insert "    " (if (car callers)
    4918           0 :                                  (mapconcat 'symbol-name callers ", ")
    4919           0 :                                "<top level>"))
    4920           0 :               (let ((fill-prefix "    "))
    4921           0 :                 (fill-region-as-paragraph p (point)))
    4922           0 :               (unless (= 0 (current-column))
    4923           0 :                 (insert "\n"))))
    4924           0 :         (if calls
    4925           0 :             (progn
    4926           0 :               (insert "  calls:\n")
    4927           0 :               (setq p (point))
    4928           0 :               (insert "    " (mapconcat 'symbol-name calls ", "))
    4929           0 :               (let ((fill-prefix "    "))
    4930           0 :                 (fill-region-as-paragraph p (point)))
    4931           0 :               (unless (= 0 (current-column))
    4932           0 :                 (insert "\n"))))
    4933           0 :         (setq rest (cdr rest)))
    4934             : 
    4935           0 :       (message "Generating call tree...(finding uncalled functions...)")
    4936           0 :       (setq rest byte-compile-call-tree)
    4937           0 :       (let (uncalled def)
    4938           0 :         (while rest
    4939           0 :           (or (nth 1 (car rest))
    4940           0 :               (null (setq f (caar rest)))
    4941           0 :               (progn
    4942           0 :                 (setq def (byte-compile-fdefinition f t))
    4943           0 :                 (and (eq (car-safe def) 'macro)
    4944           0 :                      (eq (car-safe (cdr-safe def)) 'lambda)
    4945           0 :                      (setq def (cdr def)))
    4946           0 :                 (functionp def))
    4947           0 :               (progn
    4948           0 :                 (setq def (byte-compile-fdefinition f nil))
    4949           0 :                 (and (eq (car-safe def) 'macro)
    4950           0 :                      (eq (car-safe (cdr-safe def)) 'lambda)
    4951           0 :                      (setq def (cdr def)))
    4952           0 :                 (commandp def))
    4953           0 :               (setq uncalled (cons f uncalled)))
    4954           0 :           (setq rest (cdr rest)))
    4955           0 :         (if uncalled
    4956           0 :             (let ((fill-prefix "  "))
    4957           0 :               (insert "Noninteractive functions not known to be called:\n  ")
    4958           0 :               (setq p (point))
    4959           0 :               (insert (mapconcat 'symbol-name (nreverse uncalled) ", "))
    4960           0 :               (fill-region-as-paragraph p (point))))))
    4961           0 :     (message "Generating call tree...done.")))
    4962             : 
    4963             : 
    4964             : ;;;###autoload
    4965             : (defun batch-byte-compile-if-not-done ()
    4966             :   "Like `byte-compile-file' but doesn't recompile if already up to date.
    4967             : Use this from the command line, with `-batch';
    4968             : it won't work in an interactive Emacs."
    4969           0 :   (batch-byte-compile t))
    4970             : 
    4971             : ;;; by crl@newton.purdue.edu
    4972             : ;;;  Only works noninteractively.
    4973             : ;;;###autoload
    4974             : (defun batch-byte-compile (&optional noforce)
    4975             :   "Run `byte-compile-file' on the files remaining on the command line.
    4976             : Use this from the command line, with `-batch';
    4977             : it won't work in an interactive Emacs.
    4978             : Each file is processed even if an error occurred previously.
    4979             : For example, invoke \"emacs -batch -f batch-byte-compile $emacs/ ~/*.el\".
    4980             : If NOFORCE is non-nil, don't recompile a file that seems to be
    4981             : already up-to-date."
    4982             :   ;; command-line-args-left is what is left of the command line, from
    4983             :   ;; startup.el.
    4984           0 :   (defvar command-line-args-left)       ;Avoid 'free variable' warning
    4985           0 :   (if (not noninteractive)
    4986           0 :       (error "`batch-byte-compile' is to be used only with -batch"))
    4987             :   ;; Better crash loudly than attempting to recover from undefined
    4988             :   ;; behavior.
    4989           0 :   (setq attempt-stack-overflow-recovery nil
    4990           0 :         attempt-orderly-shutdown-on-fatal-signal nil)
    4991           0 :   (let ((error nil))
    4992           0 :     (while command-line-args-left
    4993           0 :       (if (file-directory-p (expand-file-name (car command-line-args-left)))
    4994             :           ;; Directory as argument.
    4995           0 :           (let (source dest)
    4996           0 :             (dolist (file (directory-files (car command-line-args-left)))
    4997           0 :               (if (and (string-match emacs-lisp-file-regexp file)
    4998           0 :                        (not (auto-save-file-name-p file))
    4999           0 :                        (setq source
    5000           0 :                              (expand-file-name file
    5001           0 :                                                (car command-line-args-left)))
    5002           0 :                        (setq dest (byte-compile-dest-file source))
    5003           0 :                        (file-exists-p dest)
    5004           0 :                        (file-newer-than-file-p source dest))
    5005           0 :                   (if (null (batch-byte-compile-file source))
    5006           0 :                       (setq error t)))))
    5007             :         ;; Specific file argument
    5008           0 :         (if (or (not noforce)
    5009           0 :                 (let* ((source (car command-line-args-left))
    5010           0 :                        (dest (byte-compile-dest-file source)))
    5011           0 :                   (or (not (file-exists-p dest))
    5012           0 :                       (file-newer-than-file-p source dest))))
    5013           0 :             (if (null (batch-byte-compile-file (car command-line-args-left)))
    5014           0 :                 (setq error t))))
    5015           0 :       (setq command-line-args-left (cdr command-line-args-left)))
    5016           0 :     (kill-emacs (if error 1 0))))
    5017             : 
    5018             : (defun batch-byte-compile-file (file)
    5019           0 :   (let ((byte-compile-root-dir (or byte-compile-root-dir default-directory)))
    5020           0 :     (if debug-on-error
    5021           0 :         (byte-compile-file file)
    5022           0 :       (condition-case err
    5023           0 :           (byte-compile-file file)
    5024             :         (file-error
    5025           0 :          (message (if (cdr err)
    5026             :                       ">>Error occurred processing %s: %s (%s)"
    5027           0 :                     ">>Error occurred processing %s: %s")
    5028           0 :                   file
    5029           0 :                   (get (car err) 'error-message)
    5030           0 :                   (prin1-to-string (cdr err)))
    5031           0 :          (let ((destfile (byte-compile-dest-file file)))
    5032           0 :            (if (file-exists-p destfile)
    5033           0 :                (delete-file destfile)))
    5034             :          nil)
    5035             :         (error
    5036           0 :          (message (if (cdr err)
    5037             :                       ">>Error occurred processing %s: %s (%s)"
    5038           0 :                     ">>Error occurred processing %s: %s")
    5039           0 :                   file
    5040           0 :                   (get (car err) 'error-message)
    5041           0 :                   (prin1-to-string (cdr err)))
    5042           0 :          nil)))))
    5043             : 
    5044             : (defun byte-compile-refresh-preloaded ()
    5045             :   "Reload any Lisp file that was changed since Emacs was dumped.
    5046             : Use with caution."
    5047           0 :   (let* ((argv0 (car command-line-args))
    5048           0 :          (emacs-file (executable-find argv0)))
    5049           0 :     (if (not (and emacs-file (file-executable-p emacs-file)))
    5050           0 :         (message "Can't find %s to refresh preloaded Lisp files" argv0)
    5051           0 :       (dolist (f (reverse load-history))
    5052           0 :         (setq f (car f))
    5053           0 :         (if (string-match "elc\\'" f) (setq f (substring f 0 -1)))
    5054           0 :         (when (and (file-readable-p f)
    5055           0 :                    (file-newer-than-file-p f emacs-file)
    5056             :                    ;; Don't reload the source version of the files below
    5057             :                    ;; because that causes subsequent byte-compilation to
    5058             :                    ;; be a lot slower and need a higher max-lisp-eval-depth,
    5059             :                    ;; so it can cause recompilation to fail.
    5060           0 :                    (not (member (file-name-nondirectory f)
    5061             :                                 '("pcase.el" "bytecomp.el" "macroexp.el"
    5062           0 :                                   "cconv.el" "byte-opt.el"))))
    5063           0 :           (message "Reloading stale %s" (file-name-nondirectory f))
    5064           0 :           (condition-case nil
    5065           0 :               (load f 'noerror nil 'nosuffix)
    5066             :             ;; Probably shouldn't happen, but in case of an error, it seems
    5067             :             ;; at least as useful to ignore it as it is to stop compilation.
    5068           0 :             (error nil)))))))
    5069             : 
    5070             : ;;;###autoload
    5071             : (defun batch-byte-recompile-directory (&optional arg)
    5072             :   "Run `byte-recompile-directory' on the dirs remaining on the command line.
    5073             : Must be used only with `-batch', and kills Emacs on completion.
    5074             : For example, invoke `emacs -batch -f batch-byte-recompile-directory .'.
    5075             : 
    5076             : Optional argument ARG is passed as second argument ARG to
    5077             : `byte-recompile-directory'; see there for its possible values
    5078             : and corresponding effects."
    5079             :   ;; command-line-args-left is what is left of the command line (startup.el)
    5080           0 :   (defvar command-line-args-left)       ;Avoid 'free variable' warning
    5081           0 :   (if (not noninteractive)
    5082           0 :       (error "batch-byte-recompile-directory is to be used only with -batch"))
    5083             :   ;; Better crash loudly than attempting to recover from undefined
    5084             :   ;; behavior.
    5085           0 :   (setq attempt-stack-overflow-recovery nil
    5086           0 :         attempt-orderly-shutdown-on-fatal-signal nil)
    5087           0 :   (or command-line-args-left
    5088           0 :       (setq command-line-args-left '(".")))
    5089           0 :   (while command-line-args-left
    5090           0 :     (byte-recompile-directory (car command-line-args-left) arg)
    5091           0 :     (setq command-line-args-left (cdr command-line-args-left)))
    5092           0 :   (kill-emacs 0))
    5093             : 
    5094             : ;;; Core compiler macros.
    5095             : 
    5096             : (put 'featurep 'compiler-macro
    5097             :      (lambda (form feature &rest _ignore)
    5098             :        ;; Emacs-21's byte-code doesn't run under XEmacs or SXEmacs anyway, so
    5099             :        ;; we can safely optimize away this test.
    5100             :        (if (member feature '('xemacs 'sxemacs 'emacs))
    5101             :            (eval form)
    5102             :          form)))
    5103             : 
    5104             : (provide 'byte-compile)
    5105             : (provide 'bytecomp)
    5106             : 
    5107             : 
    5108             : ;;; report metering (see the hacks in bytecode.c)
    5109             : 
    5110             : (defvar byte-code-meter)
    5111             : (defun byte-compile-report-ops ()
    5112           0 :   (or (boundp 'byte-metering-on)
    5113           0 :       (error "You must build Emacs with -DBYTE_CODE_METER to use this"))
    5114           0 :   (with-output-to-temp-buffer "*Meter*"
    5115           0 :     (set-buffer "*Meter*")
    5116           0 :     (let ((i 0) n op off)
    5117           0 :       (while (< i 256)
    5118           0 :         (setq n (aref (aref byte-code-meter 0) i)
    5119           0 :               off nil)
    5120           0 :         (if t                           ;(not (zerop n))
    5121           0 :             (progn
    5122           0 :               (setq op i)
    5123           0 :               (setq off nil)
    5124           0 :               (cond ((< op byte-nth)
    5125           0 :                      (setq off (logand op 7))
    5126           0 :                      (setq op (logand op 248)))
    5127           0 :                     ((>= op byte-constant)
    5128           0 :                      (setq off (- op byte-constant)
    5129           0 :                            op byte-constant)))
    5130           0 :               (setq op (aref byte-code-vector op))
    5131           0 :               (insert (format "%-4d" i))
    5132           0 :               (insert (symbol-name op))
    5133           0 :               (if off (insert " [" (int-to-string off) "]"))
    5134           0 :               (indent-to 40)
    5135           0 :               (insert (int-to-string n) "\n")))
    5136           0 :         (setq i (1+ i))))))
    5137             : 
    5138             : ;; To avoid "lisp nesting exceeds max-lisp-eval-depth" when bytecomp compiles
    5139             : ;; itself, compile some of its most used recursive functions (at load time).
    5140             : ;;
    5141             : (eval-when-compile
    5142             :   (or (byte-code-function-p (symbol-function 'byte-compile-form))
    5143             :       (assq 'byte-code (symbol-function 'byte-compile-form))
    5144             :       (let ((byte-optimize nil)         ; do it fast
    5145             :             (byte-compile-warnings nil))
    5146             :         (mapc (lambda (x)
    5147             :                 (or noninteractive (message "compiling %s..." x))
    5148             :                 (byte-compile x)
    5149             :                 (or noninteractive (message "compiling %s...done" x)))
    5150             :               '(byte-compile-normal-call
    5151             :                 byte-compile-form
    5152             :                 byte-compile-body
    5153             :                 ;; Inserted some more than necessary, to speed it up.
    5154             :                 byte-compile-top-level
    5155             :                 byte-compile-out-toplevel
    5156             :                 byte-compile-constant
    5157             :                 byte-compile-variable-ref))))
    5158             :   nil)
    5159             : 
    5160             : (run-hooks 'bytecomp-load-hook)
    5161             : 
    5162             : ;;; bytecomp.el ends here

Generated by: LCOV version 1.12