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
|