(find-new-buffer-file-coding-system): Doc fix.
[bpt/emacs.git] / lisp / emacs-lisp / bytecomp.el
CommitLineData
fd5285f3
RS
1;;; bytecomp.el --- compilation of Lisp code into byte code.
2
b578f267 3;; Copyright (C) 1985, 1986, 1987, 1992, 1994 Free Software Foundation, Inc.
3a801d0c 4
fd5285f3
RS
5;; Author: Jamie Zawinski <jwz@lucid.com>
6;; Hallvard Furuseth <hbf@ulrik.uio.no>
74dfd056 7;; Maintainer: FSF
713ea1de 8;; Keywords: lisp
1c393159 9
e27c3564 10;;; This version incorporates changes up to version 2.10 of the
9e2b097b 11;;; Zawinski-Furuseth compiler.
dd9383bc 12(defconst byte-compile-version "$Revision: 2.54 $")
1c393159
JB
13
14;; This file is part of GNU Emacs.
15
16;; GNU Emacs is free software; you can redistribute it and/or modify
17;; it under the terms of the GNU General Public License as published by
fd5285f3 18;; the Free Software Foundation; either version 2, or (at your option)
1c393159
JB
19;; any later version.
20
21;; GNU Emacs is distributed in the hope that it will be useful,
22;; but WITHOUT ANY WARRANTY; without even the implied warranty of
23;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
24;; GNU General Public License for more details.
25
26;; You should have received a copy of the GNU General Public License
b578f267
EN
27;; along with GNU Emacs; see the file COPYING. If not, write to the
28;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
29;; Boston, MA 02111-1307, USA.
1c393159 30
e41b2db1
ER
31;;; Commentary:
32
33;; The Emacs Lisp byte compiler. This crunches lisp source into a sort
34;; of p-code which takes up less space and can be interpreted faster.
35;; The user entry points are byte-compile-file and byte-recompile-directory.
36
fd5285f3
RS
37;;; Code:
38
b578f267
EN
39;; ========================================================================
40;; Entry points:
41;; byte-recompile-directory, byte-compile-file,
42;; batch-byte-compile, batch-byte-recompile-directory,
43;; byte-compile, compile-defun,
44;; display-call-tree
45;; (byte-compile-buffer and byte-compile-and-load-file were turned off
46;; because they are not terribly useful and get in the way of completion.)
47
48;; This version of the byte compiler has the following improvements:
49;; + optimization of compiled code:
50;; - removal of unreachable code;
51;; - removal of calls to side-effectless functions whose return-value
52;; is unused;
53;; - compile-time evaluation of safe constant forms, such as (consp nil)
54;; and (ash 1 6);
55;; - open-coding of literal lambdas;
56;; - peephole optimization of emitted code;
57;; - trivial functions are left uncompiled for speed.
58;; + support for inline functions;
59;; + compile-time evaluation of arbitrary expressions;
60;; + compile-time warning messages for:
61;; - functions being redefined with incompatible arglists;
62;; - functions being redefined as macros, or vice-versa;
63;; - functions or macros defined multiple times in the same file;
64;; - functions being called with the incorrect number of arguments;
65;; - functions being called which are not defined globally, in the
66;; file, or as autoloads;
67;; - assignment and reference of undeclared free variables;
68;; - various syntax errors;
69;; + correct compilation of nested defuns, defmacros, defvars and defsubsts;
70;; + correct compilation of top-level uses of macros;
71;; + the ability to generate a histogram of functions called.
72
73;; User customization variables:
74;;
75;; byte-compile-verbose Whether to report the function currently being
76;; compiled in the minibuffer;
77;; byte-optimize Whether to do optimizations; this may be
78;; t, nil, 'source, or 'byte;
79;; byte-optimize-log Whether to report (in excruciating detail)
80;; exactly which optimizations have been made.
81;; This may be t, nil, 'source, or 'byte;
82;; byte-compile-error-on-warn Whether to stop compilation when a warning is
83;; produced;
84;; byte-compile-delete-errors Whether the optimizer may delete calls or
85;; variable references that are side-effect-free
86;; except that they may return an error.
87;; byte-compile-generate-call-tree Whether to generate a histogram of
88;; function calls. This can be useful for
89;; finding unused functions, as well as simple
90;; performance metering.
91;; byte-compile-warnings List of warnings to issue, or t. May contain
92;; 'free-vars (references to variables not in the
93;; current lexical scope)
94;; 'unresolved (calls to unknown functions)
95;; 'callargs (lambda calls with args that don't
96;; match the lambda's definition)
97;; 'redefine (function cell redefined from
98;; a macro to a lambda or vice versa,
99;; or redefined to take other args)
100;; 'obsolete (obsolete variables and functions)
101;; byte-compile-compatibility Whether the compiler should
102;; generate .elc files which can be loaded into
103;; generic emacs 18.
104;; emacs-lisp-file-regexp Regexp for the extension of source-files;
105;; see also the function byte-compile-dest-file.
106
107;; New Features:
108;;
109;; o The form `defsubst' is just like `defun', except that the function
110;; generated will be open-coded in compiled code which uses it. This
111;; means that no function call will be generated, it will simply be
112;; spliced in. Lisp functions calls are very slow, so this can be a
113;; big win.
114;;
115;; You can generally accomplish the same thing with `defmacro', but in
116;; that case, the defined procedure can't be used as an argument to
117;; mapcar, etc.
118;;
119;; o You can also open-code one particular call to a function without
120;; open-coding all calls. Use the 'inline' form to do this, like so:
121;;
122;; (inline (foo 1 2 3)) ;; `foo' will be open-coded
123;; or...
124;; (inline ;; `foo' and `baz' will be
125;; (foo 1 2 3 (bar 5)) ;; open-coded, but `bar' will not.
126;; (baz 0))
127;;
128;; o It is possible to open-code a function in the same file it is defined
129;; in without having to load that file before compiling it. the
130;; byte-compiler has been modified to remember function definitions in
131;; the compilation environment in the same way that it remembers macro
132;; definitions.
133;;
134;; o Forms like ((lambda ...) ...) are open-coded.
135;;
136;; o The form `eval-when-compile' is like progn, except that the body
137;; is evaluated at compile-time. When it appears at top-level, this
138;; is analogous to the Common Lisp idiom (eval-when (compile) ...).
139;; When it does not appear at top-level, it is similar to the
140;; Common Lisp #. reader macro (but not in interpreted code).
141;;
142;; o The form `eval-and-compile' is similar to eval-when-compile, but
143;; the whole form is evalled both at compile-time and at run-time.
144;;
145;; o The command compile-defun is analogous to eval-defun.
146;;
147;; o If you run byte-compile-file on a filename which is visited in a
148;; buffer, and that buffer is modified, you are asked whether you want
149;; to save the buffer before compiling.
150;;
151;; o byte-compiled files now start with the string `;ELC'.
152;; Some versions of `file' can be customized to recognize that.
1c393159 153
79d52eea
JB
154(require 'backquote)
155
1c393159
JB
156(or (fboundp 'defsubst)
157 ;; This really ought to be loaded already!
52799cb8 158 (load-library "byte-run"))
1c393159 159
52799cb8
RS
160;;; The feature of compiling in a specific target Emacs version
161;;; has been turned off because compile time options are a bad idea.
162(defmacro byte-compile-single-version () nil)
163(defmacro byte-compile-version-cond (cond) cond)
1c393159
JB
164
165;;; The crud you see scattered through this file of the form
166;;; (or (and (boundp 'epoch::version) epoch::version)
167;;; (string-lessp emacs-version "19"))
168;;; is because the Epoch folks couldn't be bothered to follow the
169;;; normal emacs version numbering convention.
170
52799cb8
RS
171;; (if (byte-compile-version-cond
172;; (or (and (boundp 'epoch::version) epoch::version)
173;; (string-lessp emacs-version "19")))
174;; (progn
175;; ;; emacs-18 compatibility.
176;; (defvar baud-rate (baud-rate)) ;Define baud-rate if it's undefined
177;;
178;; (if (byte-compile-single-version)
ed015bdd
JB
179;; (defmacro byte-code-function-p (x) "Emacs 18 doesn't have these." nil)
180;; (defun byte-code-function-p (x) "Emacs 18 doesn't have these." nil))
52799cb8
RS
181;;
182;; (or (and (fboundp 'member)
183;; ;; avoid using someone else's possibly bogus definition of this.
184;; (subrp (symbol-function 'member)))
185;; (defun member (elt list)
186;; "like memq, but uses equal instead of eq. In v19, this is a subr."
187;; (while (and list (not (equal elt (car list))))
188;; (setq list (cdr list)))
189;; list))))
190
191
713ea1de
RS
192(defgroup bytecomp nil
193 "Emacs Lisp byte-compiler"
194 :group 'lisp)
195
196(defcustom emacs-lisp-file-regexp (if (eq system-type 'vax-vms)
197 "\\.EL\\(;[0-9]+\\)?$"
198 "\\.el$")
52799cb8 199 "*Regexp which matches Emacs Lisp source files.
713ea1de
RS
200You may want to redefine the function `byte-compile-dest-file'
201if you change this variable."
202 :group 'bytecomp
203 :type 'regexp)
1c393159 204
2140206e
RS
205;; This enables file name handlers such as jka-compr
206;; to remove parts of the file name that should not be copied
207;; through to the output file name.
208(defun byte-compiler-base-file-name (filename)
209 (let ((handler (find-file-name-handler filename
210 'byte-compiler-base-file-name)))
211 (if handler
212 (funcall handler 'byte-compiler-base-file-name filename)
213 filename)))
214
1c393159 215(or (fboundp 'byte-compile-dest-file)
e27c3564 216 ;; The user may want to redefine this along with emacs-lisp-file-regexp,
1c393159
JB
217 ;; so only define it if it is undefined.
218 (defun byte-compile-dest-file (filename)
52799cb8 219 "Convert an Emacs Lisp source file name to a compiled file name."
2140206e 220 (setq filename (byte-compiler-base-file-name filename))
1c393159
JB
221 (setq filename (file-name-sans-versions filename))
222 (cond ((eq system-type 'vax-vms)
01c925e9
RS
223 (concat (substring filename 0 (string-match ";" filename)) "c"))
224 ((string-match emacs-lisp-file-regexp filename)
225 (concat (substring filename 0 (match-beginning 0)) ".elc"))
226 (t (concat filename ".elc")))))
1c393159
JB
227
228;; This can be the 'byte-compile property of any symbol.
52799cb8 229(autoload 'byte-compile-inline-expand "byte-opt")
1c393159
JB
230
231;; This is the entrypoint to the lapcode optimizer pass1.
52799cb8 232(autoload 'byte-optimize-form "byte-opt")
1c393159 233;; This is the entrypoint to the lapcode optimizer pass2.
52799cb8
RS
234(autoload 'byte-optimize-lapcode "byte-opt")
235(autoload 'byte-compile-unfold-lambda "byte-opt")
1c393159 236
ed015bdd
JB
237;; This is the entry point to the decompiler, which is used by the
238;; disassembler. The disassembler just requires 'byte-compile, but
239;; that doesn't define this function, so this seems to be a reasonable
240;; thing to do.
241(autoload 'byte-decompile-bytecode "byte-opt")
242
713ea1de 243(defcustom byte-compile-verbose
1c393159 244 (and (not noninteractive) (> baud-rate search-slow-speed))
713ea1de
RS
245 "*Non-nil means print messages describing progress of byte-compiler."
246 :group 'bytecomp
247 :type 'boolean)
1c393159 248
713ea1de
RS
249(defcustom byte-compile-compatibility nil
250 "*Non-nil means generate output that can run in Emacs 18."
251 :group 'bytecomp
252 :type 'boolean)
52799cb8
RS
253
254;; (defvar byte-compile-generate-emacs19-bytecodes
255;; (not (or (and (boundp 'epoch::version) epoch::version)
256;; (string-lessp emacs-version "19")))
257;; "*If this is true, then the byte-compiler will generate bytecode which
258;; makes use of byte-ops which are present only in Emacs 19. Code generated
259;; this way can never be run in Emacs 18, and may even cause it to crash.")
1c393159 260
713ea1de 261(defcustom byte-optimize t
ab94e6e7
RS
262 "*Enables optimization in the byte compiler.
263nil means don't do any optimization.
264t means do all optimizations.
265`source' means do source-level optimizations only.
713ea1de
RS
266`byte' means do code-level optimizations only."
267 :group 'bytecomp
268 :type '(choice (const :tag "none" nil)
269 (const :tag "all" t)
270 (const :tag "source-level" source)
271 (const :tag "byte-level" byte)))
272
273(defcustom byte-compile-delete-errors t
ab94e6e7 274 "*If non-nil, the optimizer may delete forms that may signal an error.
713ea1de
RS
275This includes variable references and calls to functions such as `car'."
276 :group 'bytecomp
277 :type 'boolean)
1c393159 278
d82e848c 279(defvar byte-compile-dynamic nil
713ea1de 280 "If non-nil, compile function bodies so they load lazily.
458f70dc
RS
281They are hidden in comments in the compiled file,
282and each one is brought into core when the
d82e848c
RS
283function is called.
284
285To enable this option, make it a file-local variable
286in the source file you want it to apply to.
287For example, add -*-byte-compile-dynamic: t;-*- on the first line.
288
289When this option is true, if you load the compiled file and then move it,
290the functions you loaded will not be able to run.")
291
713ea1de 292(defcustom byte-compile-dynamic-docstrings t
d82e848c
RS
293 "*If non-nil, compile doc strings for lazy access.
294We bury the doc strings of functions and variables
295inside comments in the file, and bring them into core only when they
296are actually needed.
297
298When this option is true, if you load the compiled file and then move it,
299you won't be able to find the documentation of anything in that file.
300
1c660f5a
KH
301To disable this option for a certain file, make it a file-local variable
302in the source file. For example, add this to the first line:
303 -*-byte-compile-dynamic-docstrings:nil;-*-
304You can also set the variable globally.
305
713ea1de
RS
306This option is enabled by default because it reduces Emacs memory usage."
307 :group 'bytecomp
308 :type 'boolean)
d82e848c 309
713ea1de 310(defcustom byte-optimize-log nil
1c393159
JB
311 "*If true, the byte-compiler will log its optimizations into *Compile-Log*.
312If this is 'source, then only source-level optimizations will be logged.
713ea1de
RS
313If it is 'byte, then only byte-level optimizations will be logged."
314 :group 'bytecomp
315 :type '(choice (const :tag "none" nil)
316 (const :tag "all" t)
317 (const :tag "source-level" source)
318 (const :tag "byte-level" byte)))
319
320(defcustom byte-compile-error-on-warn nil
321 "*If true, the byte-compiler reports warnings with `error'."
322 :group 'bytecomp
323 :type 'boolean)
1c393159 324
9290191f
RS
325(defconst byte-compile-warning-types
326 '(redefine callargs free-vars unresolved obsolete))
713ea1de 327(defcustom byte-compile-warnings t
1c393159 328 "*List of warnings that the byte-compiler should issue (t for all).
9e2b097b
JB
329Elements of the list may be be:
330
331 free-vars references to variables not in the current lexical scope.
332 unresolved calls to unknown functions.
333 callargs lambda calls with args that don't match the definition.
334 redefine function cell redefined from a macro to a lambda or vice
335 versa, or redefined to take a different number of arguments.
dd9383bc 336 obsolete obsolete variables and functions."
713ea1de 337 :group 'bytecomp
aa635691
AS
338 :type '(choice (const :tag "All" t)
339 (set :menu-tag "Some"
340 (const free-vars) (const unresolved)
341 (const callargs) (const redefined)
342 (const obsolete))))
1c393159 343
713ea1de 344(defcustom byte-compile-generate-call-tree nil
52799cb8
RS
345 "*Non-nil means collect call-graph information when compiling.
346This records functions were called and from where.
347If the value is t, compilation displays the call graph when it finishes.
348If the value is neither t nor nil, compilation asks you whether to display
349the graph.
1c393159
JB
350
351The call tree only lists functions called, not macros used. Those functions
352which the byte-code interpreter knows about directly (eq, cons, etc.) are
353not reported.
354
355The call tree also lists those functions which are not known to be called
5023d9a0 356\(that is, to which no calls have been compiled). Functions which can be
713ea1de
RS
357invoked interactively are excluded from this list."
358 :group 'bytecomp
359 :type '(choice (const :tag "Yes" t) (const :tag "No" nil)
778c7576 360 (other :tag "Ask" lambda)))
1c393159
JB
361
362(defconst byte-compile-call-tree nil "Alist of functions and their call tree.
363Each element looks like
364
365 \(FUNCTION CALLERS CALLS\)
366
367where CALLERS is a list of functions that call FUNCTION, and CALLS
368is a list of functions for which calls were generated while compiling
369FUNCTION.")
370
713ea1de 371(defcustom byte-compile-call-tree-sort 'name
52799cb8
RS
372 "*If non-nil, sort the call tree.
373The values `name', `callers', `calls', `calls+callers'
713ea1de
RS
374specify different fields to sort on."
375 :group 'bytecomp
376 :type '(choice (const name) (const callers) (const calls)
377 (const calls+callers) (const nil)))
52799cb8
RS
378
379;; (defvar byte-compile-overwrite-file t
380;; "If nil, old .elc files are deleted before the new is saved, and .elc
381;; files will have the same modes as the corresponding .el file. Otherwise,
382;; existing .elc files will simply be overwritten, and the existing modes
383;; will not be changed. If this variable is nil, then an .elc file which
384;; is a symbolic link will be turned into a normal file, instead of the file
385;; which the link points to being overwritten.")
1c393159
JB
386
387(defvar byte-compile-constants nil
388 "list of all constants encountered during compilation of this form")
389(defvar byte-compile-variables nil
390 "list of all variables encountered during compilation of this form")
391(defvar byte-compile-bound-variables nil
392 "list of variables bound in the context of the current form; this list
393lives partly on the stack.")
394(defvar byte-compile-free-references)
395(defvar byte-compile-free-assignments)
396
ab94e6e7
RS
397(defvar byte-compiler-error-flag)
398
1c393159 399(defconst byte-compile-initial-macro-environment
52799cb8
RS
400 '(
401;; (byte-compiler-options . (lambda (&rest forms)
402;; (apply 'byte-compiler-options-handler forms)))
1c393159
JB
403 (eval-when-compile . (lambda (&rest body)
404 (list 'quote (eval (byte-compile-top-level
405 (cons 'progn body))))))
406 (eval-and-compile . (lambda (&rest body)
407 (eval (cons 'progn body))
408 (cons 'progn body))))
409 "The default macro-environment passed to macroexpand by the compiler.
410Placing a macro here will cause a macro to have different semantics when
411expanded by the compiler as when expanded by the interpreter.")
412
413(defvar byte-compile-macro-environment byte-compile-initial-macro-environment
52799cb8
RS
414 "Alist of macros defined in the file being compiled.
415Each element looks like (MACRONAME . DEFINITION). It is
e27c3564 416\(MACRONAME . nil) when a macro is redefined as a function.")
1c393159
JB
417
418(defvar byte-compile-function-environment nil
52799cb8
RS
419 "Alist of functions defined in the file being compiled.
420This is so we can inline them when necessary.
421Each element looks like (FUNCTIONNAME . DEFINITION). It is
422\(FUNCTIONNAME . nil) when a function is redefined as a macro.")
1c393159
JB
423
424(defvar byte-compile-unresolved-functions nil
425 "Alist of undefined functions to which calls have been compiled (used for
426warnings when the function is later defined with incorrect args).")
427
428(defvar byte-compile-tag-number 0)
429(defvar byte-compile-output nil
430 "Alist describing contents to put in byte code string.
431Each element is (INDEX . VALUE)")
432(defvar byte-compile-depth 0 "Current depth of execution stack.")
433(defvar byte-compile-maxdepth 0 "Maximum depth of execution stack.")
434
435\f
436;;; The byte codes; this information is duplicated in bytecomp.c
437
438(defconst byte-code-vector nil
439 "An array containing byte-code names indexed by byte-code values.")
440
441(defconst byte-stack+-info nil
442 "An array with the stack adjustment for each byte-code.")
443
444(defmacro byte-defop (opcode stack-adjust opname &optional docstring)
445 ;; This is a speed-hack for building the byte-code-vector at compile-time.
446 ;; We fill in the vector at macroexpand-time, and then after the last call
447 ;; to byte-defop, we write the vector out as a constant instead of writing
448 ;; out a bunch of calls to aset.
449 ;; Actually, we don't fill in the vector itself, because that could make
450 ;; it problematic to compile big changes to this compiler; we store the
451 ;; values on its plist, and remove them later in -extrude.
452 (let ((v1 (or (get 'byte-code-vector 'tmp-compile-time-value)
453 (put 'byte-code-vector 'tmp-compile-time-value
454 (make-vector 256 nil))))
455 (v2 (or (get 'byte-stack+-info 'tmp-compile-time-value)
456 (put 'byte-stack+-info 'tmp-compile-time-value
457 (make-vector 256 nil)))))
458 (aset v1 opcode opname)
459 (aset v2 opcode stack-adjust))
460 (if docstring
461 (list 'defconst opname opcode (concat "Byte code opcode " docstring "."))
462 (list 'defconst opname opcode)))
463
464(defmacro byte-extrude-byte-code-vectors ()
465 (prog1 (list 'setq 'byte-code-vector
466 (get 'byte-code-vector 'tmp-compile-time-value)
467 'byte-stack+-info
468 (get 'byte-stack+-info 'tmp-compile-time-value))
469 ;; emacs-18 has no REMPROP.
470 (put 'byte-code-vector 'tmp-compile-time-value nil)
471 (put 'byte-stack+-info 'tmp-compile-time-value nil)))
472
473
474;; unused: 0-7
475
476;; These opcodes are special in that they pack their argument into the
477;; opcode word.
478;;
479(byte-defop 8 1 byte-varref "for variable reference")
480(byte-defop 16 -1 byte-varset "for setting a variable")
481(byte-defop 24 -1 byte-varbind "for binding a variable")
482(byte-defop 32 0 byte-call "for calling a function")
483(byte-defop 40 0 byte-unbind "for unbinding special bindings")
eb8c3be9 484;; codes 8-47 are consumed by the preceding opcodes
1c393159
JB
485
486;; unused: 48-55
487
488(byte-defop 56 -1 byte-nth)
489(byte-defop 57 0 byte-symbolp)
490(byte-defop 58 0 byte-consp)
491(byte-defop 59 0 byte-stringp)
492(byte-defop 60 0 byte-listp)
493(byte-defop 61 -1 byte-eq)
494(byte-defop 62 -1 byte-memq)
495(byte-defop 63 0 byte-not)
496(byte-defop 64 0 byte-car)
497(byte-defop 65 0 byte-cdr)
498(byte-defop 66 -1 byte-cons)
499(byte-defop 67 0 byte-list1)
500(byte-defop 68 -1 byte-list2)
501(byte-defop 69 -2 byte-list3)
502(byte-defop 70 -3 byte-list4)
503(byte-defop 71 0 byte-length)
504(byte-defop 72 -1 byte-aref)
505(byte-defop 73 -2 byte-aset)
506(byte-defop 74 0 byte-symbol-value)
507(byte-defop 75 0 byte-symbol-function) ; this was commented out
508(byte-defop 76 -1 byte-set)
509(byte-defop 77 -1 byte-fset) ; this was commented out
510(byte-defop 78 -1 byte-get)
511(byte-defop 79 -2 byte-substring)
512(byte-defop 80 -1 byte-concat2)
513(byte-defop 81 -2 byte-concat3)
514(byte-defop 82 -3 byte-concat4)
515(byte-defop 83 0 byte-sub1)
516(byte-defop 84 0 byte-add1)
517(byte-defop 85 -1 byte-eqlsign)
518(byte-defop 86 -1 byte-gtr)
519(byte-defop 87 -1 byte-lss)
520(byte-defop 88 -1 byte-leq)
521(byte-defop 89 -1 byte-geq)
522(byte-defop 90 -1 byte-diff)
523(byte-defop 91 0 byte-negate)
524(byte-defop 92 -1 byte-plus)
525(byte-defop 93 -1 byte-max)
526(byte-defop 94 -1 byte-min)
527(byte-defop 95 -1 byte-mult) ; v19 only
528(byte-defop 96 1 byte-point)
1c393159
JB
529(byte-defop 98 0 byte-goto-char)
530(byte-defop 99 0 byte-insert)
531(byte-defop 100 1 byte-point-max)
532(byte-defop 101 1 byte-point-min)
533(byte-defop 102 0 byte-char-after)
534(byte-defop 103 1 byte-following-char)
535(byte-defop 104 1 byte-preceding-char)
536(byte-defop 105 1 byte-current-column)
537(byte-defop 106 0 byte-indent-to)
538(byte-defop 107 0 byte-scan-buffer-OBSOLETE) ; no longer generated as of v18
539(byte-defop 108 1 byte-eolp)
540(byte-defop 109 1 byte-eobp)
541(byte-defop 110 1 byte-bolp)
542(byte-defop 111 1 byte-bobp)
543(byte-defop 112 1 byte-current-buffer)
544(byte-defop 113 0 byte-set-buffer)
78943c8a
RS
545(byte-defop 114 0 byte-save-current-buffer
546 "To make a binding to record the current buffer")
1c393159
JB
547(byte-defop 115 0 byte-set-mark-OBSOLETE)
548(byte-defop 116 1 byte-interactive-p)
549
550;; These ops are new to v19
551(byte-defop 117 0 byte-forward-char)
552(byte-defop 118 0 byte-forward-word)
553(byte-defop 119 -1 byte-skip-chars-forward)
554(byte-defop 120 -1 byte-skip-chars-backward)
555(byte-defop 121 0 byte-forward-line)
556(byte-defop 122 0 byte-char-syntax)
557(byte-defop 123 -1 byte-buffer-substring)
558(byte-defop 124 -1 byte-delete-region)
559(byte-defop 125 -1 byte-narrow-to-region)
560(byte-defop 126 1 byte-widen)
561(byte-defop 127 0 byte-end-of-line)
562
563;; unused: 128
564
565;; These store their argument in the next two bytes
566(byte-defop 129 1 byte-constant2
567 "for reference to a constant with vector index >= byte-constant-limit")
568(byte-defop 130 0 byte-goto "for unconditional jump")
569(byte-defop 131 -1 byte-goto-if-nil "to pop value and jump if it's nil")
570(byte-defop 132 -1 byte-goto-if-not-nil "to pop value and jump if it's not nil")
571(byte-defop 133 -1 byte-goto-if-nil-else-pop
572 "to examine top-of-stack, jump and don't pop it if it's nil,
573otherwise pop it")
574(byte-defop 134 -1 byte-goto-if-not-nil-else-pop
575 "to examine top-of-stack, jump and don't pop it if it's non nil,
576otherwise pop it")
577
578(byte-defop 135 -1 byte-return "to pop a value and return it from `byte-code'")
579(byte-defop 136 -1 byte-discard "to discard one value from stack")
580(byte-defop 137 1 byte-dup "to duplicate the top of the stack")
581
582(byte-defop 138 0 byte-save-excursion
583 "to make a binding to record the buffer, point and mark")
584(byte-defop 139 0 byte-save-window-excursion
585 "to make a binding to record entire window configuration")
586(byte-defop 140 0 byte-save-restriction
587 "to make a binding to record the current buffer clipping restrictions")
588(byte-defop 141 -1 byte-catch
589 "for catch. Takes, on stack, the tag and an expression for the body")
590(byte-defop 142 -1 byte-unwind-protect
591 "for unwind-protect. Takes, on stack, an expression for the unwind-action")
592
52799cb8
RS
593;; For condition-case. Takes, on stack, the variable to bind,
594;; an expression for the body, and a list of clauses.
595(byte-defop 143 -2 byte-condition-case)
1c393159 596
52799cb8
RS
597;; For entry to with-output-to-temp-buffer.
598;; Takes, on stack, the buffer name.
599;; Binds standard-output and does some other things.
600;; Returns with temp buffer on the stack in place of buffer name.
601(byte-defop 144 0 byte-temp-output-buffer-setup)
1c393159 602
52799cb8
RS
603;; For exit from with-output-to-temp-buffer.
604;; Expects the temp buffer on the stack underneath value to return.
605;; Pops them both, then pushes the value back on.
606;; Unbinds standard-output and makes the temp buffer visible.
607(byte-defop 145 -1 byte-temp-output-buffer-show)
1c393159
JB
608
609;; these ops are new to v19
52799cb8
RS
610
611;; To unbind back to the beginning of this frame.
69dc83fd 612;; Not used yet, but will be needed for tail-recursion elimination.
52799cb8 613(byte-defop 146 0 byte-unbind-all)
1c393159
JB
614
615;; these ops are new to v19
616(byte-defop 147 -2 byte-set-marker)
617(byte-defop 148 0 byte-match-beginning)
618(byte-defop 149 0 byte-match-end)
619(byte-defop 150 0 byte-upcase)
620(byte-defop 151 0 byte-downcase)
621(byte-defop 152 -1 byte-string=)
622(byte-defop 153 -1 byte-string<)
623(byte-defop 154 -1 byte-equal)
624(byte-defop 155 -1 byte-nthcdr)
625(byte-defop 156 -1 byte-elt)
626(byte-defop 157 -1 byte-member)
627(byte-defop 158 -1 byte-assq)
628(byte-defop 159 0 byte-nreverse)
629(byte-defop 160 -1 byte-setcar)
630(byte-defop 161 -1 byte-setcdr)
631(byte-defop 162 0 byte-car-safe)
632(byte-defop 163 0 byte-cdr-safe)
633(byte-defop 164 -1 byte-nconc)
634(byte-defop 165 -1 byte-quo)
635(byte-defop 166 -1 byte-rem)
636(byte-defop 167 0 byte-numberp)
637(byte-defop 168 0 byte-integerp)
638
3eac9910 639;; unused: 169-174
1c393159
JB
640(byte-defop 175 nil byte-listN)
641(byte-defop 176 nil byte-concatN)
642(byte-defop 177 nil byte-insertN)
643
644;; unused: 178-191
645
646(byte-defop 192 1 byte-constant "for reference to a constant")
647;; codes 193-255 are consumed by byte-constant.
648(defconst byte-constant-limit 64
649 "Exclusive maximum index usable in the `byte-constant' opcode.")
650
651(defconst byte-goto-ops '(byte-goto byte-goto-if-nil byte-goto-if-not-nil
652 byte-goto-if-nil-else-pop
653 byte-goto-if-not-nil-else-pop)
52799cb8 654 "List of byte-codes whose offset is a pc.")
1c393159
JB
655
656(defconst byte-goto-always-pop-ops '(byte-goto-if-nil byte-goto-if-not-nil))
657
1c393159
JB
658(byte-extrude-byte-code-vectors)
659\f
660;;; lapcode generator
661;;;
662;;; the byte-compiler now does source -> lapcode -> bytecode instead of
663;;; source -> bytecode, because it's a lot easier to make optimizations
664;;; on lapcode than on bytecode.
665;;;
666;;; Elements of the lapcode list are of the form (<instruction> . <parameter>)
667;;; where instruction is a symbol naming a byte-code instruction,
668;;; and parameter is an argument to that instruction, if any.
669;;;
670;;; The instruction can be the pseudo-op TAG, which means that this position
671;;; in the instruction stream is a target of a goto. (car PARAMETER) will be
672;;; the PC for this location, and the whole instruction "(TAG pc)" will be the
673;;; parameter for some goto op.
674;;;
675;;; If the operation is varbind, varref, varset or push-constant, then the
676;;; parameter is (variable/constant . index_in_constant_vector).
677;;;
678;;; First, the source code is macroexpanded and optimized in various ways.
679;;; Then the resultant code is compiled into lapcode. Another set of
680;;; optimizations are then run over the lapcode. Then the variables and
681;;; constants referenced by the lapcode are collected and placed in the
682;;; constants-vector. (This happens now so that variables referenced by dead
683;;; code don't consume space.) And finally, the lapcode is transformed into
684;;; compacted byte-code.
685;;;
686;;; A distinction is made between variables and constants because the variable-
687;;; referencing instructions are more sensitive to the variables being near the
688;;; front of the constants-vector than the constant-referencing instructions.
689;;; Also, this lets us notice references to free variables.
690
691(defun byte-compile-lapcode (lap)
692 "Turns lapcode into bytecode. The lapcode is destroyed."
693 ;; Lapcode modifications: changes the ID of a tag to be the tag's PC.
694 (let ((pc 0) ; Program counter
695 op off ; Operation & offset
696 (bytes '()) ; Put the output bytes here
697 (patchlist nil) ; List of tags and goto's to patch
698 rest rel tmp)
699 (while lap
700 (setq op (car (car lap))
701 off (cdr (car lap)))
702 (cond ((not (symbolp op))
52799cb8 703 (error "Non-symbolic opcode `%s'" op))
1c393159
JB
704 ((eq op 'TAG)
705 (setcar off pc)
706 (setq patchlist (cons off patchlist)))
707 ((memq op byte-goto-ops)
708 (setq pc (+ pc 3))
709 (setq bytes (cons (cons pc (cdr off))
710 (cons nil
711 (cons (symbol-value op) bytes))))
712 (setq patchlist (cons bytes patchlist)))
713 (t
714 (setq bytes
715 (cond ((cond ((consp off)
716 ;; Variable or constant reference
717 (setq off (cdr off))
718 (eq op 'byte-constant)))
719 (cond ((< off byte-constant-limit)
720 (setq pc (1+ pc))
721 (cons (+ byte-constant off) bytes))
722 (t
723 (setq pc (+ 3 pc))
724 (cons (lsh off -8)
725 (cons (logand off 255)
726 (cons byte-constant2 bytes))))))
727 ((<= byte-listN (symbol-value op))
728 (setq pc (+ 2 pc))
729 (cons off (cons (symbol-value op) bytes)))
730 ((< off 6)
731 (setq pc (1+ pc))
732 (cons (+ (symbol-value op) off) bytes))
733 ((< off 256)
734 (setq pc (+ 2 pc))
735 (cons off (cons (+ (symbol-value op) 6) bytes)))
736 (t
737 (setq pc (+ 3 pc))
738 (cons (lsh off -8)
739 (cons (logand off 255)
740 (cons (+ (symbol-value op) 7)
741 bytes))))))))
742 (setq lap (cdr lap)))
743 ;;(if (not (= pc (length bytes)))
52799cb8 744 ;; (error "Compiler error: pc mismatch - %s %s" pc (length bytes)))
1c393159
JB
745 ;; Patch PC into jumps
746 (let (bytes)
747 (while patchlist
748 (setq bytes (car patchlist))
749 (cond ((atom (car bytes))) ; Tag
1c393159
JB
750 (t ; Absolute jump
751 (setq pc (car (cdr (car bytes)))) ; Pick PC from tag
752 (setcar (cdr bytes) (logand pc 255))
753 (setcar bytes (lsh pc -8))))
754 (setq patchlist (cdr patchlist))))
755 (concat (nreverse bytes))))
756
757\f
758;;; byte compiler messages
759
d82e848c
RS
760(defvar byte-compile-current-form nil)
761(defvar byte-compile-current-file nil)
762(defvar byte-compile-dest-file nil)
1c393159
JB
763
764(defmacro byte-compile-log (format-string &rest args)
765 (list 'and
766 'byte-optimize
767 '(memq byte-optimize-log '(t source))
768 (list 'let '((print-escape-newlines t)
769 (print-level 4)
770 (print-length 4))
771 (list 'byte-compile-log-1
772 (cons 'format
773 (cons format-string
774 (mapcar
775 '(lambda (x)
776 (if (symbolp x) (list 'prin1-to-string x) x))
777 args)))))))
778
779(defconst byte-compile-last-warned-form nil)
780
144b2637
RS
781;; Log a message STRING in *Compile-Log*.
782;; Also log the current function and file if not already done.
9e2b097b 783(defun byte-compile-log-1 (string &optional fill)
1c393159
JB
784 (cond (noninteractive
785 (if (or byte-compile-current-file
786 (and byte-compile-last-warned-form
787 (not (eq byte-compile-current-form
788 byte-compile-last-warned-form))))
7e084653
KH
789 (message "While compiling %s%s:"
790 (or byte-compile-current-form "toplevel forms")
791 (if byte-compile-current-file
792 (if (stringp byte-compile-current-file)
793 (concat " in file " byte-compile-current-file)
794 (concat " in buffer "
795 (buffer-name byte-compile-current-file)))
796 "")))
1c393159
JB
797 (message " %s" string))
798 (t
799 (save-excursion
800 (set-buffer (get-buffer-create "*Compile-Log*"))
801 (goto-char (point-max))
802 (cond ((or byte-compile-current-file
803 (and byte-compile-last-warned-form
804 (not (eq byte-compile-current-form
805 byte-compile-last-warned-form))))
806 (if byte-compile-current-file
807 (insert "\n\^L\n" (current-time-string) "\n"))
808 (insert "While compiling "
809 (if byte-compile-current-form
810 (format "%s" byte-compile-current-form)
811 "toplevel forms"))
812 (if byte-compile-current-file
813 (if (stringp byte-compile-current-file)
814 (insert " in file " byte-compile-current-file)
815 (insert " in buffer "
816 (buffer-name byte-compile-current-file))))
817 (insert ":\n")))
9e2b097b
JB
818 (insert " " string "\n")
819 (if (and fill (not (string-match "\n" string)))
820 (let ((fill-prefix " ")
821 (fill-column 78))
822 (fill-paragraph nil)))
823 )))
1c393159
JB
824 (setq byte-compile-current-file nil
825 byte-compile-last-warned-form byte-compile-current-form))
826
144b2637
RS
827;; Log the start of a file in *Compile-Log*, and mark it as done.
828;; But do nothing in batch mode.
829(defun byte-compile-log-file ()
830 (and byte-compile-current-file (not noninteractive)
831 (save-excursion
832 (set-buffer (get-buffer-create "*Compile-Log*"))
ca96ae0b 833 (goto-char (point-max))
144b2637
RS
834 (insert "\n\^L\nCompiling "
835 (if (stringp byte-compile-current-file)
836 (concat "file " byte-compile-current-file)
837 (concat "buffer " (buffer-name byte-compile-current-file)))
838 " at " (current-time-string) "\n")
839 (setq byte-compile-current-file nil))))
840
1c393159
JB
841(defun byte-compile-warn (format &rest args)
842 (setq format (apply 'format format args))
843 (if byte-compile-error-on-warn
844 (error "%s" format) ; byte-compile-file catches and logs it
9e2b097b 845 (byte-compile-log-1 (concat "** " format) t)
fd5285f3
RS
846;;; It is useless to flash warnings too fast to be read.
847;;; Besides, they will all be shown at the end.
848;;; (or noninteractive ; already written on stdout.
849;;; (message "Warning: %s" format))
850 ))
1c393159 851
0b030df7
JB
852;;; This function should be used to report errors that have halted
853;;; compilation of the current file.
854(defun byte-compile-report-error (error-info)
ab94e6e7 855 (setq byte-compiler-error-flag t)
9e2b097b
JB
856 (byte-compile-log-1
857 (concat "!! "
858 (format (if (cdr error-info) "%s (%s)" "%s")
859 (get (car error-info) 'error-message)
860 (prin1-to-string (cdr error-info))))))
0b030df7 861
1c393159
JB
862;;; Used by make-obsolete.
863(defun byte-compile-obsolete (form)
e0b93488
RS
864 (let ((new (get (car form) 'byte-obsolete-info)))
865 (if (memq 'obsolete byte-compile-warnings)
9290191f
RS
866 (byte-compile-warn "%s is an obsolete function; %s" (car form)
867 (if (stringp (car new))
868 (car new)
e0b93488
RS
869 (format "use %s instead." (car new)))))
870 (funcall (or (cdr new) 'byte-compile-normal-call) form)))
1c393159
JB
871\f
872;; Compiler options
873
52799cb8
RS
874;; (defvar byte-compiler-valid-options
875;; '((optimize byte-optimize (t nil source byte) val)
876;; (file-format byte-compile-compatibility (emacs18 emacs19)
877;; (eq val 'emacs18))
878;; ;; (new-bytecodes byte-compile-generate-emacs19-bytecodes (t nil) val)
879;; (delete-errors byte-compile-delete-errors (t nil) val)
880;; (verbose byte-compile-verbose (t nil) val)
881;; (warnings byte-compile-warnings ((callargs redefine free-vars unresolved))
882;; val)))
1c393159
JB
883
884;; Inhibit v18/v19 selectors if the version is hardcoded.
885;; #### This should print a warning if the user tries to change something
886;; than can't be changed because the running compiler doesn't support it.
52799cb8
RS
887;; (cond
888;; ((byte-compile-single-version)
889;; (setcar (cdr (cdr (assq 'new-bytecodes byte-compiler-valid-options)))
890;; (list (byte-compile-version-cond
891;; byte-compile-generate-emacs19-bytecodes)))
892;; (setcar (cdr (cdr (assq 'file-format byte-compiler-valid-options)))
893;; (if (byte-compile-version-cond byte-compile-compatibility)
894;; '(emacs18) '(emacs19)))))
895
896;; (defun byte-compiler-options-handler (&rest args)
897;; (let (key val desc choices)
898;; (while args
899;; (if (or (atom (car args)) (nthcdr 2 (car args)) (null (cdr (car args))))
900;; (error "Malformed byte-compiler option `%s'" (car args)))
901;; (setq key (car (car args))
902;; val (car (cdr (car args)))
903;; desc (assq key byte-compiler-valid-options))
904;; (or desc
905;; (error "Unknown byte-compiler option `%s'" key))
906;; (setq choices (nth 2 desc))
907;; (if (consp (car choices))
908;; (let (this
909;; (handler 'cons)
910;; (ret (and (memq (car val) '(+ -))
911;; (copy-sequence (if (eq t (symbol-value (nth 1 desc)))
912;; choices
913;; (symbol-value (nth 1 desc)))))))
914;; (setq choices (car choices))
915;; (while val
916;; (setq this (car val))
917;; (cond ((memq this choices)
918;; (setq ret (funcall handler this ret)))
919;; ((eq this '+) (setq handler 'cons))
920;; ((eq this '-) (setq handler 'delq))
921;; ((error "`%s' only accepts %s" key choices)))
922;; (setq val (cdr val)))
923;; (set (nth 1 desc) ret))
924;; (or (memq val choices)
925;; (error "`%s' must be one of `%s'" key choices))
926;; (set (nth 1 desc) (eval (nth 3 desc))))
927;; (setq args (cdr args)))
928;; nil))
1c393159
JB
929\f
930;;; sanity-checking arglists
931
932(defun byte-compile-fdefinition (name macro-p)
933 (let* ((list (if macro-p
934 byte-compile-macro-environment
5286a842 935 byte-compile-function-environment))
1c393159
JB
936 (env (cdr (assq name list))))
937 (or env
938 (let ((fn name))
939 (while (and (symbolp fn)
940 (fboundp fn)
941 (or (symbolp (symbol-function fn))
942 (consp (symbol-function fn))
943 (and (not macro-p)
ed015bdd 944 (byte-code-function-p (symbol-function fn)))))
1c393159 945 (setq fn (symbol-function fn)))
ed015bdd 946 (if (and (not macro-p) (byte-code-function-p fn))
1c393159
JB
947 fn
948 (and (consp fn)
949 (if (eq 'macro (car fn))
950 (cdr fn)
951 (if macro-p
952 nil
953 (if (eq 'autoload (car fn))
954 nil
955 fn)))))))))
956
957(defun byte-compile-arglist-signature (arglist)
958 (let ((args 0)
959 opts
960 restp)
961 (while arglist
962 (cond ((eq (car arglist) '&optional)
963 (or opts (setq opts 0)))
964 ((eq (car arglist) '&rest)
965 (if (cdr arglist)
966 (setq restp t
967 arglist nil)))
968 (t
969 (if opts
970 (setq opts (1+ opts))
971 (setq args (1+ args)))))
972 (setq arglist (cdr arglist)))
973 (cons args (if restp nil (if opts (+ args opts) args)))))
974
975
976(defun byte-compile-arglist-signatures-congruent-p (old new)
977 (not (or
978 (> (car new) (car old)) ; requires more args now
a7acbbe4 979 (and (null (cdr old)) ; took rest-args, doesn't any more
1c393159
JB
980 (cdr new))
981 (and (cdr new) (cdr old) ; can't take as many args now
982 (< (cdr new) (cdr old)))
983 )))
984
985(defun byte-compile-arglist-signature-string (signature)
986 (cond ((null (cdr signature))
987 (format "%d+" (car signature)))
988 ((= (car signature) (cdr signature))
989 (format "%d" (car signature)))
990 (t (format "%d-%d" (car signature) (cdr signature)))))
991
992
52799cb8 993;; Warn if the form is calling a function with the wrong number of arguments.
1c393159 994(defun byte-compile-callargs-warn (form)
1c393159
JB
995 (let* ((def (or (byte-compile-fdefinition (car form) nil)
996 (byte-compile-fdefinition (car form) t)))
997 (sig (and def (byte-compile-arglist-signature
998 (if (eq 'lambda (car-safe def))
999 (nth 1 def)
d82e848c 1000 (if (byte-code-function-p def)
5286a842
RS
1001 (aref def 0)
1002 '(&rest def))))))
1c393159
JB
1003 (ncall (length (cdr form))))
1004 (if sig
1005 (if (or (< ncall (car sig))
1006 (and (cdr sig) (> ncall (cdr sig))))
1007 (byte-compile-warn
1008 "%s called with %d argument%s, but %s %s"
1009 (car form) ncall
1010 (if (= 1 ncall) "" "s")
1011 (if (< ncall (car sig))
1012 "requires"
1013 "accepts only")
1014 (byte-compile-arglist-signature-string sig)))
1015 (or (fboundp (car form)) ; might be a subr or autoload.
1016 (eq (car form) byte-compile-current-form) ; ## this doesn't work with recursion.
1017 ;; It's a currently-undefined function. Remember number of args in call.
1018 (let ((cons (assq (car form) byte-compile-unresolved-functions))
1019 (n (length (cdr form))))
1020 (if cons
1021 (or (memq n (cdr cons))
1022 (setcdr cons (cons n (cdr cons))))
1023 (setq byte-compile-unresolved-functions
1024 (cons (list (car form) n)
1025 byte-compile-unresolved-functions))))))))
1026
52799cb8
RS
1027;; Warn if the function or macro is being redefined with a different
1028;; number of arguments.
1c393159 1029(defun byte-compile-arglist-warn (form macrop)
1c393159
JB
1030 (let ((old (byte-compile-fdefinition (nth 1 form) macrop)))
1031 (if old
1032 (let ((sig1 (byte-compile-arglist-signature
1033 (if (eq 'lambda (car-safe old))
1034 (nth 1 old)
d82e848c 1035 (if (byte-code-function-p old)
5286a842
RS
1036 (aref old 0)
1037 '(&rest def)))))
1c393159
JB
1038 (sig2 (byte-compile-arglist-signature (nth 2 form))))
1039 (or (byte-compile-arglist-signatures-congruent-p sig1 sig2)
1040 (byte-compile-warn "%s %s used to take %s %s, now takes %s"
1041 (if (eq (car form) 'defun) "function" "macro")
1042 (nth 1 form)
1043 (byte-compile-arglist-signature-string sig1)
1044 (if (equal sig1 '(1 . 1)) "argument" "arguments")
1045 (byte-compile-arglist-signature-string sig2))))
1046 ;; This is the first definition. See if previous calls are compatible.
1047 (let ((calls (assq (nth 1 form) byte-compile-unresolved-functions))
1048 nums sig min max)
1049 (if calls
1050 (progn
1051 (setq sig (byte-compile-arglist-signature (nth 2 form))
1052 nums (sort (copy-sequence (cdr calls)) (function <))
1053 min (car nums)
1054 max (car (nreverse nums)))
1055 (if (or (< min (car sig))
1056 (and (cdr sig) (> max (cdr sig))))
1057 (byte-compile-warn
1058 "%s being defined to take %s%s, but was previously called with %s"
1059 (nth 1 form)
1060 (byte-compile-arglist-signature-string sig)
1061 (if (equal sig '(1 . 1)) " arg" " args")
1062 (byte-compile-arglist-signature-string (cons min max))))
1063
1064 (setq byte-compile-unresolved-functions
1065 (delq calls byte-compile-unresolved-functions)))))
1066 )))
1067
52799cb8
RS
1068;; If we have compiled any calls to functions which are not known to be
1069;; defined, issue a warning enumerating them.
1070;; `unresolved' in the list `byte-compile-warnings' disables this.
1c393159 1071(defun byte-compile-warn-about-unresolved-functions ()
1c393159
JB
1072 (if (memq 'unresolved byte-compile-warnings)
1073 (let ((byte-compile-current-form "the end of the data"))
1074 (if (cdr byte-compile-unresolved-functions)
170c9733 1075 (let* ((str "The following functions are not known to be defined:")
1c393159
JB
1076 (L (length str))
1077 (rest (reverse byte-compile-unresolved-functions))
1078 s)
1079 (while rest
1080 (setq s (symbol-name (car (car rest)))
1081 L (+ L (length s) 2)
1082 rest (cdr rest))
1083 (if (< L (1- fill-column))
1084 (setq str (concat str " " s (and rest ",")))
1085 (setq str (concat str "\n " s (and rest ","))
1086 L (+ (length s) 4))))
1087 (byte-compile-warn "%s" str))
1088 (if byte-compile-unresolved-functions
1089 (byte-compile-warn "the function %s is not known to be defined."
1090 (car (car byte-compile-unresolved-functions)))))))
1091 nil)
1092
1093\f
1094(defmacro byte-compile-constp (form)
1095 ;; Returns non-nil if FORM is a constant.
1096 (` (cond ((consp (, form)) (eq (car (, form)) 'quote))
1097 ((not (symbolp (, form))))
1098 ((memq (, form) '(nil t))))))
1099
1100(defmacro byte-compile-close-variables (&rest body)
1101 (cons 'let
1102 (cons '(;;
1103 ;; Close over these variables to encapsulate the
1104 ;; compilation state
1105 ;;
1106 (byte-compile-macro-environment
1107 ;; Copy it because the compiler may patch into the
1108 ;; macroenvironment.
1109 (copy-alist byte-compile-initial-macro-environment))
1110 (byte-compile-function-environment nil)
1111 (byte-compile-bound-variables nil)
1112 (byte-compile-free-references nil)
1113 (byte-compile-free-assignments nil)
1114 ;;
1115 ;; Close over these variables so that `byte-compiler-options'
1116 ;; can change them on a per-file basis.
1117 ;;
1118 (byte-compile-verbose byte-compile-verbose)
1119 (byte-optimize byte-optimize)
d82e848c
RS
1120 (byte-compile-compatibility byte-compile-compatibility)
1121 (byte-compile-dynamic byte-compile-dynamic)
1122 (byte-compile-dynamic-docstrings
1123 byte-compile-dynamic-docstrings)
52799cb8
RS
1124;; (byte-compile-generate-emacs19-bytecodes
1125;; byte-compile-generate-emacs19-bytecodes)
1c393159
JB
1126 (byte-compile-warnings (if (eq byte-compile-warnings t)
1127 byte-compile-warning-types
1128 byte-compile-warnings))
1129 )
1130 body)))
1131
144b2637 1132(defvar byte-compile-warnings-point-max nil)
1c393159
JB
1133(defmacro displaying-byte-compile-warnings (&rest body)
1134 (list 'let
144b2637
RS
1135 '((byte-compile-warnings-point-max byte-compile-warnings-point-max))
1136 ;; Log the file name.
1137 '(byte-compile-log-file)
1138 ;; Record how much is logged now.
1139 ;; We will display the log buffer if anything more is logged
1140 ;; before the end of BODY.
1141 '(or byte-compile-warnings-point-max
1142 (save-excursion
1143 (set-buffer (get-buffer-create "*Compile-Log*"))
1144 (setq byte-compile-warnings-point-max (point-max))))
0b030df7
JB
1145 (list 'unwind-protect
1146 (list 'condition-case 'error-info
1147 (cons 'progn body)
1148 '(error
1149 (byte-compile-report-error error-info)))
1c393159
JB
1150 '(save-excursion
1151 ;; If there were compilation warnings, display them.
1152 (set-buffer "*Compile-Log*")
1153 (if (= byte-compile-warnings-point-max (point-max))
1154 nil
1155 (select-window
1156 (prog1 (selected-window)
1157 (select-window (display-buffer (current-buffer)))
1158 (goto-char byte-compile-warnings-point-max)
713ea1de
RS
1159 (beginning-of-line)
1160 (forward-line -1)
cb5b843e 1161 (recenter 0))))))))
1c393159
JB
1162
1163\f
fd5285f3 1164;;;###autoload
9742dbc0
RS
1165(defun byte-force-recompile (directory)
1166 "Recompile every `.el' file in DIRECTORY that already has a `.elc' file.
1167Files in subdirectories of DIRECTORY are processed also."
c0f43df5 1168 (interactive "DByte force recompile (directory): ")
9742dbc0
RS
1169 (byte-recompile-directory directory nil t))
1170
1171;;;###autoload
1172(defun byte-recompile-directory (directory &optional arg force)
1c393159
JB
1173 "Recompile every `.el' file in DIRECTORY that needs recompilation.
1174This is if a `.elc' file exists but is older than the `.el' file.
691e7e76 1175Files in subdirectories of DIRECTORY are processed also.
1c393159
JB
1176
1177If the `.elc' file does not exist, normally the `.el' file is *not* compiled.
1178But a prefix argument (optional second arg) means ask user,
9e2b097b 1179for each such `.el' file, whether to compile it. Prefix argument 0 means
691e7e76
RS
1180don't ask and compile the file anyway.
1181
9742dbc0
RS
1182A nonzero prefix argument also means ask about each subdirectory.
1183
1184If the third argument FORCE is non-nil,
1185recompile every `.el' file that already has a `.elc' file."
1c393159 1186 (interactive "DByte recompile directory: \nP")
0dea0bbe
RM
1187 (if arg
1188 (setq arg (prefix-numeric-value arg)))
e27c3564
JB
1189 (if noninteractive
1190 nil
1191 (save-some-buffers)
ba901388 1192 (force-mode-line-update))
9e2b097b
JB
1193 (let ((directories (list (expand-file-name directory)))
1194 (file-count 0)
1195 (dir-count 0)
1196 last-dir)
1197 (displaying-byte-compile-warnings
1198 (while directories
1199 (setq directory (car directories))
080434ef 1200 (message "Checking %s..." directory)
9e2b097b
JB
1201 (let ((files (directory-files directory))
1202 source dest)
1203 (while files
1204 (setq source (expand-file-name (car files) directory))
1205 (if (and (not (member (car files) '("." ".." "RCS" "CVS")))
e9681c45
RS
1206 (file-directory-p source)
1207 (not (file-symlink-p source)))
9742dbc0 1208 ;; This file is a subdirectory. Handle them differently.
080434ef
RS
1209 (when (or (null arg)
1210 (eq 0 arg)
1211 (y-or-n-p (concat "Check " source "? ")))
1212 (setq directories
1213 (nconc directories (list source))))
9742dbc0 1214 ;; It is an ordinary file. Decide whether to compile it.
9e2b097b
JB
1215 (if (and (string-match emacs-lisp-file-regexp source)
1216 (not (auto-save-file-name-p source))
1217 (setq dest (byte-compile-dest-file source))
1218 (if (file-exists-p dest)
9742dbc0
RS
1219 ;; File was already compiled.
1220 (or force (file-newer-than-file-p source dest))
1221 ;; No compiled file exists yet.
9e2b097b 1222 (and arg
0dea0bbe 1223 (or (eq 0 arg)
9e2b097b 1224 (y-or-n-p (concat "Compile " source "? "))))))
e27c3564
JB
1225 (progn (if (and noninteractive (not byte-compile-verbose))
1226 (message "Compiling %s..." source))
1227 (byte-compile-file source)
47082fcd
RS
1228 (or noninteractive
1229 (message "Checking %s..." directory))
9e2b097b
JB
1230 (setq file-count (1+ file-count))
1231 (if (not (eq last-dir directory))
1232 (setq last-dir directory
1233 dir-count (1+ dir-count)))
1234 )))
1235 (setq files (cdr files))))
1236 (setq directories (cdr directories))))
1237 (message "Done (Total of %d file%s compiled%s)"
1238 file-count (if (= file-count 1) "" "s")
1239 (if (> dir-count 1) (format " in %d directories" dir-count) ""))))
1c393159 1240
fd5285f3 1241;;;###autoload
1c393159
JB
1242(defun byte-compile-file (filename &optional load)
1243 "Compile a file of Lisp code named FILENAME into a file of byte code.
1244The output file's name is made by appending `c' to the end of FILENAME.
1c57117e
RS
1245With prefix arg (noninteractively: 2nd arg), load the file after compiling.
1246The value is t if there were no errors, nil if errors."
1c393159
JB
1247;; (interactive "fByte compile file: \nP")
1248 (interactive
1249 (let ((file buffer-file-name)
1250 (file-name nil)
1251 (file-dir nil))
1252 (and file
1253 (eq (cdr (assq 'major-mode (buffer-local-variables)))
1254 'emacs-lisp-mode)
1255 (setq file-name (file-name-nondirectory file)
1256 file-dir (file-name-directory file)))
52799cb8
RS
1257 (list (read-file-name (if current-prefix-arg
1258 "Byte compile and load file: "
1259 "Byte compile file: ")
79c6071d 1260 file-dir file-name nil)
fd5285f3 1261 current-prefix-arg)))
1c393159
JB
1262 ;; Expand now so we get the current buffer's defaults
1263 (setq filename (expand-file-name filename))
1264
1265 ;; If we're compiling a file that's in a buffer and is modified, offer
1266 ;; to save it first.
1267 (or noninteractive
1268 (let ((b (get-file-buffer (expand-file-name filename))))
1269 (if (and b (buffer-modified-p b)
1270 (y-or-n-p (format "save buffer %s first? " (buffer-name b))))
1271 (save-excursion (set-buffer b) (save-buffer)))))
1272
1273 (if byte-compile-verbose
1274 (message "Compiling %s..." filename))
3ea1f391 1275 (let ((byte-compile-current-file filename)
dc14ae36 1276 (set-auto-coding-for-load t)
d82e848c
RS
1277 target-file input-buffer output-buffer
1278 byte-compile-dest-file)
1279 (setq target-file (byte-compile-dest-file filename))
1280 (setq byte-compile-dest-file target-file)
1c393159 1281 (save-excursion
ab94e6e7
RS
1282 (setq input-buffer (get-buffer-create " *Compiler Input*"))
1283 (set-buffer input-buffer)
1c393159 1284 (erase-buffer)
746dd298
RS
1285 ;; Always compile an Emacs Lisp file as multibyte
1286 ;; unless the file itself forces unibyte with -*-coding: raw-text;-*-x
1287 (set-buffer-multibyte t)
1c393159
JB
1288 (insert-file-contents filename)
1289 ;; Run hooks including the uncompression hook.
1290 ;; If they change the file name, then change it for the output also.
d82e848c 1291 (let ((buffer-file-name filename)
a096f13f 1292 (default-major-mode 'emacs-lisp-mode)
d82e848c
RS
1293 (enable-local-eval nil))
1294 (normal-mode)
cd891e68
RS
1295 (setq filename buffer-file-name))
1296 ;; Set the default directory, in case an eval-when-compile uses it.
1297 (setq default-directory (file-name-directory filename)))
ab94e6e7
RS
1298 (setq byte-compiler-error-flag nil)
1299 ;; It is important that input-buffer not be current at this call,
1300 ;; so that the value of point set in input-buffer
1301 ;; within byte-compile-from-buffer lingers in that buffer.
8a5dd086 1302 (setq output-buffer (byte-compile-from-buffer input-buffer filename))
189db152
RS
1303 (if byte-compiler-error-flag
1304 nil
92beedc2
KH
1305 (if byte-compile-verbose
1306 (message "Compiling %s...done" filename))
189db152
RS
1307 (kill-buffer input-buffer)
1308 (save-excursion
1309 (set-buffer output-buffer)
1310 (goto-char (point-max))
1311 (insert "\n") ; aaah, unix.
1312 (let ((vms-stmlf-recfm t))
189db152 1313 (if (file-writable-p target-file)
b8575ac3 1314 ;; We must disable any code conversion here.
95aeae46 1315 (let ((coding-system-for-write 'no-conversion))
2cd0169d 1316 (if (or (eq system-type 'ms-dos) (eq system-type 'windows-nt))
e3c72369 1317 (setq buffer-file-type t))
189db152
RS
1318 (write-region 1 (point-max) target-file))
1319 ;; This is just to give a better error message than
1320 ;; write-region
1321 (signal 'file-error
1322 (list "Opening output file"
1323 (if (file-exists-p target-file)
1324 "cannot overwrite file"
1325 "directory not writable or nonexistent")
d82e848c 1326 target-file))))
189db152
RS
1327 (kill-buffer (current-buffer)))
1328 (if (and byte-compile-generate-call-tree
1329 (or (eq t byte-compile-generate-call-tree)
1330 (y-or-n-p (format "Report call tree for %s? " filename))))
1331 (save-excursion
1332 (display-call-tree filename)))
1333 (if load
a2bb8f73
KH
1334 (load target-file))
1335 t)))
1c393159 1336
52799cb8
RS
1337;;(defun byte-compile-and-load-file (&optional filename)
1338;; "Compile a file of Lisp code named FILENAME into a file of byte code,
1339;;and then load it. The output file's name is made by appending \"c\" to
1340;;the end of FILENAME."
1341;; (interactive)
1342;; (if filename ; I don't get it, (interactive-p) doesn't always work
1343;; (byte-compile-file filename t)
1344;; (let ((current-prefix-arg '(4)))
1345;; (call-interactively 'byte-compile-file))))
1346
1347;;(defun byte-compile-buffer (&optional buffer)
1348;; "Byte-compile and evaluate contents of BUFFER (default: the current buffer)."
1349;; (interactive "bByte compile buffer: ")
1350;; (setq buffer (if buffer (get-buffer buffer) (current-buffer)))
1351;; (message "Compiling %s..." (buffer-name buffer))
1352;; (let* ((filename (or (buffer-file-name buffer)
1353;; (concat "#<buffer " (buffer-name buffer) ">")))
1354;; (byte-compile-current-file buffer))
8a5dd086 1355;; (byte-compile-from-buffer buffer nil))
52799cb8
RS
1356;; (message "Compiling %s...done" (buffer-name buffer))
1357;; t)
1c393159
JB
1358
1359;;; compiling a single function
fd5285f3 1360;;;###autoload
52799cb8 1361(defun compile-defun (&optional arg)
1c393159
JB
1362 "Compile and evaluate the current top-level form.
1363Print the result in the minibuffer.
1364With argument, insert value in current buffer after the form."
1365 (interactive "P")
1366 (save-excursion
1367 (end-of-defun)
1368 (beginning-of-defun)
1369 (let* ((byte-compile-current-file nil)
1370 (byte-compile-last-warned-form 'nothing)
fd5285f3
RS
1371 (value (eval (displaying-byte-compile-warnings
1372 (byte-compile-sexp (read (current-buffer)))))))
1c393159
JB
1373 (cond (arg
1374 (message "Compiling from buffer... done.")
1375 (prin1 value (current-buffer))
1376 (insert "\n"))
1377 ((message "%s" (prin1-to-string value)))))))
1378
1379
8a5dd086
RS
1380(defun byte-compile-from-buffer (inbuffer &optional filename)
1381 ;; Filename is used for the loading-into-Emacs-18 error message.
d82e848c
RS
1382 (let (outbuffer
1383 ;; Prevent truncation of flonums and lists as we read and print them
1384 (float-output-format nil)
1385 (case-fold-search nil)
1386 (print-length nil)
95e7d933 1387 (print-level nil)
74dfd056
RS
1388 ;; Prevent edebug from interfering when we compile
1389 ;; and put the output into a file.
1390 (edebug-all-defs nil)
1391 (edebug-all-forms nil)
d82e848c
RS
1392 ;; Simulate entry to byte-compile-top-level
1393 (byte-compile-constants nil)
1394 (byte-compile-variables nil)
1395 (byte-compile-tag-number 0)
1396 (byte-compile-depth 0)
1397 (byte-compile-maxdepth 0)
1398 (byte-compile-output nil)
1399 ;; #### This is bound in b-c-close-variables.
1400 ;; (byte-compile-warnings (if (eq byte-compile-warnings t)
1401 ;; byte-compile-warning-types
1402 ;; byte-compile-warnings))
1403 )
1404 (byte-compile-close-variables
1405 (save-excursion
1406 (setq outbuffer
1407 (set-buffer (get-buffer-create " *Compiler Output*")))
08b59cd3 1408 (set-buffer-multibyte t)
d82e848c
RS
1409 (erase-buffer)
1410 ;; (emacs-lisp-mode)
1411 (setq case-fold-search nil)
d82e848c
RS
1412 ;; This is a kludge. Some operating systems (OS/2, DOS) need to
1413 ;; write files containing binary information specially.
1414 ;; Under most circumstances, such files will be in binary
1415 ;; overwrite mode, so those OS's use that flag to guess how
1416 ;; they should write their data. Advise them that .elc files
1417 ;; need to be written carefully.
1418 (setq overwrite-mode 'overwrite-mode-binary))
1419 (displaying-byte-compile-warnings
fb639443 1420 (and filename (byte-compile-insert-header filename inbuffer outbuffer))
d82e848c
RS
1421 (save-excursion
1422 (set-buffer inbuffer)
1423 (goto-char 1)
1424
1425 ;; Compile the forms from the input buffer.
1426 (while (progn
1427 (while (progn (skip-chars-forward " \t\n\^l")
1428 (looking-at ";"))
1429 (forward-line 1))
1430 (not (eobp)))
1431 (byte-compile-file-form (read inbuffer)))
1432
1433 ;; Compile pending forms at end of file.
1434 (byte-compile-flush-pending)
1435 (byte-compile-warn-about-unresolved-functions)
a7acbbe4 1436 ;; Should we always do this? When calling multiple files, it
d82e848c
RS
1437 ;; would be useful to delay this warning until all have
1438 ;; been compiled.
fb639443
RS
1439 (setq byte-compile-unresolved-functions nil))
1440 ;; Fix up the header at the front of the output
1441 ;; if the buffer contains multibyte characters.
1442 (and filename (byte-compile-fix-header filename inbuffer outbuffer))))
285cdf4e 1443 outbuffer))
8a5dd086 1444
fb639443
RS
1445(defun byte-compile-fix-header (filename inbuffer outbuffer)
1446 (save-excursion
1447 (set-buffer outbuffer)
1448 (goto-char (point-min))
1449 ;; See if the buffer has any multibyte characters.
1450 (skip-chars-forward "\0-\377")
1451 (when (not (eobp))
1452 (when (byte-compile-version-cond byte-compile-compatibility)
1453 (error "Version-18 compatibility not valid with multibyte characters"))
1454 (goto-char (point-min))
1455 ;; Find the comment that describes the version test.
1456 (search-forward "\n;;; This file")
1457 (beginning-of-line)
1458 (narrow-to-region (point) (point-max))
1459 ;; Find the line of ballast semicolons.
1460 (search-forward ";;;;;;;;;;")
1461 (beginning-of-line)
1462
1463 (narrow-to-region (point-min) (point))
1464 (let ((old-header-end (point))
1465 delta)
1466 (goto-char (point-min))
1467 (delete-region (point) (progn (re-search-forward "^(")
1468 (beginning-of-line)
1469 (point)))
1470 (insert ";;; This file contains multibyte non-ASCII characters\n"
1471 ";;; and therefore cannot be loaded into Emacs 19.\n")
1472 ;; Replace "19" or "19.29" with "20", twice.
1473 (re-search-forward "19\\(\\.[0-9]+\\)")
1474 (replace-match "20")
1475 (re-search-forward "19\\(\\.[0-9]+\\)")
1476 (replace-match "20")
1477 ;; Now compensate for the change in size,
1478 ;; to make sure all positions in the file remain valid.
1479 (setq delta (- (point-max) old-header-end))
1480 (goto-char (point-max))
1481 (widen)
1482 (delete-char delta)))))
1483
f1f32df9
RS
1484(defun byte-compile-insert-header (filename inbuffer outbuffer)
1485 (set-buffer inbuffer)
1e098504 1486 (let ((dynamic-docstrings byte-compile-dynamic-docstrings)
fb639443 1487 (dynamic byte-compile-dynamic))
f1f32df9
RS
1488 (set-buffer outbuffer)
1489 (goto-char 1)
1596952e
RS
1490 ;; The magic number of .elc files is ";ELC", or 0x3B454C43. After
1491 ;; that is the file-format version number (18, 19 or 20) as a
1492 ;; byte, followed by some nulls. The primary motivation for doing
1493 ;; this is to get some binary characters up in the first line of
1494 ;; the file so that `diff' will simply say "Binary files differ"
1495 ;; instead of actually doing a diff of two .elc files. An extra
1496 ;; benefit is that you can add this to /etc/magic:
1497
f1f32df9
RS
1498 ;; 0 string ;ELC GNU Emacs Lisp compiled file,
1499 ;; >4 byte x version %d
1596952e 1500
f1f32df9
RS
1501 (insert
1502 ";ELC"
1596952e 1503 (if (byte-compile-version-cond byte-compile-compatibility) 18 20)
f1f32df9
RS
1504 "\000\000\000\n"
1505 )
1e098504 1506 (insert ";;; Compiled by "
f1f32df9
RS
1507 (or (and (boundp 'user-mail-address) user-mail-address)
1508 (concat (user-login-name) "@" (system-name)))
1509 " on "
1510 (current-time-string) "\n;;; from file " filename "\n")
1e098504 1511 (insert ";;; in Emacs version " emacs-version "\n")
5f17a95a 1512 (insert ";;; with bytecomp version "
fd20f015
RS
1513 (progn (string-match "[0-9.]+" byte-compile-version)
1514 (match-string 0 byte-compile-version))
5f17a95a 1515 "\n;;; "
f1f32df9 1516 (cond
1e098504
RS
1517 ((eq byte-optimize 'source) "with source-level optimization only")
1518 ((eq byte-optimize 'byte) "with byte-level optimization only")
1519 (byte-optimize "with all optimizations")
1520 (t "without optimization"))
f1f32df9
RS
1521 (if (byte-compile-version-cond byte-compile-compatibility)
1522 "; compiled with Emacs 18 compatibility.\n"
1523 ".\n"))
1e098504
RS
1524 (if dynamic
1525 (insert ";;; Function definitions are lazy-loaded.\n"))
fb639443 1526 (if (not (byte-compile-version-cond byte-compile-compatibility))
1596952e
RS
1527 (let (intro-string minimum-version)
1528 ;; Figure out which Emacs version to require,
1529 ;; and what comment to use to explain why.
fb639443
RS
1530 ;; Note that this fails to take account of whether
1531 ;; the buffer contains multibyte characters. We may have to
1532 ;; compensate at the end in byte-compile-fix-header.
1533 (if dynamic-docstrings
1596952e 1534 (setq intro-string
fb639443
RS
1535 ";;; This file uses dynamic docstrings, first added in Emacs 19.29.\n"
1536 minimum-version "19.29")
1537 (setq intro-string
1538 ";;; This file uses opcodes which do not exist in Emacs 18.\n"
1539 minimum-version "19"))
1596952e
RS
1540 ;; Now insert the comment and the error check.
1541 (insert
fb639443 1542 "\n"
1596952e
RS
1543 intro-string
1544 ;; Have to check if emacs-version is bound so that this works
1545 ;; in files loaded early in loadup.el.
fb639443 1546 "(if (and (boundp 'emacs-version)\n"
1596952e
RS
1547 ;; If there is a name at the end of emacs-version,
1548 ;; don't try to check the version number.
1549 "\t (< (aref emacs-version (1- (length emacs-version))) ?A)\n"
1550 "\t (or (and (boundp 'epoch::version) epoch::version)\n"
1551 (format "\t (string-lessp emacs-version \"%s\")))\n"
1552 minimum-version)
1553 " (error \"`"
1554 ;; prin1-to-string is used to quote backslashes.
1555 (substring (prin1-to-string (file-name-nondirectory filename))
1556 1 -1)
1557 (format "' was compiled for Emacs %s or later\"))\n\n"
fb639443
RS
1558 minimum-version)
1559 ;; Insert semicolons as ballast, so that byte-compile-fix-header
1560 ;; can delete them so as to keep the buffer positions
1561 ;; constant for the actual compiled code.
1562 ";;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;\n\n"))
1596952e 1563 ;; Here if we want Emacs 18 compatibility.
fb639443
RS
1564 (when dynamic-docstrings
1565 (error "Version-18 compatibility doesn't support dynamic doc strings"))
1566 (when byte-compile-dynamic
1567 (error "Version-18 compatibility doesn't support dynamic byte code"))
f1f32df9 1568 (insert "(or (boundp 'current-load-list) (setq current-load-list nil))\n"
1596952e 1569 "\n"))))
1c393159
JB
1570
1571(defun byte-compile-output-file-form (form)
1572 ;; writes the given form to the output buffer, being careful of docstrings
36b7e523
RS
1573 ;; in defun, defmacro, defvar, defconst, autoload and
1574 ;; custom-declare-variable because make-docfile is so amazingly stupid.
c36881cf
ER
1575 ;; defalias calls are output directly by byte-compile-file-form-defmumble;
1576 ;; it does not pay to first build the defalias in defmumble and then parse
1577 ;; it here.
36b7e523
RS
1578 (if (and (memq (car-safe form) '(defun defmacro defvar defconst autoload
1579 custom-declare-variable))
1c393159 1580 (stringp (nth 3 form)))
d82e848c 1581 (byte-compile-output-docform nil nil '("\n(" 3 ")") form nil
36b7e523
RS
1582 (memq (car form)
1583 '(autoload custom-declare-variable)))
1c393159 1584 (let ((print-escape-newlines t)
37c29340
KH
1585 (print-length nil)
1586 (print-level nil)
77308fd7
EN
1587 (print-quoted t)
1588 (print-gensym t))
1c393159
JB
1589 (princ "\n" outbuffer)
1590 (prin1 form outbuffer)
1591 nil)))
1592
d82e848c 1593(defun byte-compile-output-docform (preface name info form specindex quoted)
dac6f673
RS
1594 "Print a form with a doc string. INFO is (prefix doc-index postfix).
1595If PREFACE and NAME are non-nil, print them too,
1596before INFO and the FORM but after the doc string itself.
1597If SPECINDEX is non-nil, it is the index in FORM
1598of the function bytecode string. In that case,
1599we output that argument and the following argument (the constants vector)
1600together, for lazy loading.
1601QUOTED says that we have to put a quote before the
1602list that represents a doc string reference.
36b7e523 1603`autoload' and `custom-declare-variable' need that."
dac6f673
RS
1604 ;; We need to examine byte-compile-dynamic-docstrings
1605 ;; in the input buffer (now current), not in the output buffer.
1606 (let ((dynamic-docstrings byte-compile-dynamic-docstrings))
1607 (set-buffer
1608 (prog1 (current-buffer)
1609 (set-buffer outbuffer)
1610 (let (position)
1611
1612 ;; Insert the doc string, and make it a comment with #@LENGTH.
1613 (and (>= (nth 1 info) 0)
1614 dynamic-docstrings
393ae6ec 1615 (not byte-compile-compatibility)
dac6f673
RS
1616 (progn
1617 ;; Make the doc string start at beginning of line
1618 ;; for make-docfile's sake.
1619 (insert "\n")
1620 (setq position
1621 (byte-compile-output-as-comment
1622 (nth (nth 1 info) form) nil))
1cdb6e7c 1623 (setq position (position-bytes position))
dac6f673
RS
1624 ;; If the doc string starts with * (a user variable),
1625 ;; negate POSITION.
1626 (if (and (stringp (nth (nth 1 info) form))
1627 (> (length (nth (nth 1 info) form)) 0)
1628 (eq (aref (nth (nth 1 info) form) 0) ?*))
1629 (setq position (- position)))))
1630
1631 (if preface
1632 (progn
1633 (insert preface)
1634 (prin1 name outbuffer)))
1635 (insert (car info))
1636 (let ((print-escape-newlines t)
77308fd7 1637 (print-quoted t)
b077f045
RS
1638 ;; Use a cons cell to say that we want
1639 ;; print-gensym-alist not to be cleared
1640 ;; between calls to print functions.
1641 (print-gensym '(t))
1642 print-gensym-alist
dac6f673
RS
1643 (index 0))
1644 (prin1 (car form) outbuffer)
1645 (while (setq form (cdr form))
1646 (setq index (1+ index))
1647 (insert " ")
1648 (cond ((and (numberp specindex) (= index specindex))
1649 (let ((position
1650 (byte-compile-output-as-comment
1651 (cons (car form) (nth 1 form))
1652 t)))
1cdb6e7c 1653 (setq position (position-bytes position))
dac6f673
RS
1654 (princ (format "(#$ . %d) nil" position) outbuffer)
1655 (setq form (cdr form))
1656 (setq index (1+ index))))
1657 ((= index (nth 1 info))
1658 (if position
1659 (princ (format (if quoted "'(#$ . %d)" "(#$ . %d)")
1660 position)
1661 outbuffer)
1662 (let ((print-escape-newlines nil))
1663 (goto-char (prog1 (1+ (point))
1664 (prin1 (car form) outbuffer)))
1665 (insert "\\\n")
1666 (goto-char (point-max)))))
1667 (t
1668 (prin1 (car form) outbuffer)))))
1669 (insert (nth 2 info))))))
1c393159
JB
1670 nil)
1671
1672(defun byte-compile-keep-pending (form &optional handler)
1673 (if (memq byte-optimize '(t source))
1674 (setq form (byte-optimize-form form t)))
1675 (if handler
1676 (let ((for-effect t))
1677 ;; To avoid consing up monstrously large forms at load time, we split
1678 ;; the output regularly.
b4ff4a23
RS
1679 (and (memq (car-safe form) '(fset defalias))
1680 (nthcdr 300 byte-compile-output)
1c393159
JB
1681 (byte-compile-flush-pending))
1682 (funcall handler form)
1683 (if for-effect
1684 (byte-compile-discard)))
1685 (byte-compile-form form t))
1686 nil)
1687
1688(defun byte-compile-flush-pending ()
1689 (if byte-compile-output
1690 (let ((form (byte-compile-out-toplevel t 'file)))
1691 (cond ((eq (car-safe form) 'progn)
1692 (mapcar 'byte-compile-output-file-form (cdr form)))
1693 (form
1694 (byte-compile-output-file-form form)))
1695 (setq byte-compile-constants nil
1696 byte-compile-variables nil
1697 byte-compile-depth 0
1698 byte-compile-maxdepth 0
1699 byte-compile-output nil))))
1700
1701(defun byte-compile-file-form (form)
1702 (let ((byte-compile-current-form nil) ; close over this for warnings.
1703 handler)
1704 (cond
1705 ((not (consp form))
1706 (byte-compile-keep-pending form))
1707 ((and (symbolp (car form))
1708 (setq handler (get (car form) 'byte-hunk-handler)))
1709 (cond ((setq form (funcall handler form))
1710 (byte-compile-flush-pending)
1711 (byte-compile-output-file-form form))))
1712 ((eq form (setq form (macroexpand form byte-compile-macro-environment)))
1713 (byte-compile-keep-pending form))
1714 (t
1715 (byte-compile-file-form form)))))
1716
1717;; Functions and variables with doc strings must be output separately,
1718;; so make-docfile can recognise them. Most other things can be output
1719;; as byte-code.
1720
1721(put 'defsubst 'byte-hunk-handler 'byte-compile-file-form-defsubst)
1722(defun byte-compile-file-form-defsubst (form)
1723 (cond ((assq (nth 1 form) byte-compile-unresolved-functions)
1724 (setq byte-compile-current-form (nth 1 form))
1725 (byte-compile-warn "defsubst %s was used before it was defined"
1726 (nth 1 form))))
1727 (byte-compile-file-form
1728 (macroexpand form byte-compile-macro-environment))
1729 ;; Return nil so the form is not output twice.
1730 nil)
1731
1732(put 'autoload 'byte-hunk-handler 'byte-compile-file-form-autoload)
1733(defun byte-compile-file-form-autoload (form)
1734 (and (let ((form form))
1735 (while (if (setq form (cdr form)) (byte-compile-constp (car form))))
1736 (null form)) ;Constants only
1737 (eval (nth 5 form)) ;Macro
1738 (eval form)) ;Define the autoload.
1739 (if (stringp (nth 3 form))
1740 form
1741 ;; No doc string, so we can compile this as a normal form.
1742 (byte-compile-keep-pending form 'byte-compile-normal-call)))
1743
1744(put 'defvar 'byte-hunk-handler 'byte-compile-file-form-defvar)
1745(put 'defconst 'byte-hunk-handler 'byte-compile-file-form-defvar)
1746(defun byte-compile-file-form-defvar (form)
1747 (if (null (nth 3 form))
1748 ;; Since there is no doc string, we can compile this as a normal form,
1749 ;; and not do a file-boundary.
1750 (byte-compile-keep-pending form)
1751 (if (memq 'free-vars byte-compile-warnings)
1752 (setq byte-compile-bound-variables
1753 (cons (nth 1 form) byte-compile-bound-variables)))
1754 (cond ((consp (nth 2 form))
1755 (setq form (copy-sequence form))
1756 (setcar (cdr (cdr form))
1757 (byte-compile-top-level (nth 2 form) nil 'file))))
1758 form))
1759
8c731d3d
RS
1760(put 'custom-declare-variable 'byte-hunk-handler
1761 'byte-compile-file-form-custom-declare-variable)
1762(defun byte-compile-file-form-custom-declare-variable (form)
1763 (if (memq 'free-vars byte-compile-warnings)
1764 (setq byte-compile-bound-variables
1765 (cons (nth 1 (nth 1 form)) byte-compile-bound-variables)))
1766 form)
1767
1c393159
JB
1768(put 'require 'byte-hunk-handler 'byte-compile-file-form-eval-boundary)
1769(defun byte-compile-file-form-eval-boundary (form)
1770 (eval form)
1771 (byte-compile-keep-pending form 'byte-compile-normal-call))
1772
1773(put 'progn 'byte-hunk-handler 'byte-compile-file-form-progn)
1774(put 'prog1 'byte-hunk-handler 'byte-compile-file-form-progn)
1775(put 'prog2 'byte-hunk-handler 'byte-compile-file-form-progn)
1776(defun byte-compile-file-form-progn (form)
1777 (mapcar 'byte-compile-file-form (cdr form))
1778 ;; Return nil so the forms are not output twice.
1779 nil)
1780
1781;; This handler is not necessary, but it makes the output from dont-compile
1782;; and similar macros cleaner.
1783(put 'eval 'byte-hunk-handler 'byte-compile-file-form-eval)
1784(defun byte-compile-file-form-eval (form)
1785 (if (eq (car-safe (nth 1 form)) 'quote)
1786 (nth 1 (nth 1 form))
1787 (byte-compile-keep-pending form)))
1788
1789(put 'defun 'byte-hunk-handler 'byte-compile-file-form-defun)
1790(defun byte-compile-file-form-defun (form)
1791 (byte-compile-file-form-defmumble form nil))
1792
1793(put 'defmacro 'byte-hunk-handler 'byte-compile-file-form-defmacro)
1794(defun byte-compile-file-form-defmacro (form)
1795 (byte-compile-file-form-defmumble form t))
1796
1797(defun byte-compile-file-form-defmumble (form macrop)
1798 (let* ((name (car (cdr form)))
1799 (this-kind (if macrop 'byte-compile-macro-environment
1800 'byte-compile-function-environment))
1801 (that-kind (if macrop 'byte-compile-function-environment
1802 'byte-compile-macro-environment))
1803 (this-one (assq name (symbol-value this-kind)))
1804 (that-one (assq name (symbol-value that-kind)))
1805 (byte-compile-free-references nil)
1806 (byte-compile-free-assignments nil))
1807
1808 ;; When a function or macro is defined, add it to the call tree so that
1809 ;; we can tell when functions are not used.
1810 (if byte-compile-generate-call-tree
1811 (or (assq name byte-compile-call-tree)
1812 (setq byte-compile-call-tree
1813 (cons (list name nil nil) byte-compile-call-tree))))
1814
1815 (setq byte-compile-current-form name) ; for warnings
1816 (if (memq 'redefine byte-compile-warnings)
1817 (byte-compile-arglist-warn form macrop))
1818 (if byte-compile-verbose
47cf9d3a 1819 (message "Compiling %s... (%s)" (or filename "") (nth 1 form)))
1c393159
JB
1820 (cond (that-one
1821 (if (and (memq 'redefine byte-compile-warnings)
52799cb8 1822 ;; don't warn when compiling the stubs in byte-run...
1c393159
JB
1823 (not (assq (nth 1 form)
1824 byte-compile-initial-macro-environment)))
1825 (byte-compile-warn
1826 "%s defined multiple times, as both function and macro"
1827 (nth 1 form)))
1828 (setcdr that-one nil))
1829 (this-one
1830 (if (and (memq 'redefine byte-compile-warnings)
1831 ;; hack: don't warn when compiling the magic internal
52799cb8 1832 ;; byte-compiler macros in byte-run.el...
1c393159
JB
1833 (not (assq (nth 1 form)
1834 byte-compile-initial-macro-environment)))
1835 (byte-compile-warn "%s %s defined multiple times in this file"
1836 (if macrop "macro" "function")
1837 (nth 1 form))))
1838 ((and (fboundp name)
1839 (eq (car-safe (symbol-function name))
1840 (if macrop 'lambda 'macro)))
1841 (if (memq 'redefine byte-compile-warnings)
1842 (byte-compile-warn "%s %s being redefined as a %s"
1843 (if macrop "function" "macro")
1844 (nth 1 form)
1845 (if macrop "macro" "function")))
1846 ;; shadow existing definition
1847 (set this-kind
1848 (cons (cons name nil) (symbol-value this-kind))))
1849 )
1850 (let ((body (nthcdr 3 form)))
1851 (if (and (stringp (car body))
1852 (symbolp (car-safe (cdr-safe body)))
1853 (car-safe (cdr-safe body))
1854 (stringp (car-safe (cdr-safe (cdr-safe body)))))
1855 (byte-compile-warn "Probable `\"' without `\\' in doc string of %s"
1856 (nth 1 form))))
1857 (let* ((new-one (byte-compile-lambda (cons 'lambda (nthcdr 2 form))))
1858 (code (byte-compile-byte-code-maker new-one)))
1859 (if this-one
1860 (setcdr this-one new-one)
1861 (set this-kind
1862 (cons (cons name new-one) (symbol-value this-kind))))
1863 (if (and (stringp (nth 3 form))
1864 (eq 'quote (car-safe code))
1865 (eq 'lambda (car-safe (nth 1 code))))
1866 (cons (car form)
1867 (cons name (cdr (nth 1 code))))
d82e848c 1868 (byte-compile-flush-pending)
1c393159 1869 (if (not (stringp (nth 3 form)))
d82e848c
RS
1870 ;; No doc string. Provide -1 as the "doc string index"
1871 ;; so that no element will be treated as a doc string.
1872 (byte-compile-output-docform
1873 (if (byte-compile-version-cond byte-compile-compatibility)
1874 "\n(fset '" "\n(defalias '")
1875 name
1876 (cond ((atom code)
1877 (if macrop '(" '(macro . #[" -1 "])") '(" #[" -1 "]")))
1878 ((eq (car code) 'quote)
1879 (setq code new-one)
1880 (if macrop '(" '(macro " -1 ")") '(" '(" -1 ")")))
1881 ((if macrop '(" (cons 'macro (" -1 "))") '(" (" -1 ")"))))
1882 (append code nil)
1883 (and (atom code) byte-compile-dynamic
1884 1)
1885 nil)
1c393159 1886 ;; Output the form by hand, that's much simpler than having
c36881cf 1887 ;; b-c-output-file-form analyze the defalias.
1c393159 1888 (byte-compile-output-docform
d82e848c
RS
1889 (if (byte-compile-version-cond byte-compile-compatibility)
1890 "\n(fset '" "\n(defalias '")
1891 name
1c393159
JB
1892 (cond ((atom code)
1893 (if macrop '(" '(macro . #[" 4 "])") '(" #[" 4 "]")))
1894 ((eq (car code) 'quote)
1895 (setq code new-one)
1896 (if macrop '(" '(macro " 2 ")") '(" '(" 2 ")")))
1897 ((if macrop '(" (cons 'macro (" 5 "))") '(" (" 5 ")"))))
d82e848c
RS
1898 (append code nil)
1899 (and (atom code) byte-compile-dynamic
1900 1)
1901 nil))
1902 (princ ")" outbuffer)
1903 nil))))
1904
1905;; Print Lisp object EXP in the output file, inside a comment,
1906;; and return the file position it will have.
1907;; If QUOTED is non-nil, print with quoting; otherwise, print without quoting.
1908(defun byte-compile-output-as-comment (exp quoted)
2d5975fa 1909 (let ((position (point)))
d82e848c
RS
1910 (set-buffer
1911 (prog1 (current-buffer)
1912 (set-buffer outbuffer)
1913
1914 ;; Insert EXP, and make it a comment with #@LENGTH.
1915 (insert " ")
1916 (if quoted
1917 (prin1 exp outbuffer)
1918 (princ exp outbuffer))
1919 (goto-char position)
1920 ;; Quote certain special characters as needed.
1921 ;; get_doc_string in doc.c does the unquoting.
1922 (while (search-forward "\^A" nil t)
1923 (replace-match "\^A\^A" t t))
1924 (goto-char position)
1925 (while (search-forward "\000" nil t)
1926 (replace-match "\^A0" t t))
1927 (goto-char position)
1928 (while (search-forward "\037" nil t)
1929 (replace-match "\^A_" t t))
1930 (goto-char (point-max))
1931 (insert "\037")
1932 (goto-char position)
2d5975fa
KH
1933 (insert "#@" (format "%d" (- (position-bytes (point-max))
1934 (position-bytes position))))
d82e848c
RS
1935
1936 ;; Save the file position of the object.
1937 ;; Note we should add 1 to skip the space
1938 ;; that we inserted before the actual doc string,
1939 ;; and subtract 1 to convert from an 1-origin Emacs position
1940 ;; to a file position; they cancel.
1941 (setq position (point))
1942 (goto-char (point-max))))
1943 position))
1944
1c393159
JB
1945
1946\f
fd5285f3 1947;;;###autoload
1c393159
JB
1948(defun byte-compile (form)
1949 "If FORM is a symbol, byte-compile its function definition.
1950If FORM is a lambda or a macro, byte-compile it as a function."
1951 (displaying-byte-compile-warnings
1952 (byte-compile-close-variables
1953 (let* ((fun (if (symbolp form)
1954 (and (fboundp form) (symbol-function form))
1955 form))
1956 (macro (eq (car-safe fun) 'macro)))
1957 (if macro
1958 (setq fun (cdr fun)))
1959 (cond ((eq (car-safe fun) 'lambda)
1960 (setq fun (if macro
1961 (cons 'macro (byte-compile-lambda fun))
1962 (byte-compile-lambda fun)))
1963 (if (symbolp form)
c36881cf 1964 (defalias form fun)
1c393159
JB
1965 fun)))))))
1966
1967(defun byte-compile-sexp (sexp)
1968 "Compile and return SEXP."
1969 (displaying-byte-compile-warnings
1970 (byte-compile-close-variables
1971 (byte-compile-top-level sexp))))
1972
1973;; Given a function made by byte-compile-lambda, make a form which produces it.
1974(defun byte-compile-byte-code-maker (fun)
1975 (cond
52799cb8 1976 ((byte-compile-version-cond byte-compile-compatibility)
1c393159
JB
1977 ;; Return (quote (lambda ...)).
1978 (list 'quote (byte-compile-byte-code-unmake fun)))
1979 ;; ## atom is faster than compiled-func-p.
1980 ((atom fun) ; compiled function.
1981 ;; generate-emacs19-bytecodes must be on, otherwise byte-compile-lambda
1982 ;; would have produced a lambda.
469414a0 1983 fun)
1c393159 1984 ;; b-c-lambda didn't produce a compiled-function, so it's either a trivial
52799cb8 1985 ;; function, or this is Emacs 18, or generate-emacs19-bytecodes is off.
1c393159
JB
1986 ((let (tmp)
1987 (if (and (setq tmp (assq 'byte-code (cdr-safe (cdr fun))))
1988 (null (cdr (memq tmp fun))))
1989 ;; Generate a make-byte-code call.
1990 (let* ((interactive (assq 'interactive (cdr (cdr fun)))))
1991 (nconc (list 'make-byte-code
1992 (list 'quote (nth 1 fun)) ;arglist
1993 (nth 1 tmp) ;bytes
1994 (nth 2 tmp) ;consts
1995 (nth 3 tmp)) ;depth
1996 (cond ((stringp (nth 2 fun))
1997 (list (nth 2 fun))) ;doc
1998 (interactive
1999 (list nil)))
2000 (cond (interactive
2001 (list (if (or (null (nth 1 interactive))
2002 (stringp (nth 1 interactive)))
2003 (nth 1 interactive)
2004 ;; Interactive spec is a list or a variable
2005 ;; (if it is correct).
2006 (list 'quote (nth 1 interactive))))))))
2007 ;; a non-compiled function (probably trivial)
2008 (list 'quote fun))))))
2009
2010;; Turn a function into an ordinary lambda. Needed for v18 files.
2011(defun byte-compile-byte-code-unmake (function)
2012 (if (consp function)
2013 function;;It already is a lambda.
2014 (setq function (append function nil)) ; turn it into a list
2015 (nconc (list 'lambda (nth 0 function))
2016 (and (nth 4 function) (list (nth 4 function)))
2017 (if (nthcdr 5 function)
2018 (list (cons 'interactive (if (nth 5 function)
2019 (nthcdr 5 function)))))
2020 (list (list 'byte-code
2021 (nth 1 function) (nth 2 function)
2022 (nth 3 function))))))
2023
2024
2025;; Byte-compile a lambda-expression and return a valid function.
2026;; The value is usually a compiled function but may be the original
2027;; lambda-expression.
2028(defun byte-compile-lambda (fun)
2029 (let* ((arglist (nth 1 fun))
2030 (byte-compile-bound-variables
2031 (nconc (and (memq 'free-vars byte-compile-warnings)
2032 (delq '&rest (delq '&optional (copy-sequence arglist))))
2033 byte-compile-bound-variables))
2034 (body (cdr (cdr fun)))
2035 (doc (if (stringp (car body))
2036 (prog1 (car body)
d8f59f56
RS
2037 ;; Discard the doc string
2038 ;; unless it is the last element of the body.
b9edcafb 2039 (if (cdr body)
d8f59f56 2040 (setq body (cdr body))))))
1c393159
JB
2041 (int (assq 'interactive body)))
2042 (cond (int
2043 ;; Skip (interactive) if it is in front (the most usual location).
2044 (if (eq int (car body))
2045 (setq body (cdr body)))
ffc394dd 2046 (cond ((consp (cdr int))
1c393159
JB
2047 (if (cdr (cdr int))
2048 (byte-compile-warn "malformed interactive spec: %s"
2049 (prin1-to-string int)))
ffc394dd
RS
2050 ;; If the interactive spec is a call to `list',
2051 ;; don't compile it, because `call-interactively'
2052 ;; looks at the args of `list'.
c0f43df5
RS
2053 (let ((form (nth 1 int)))
2054 (while (or (eq (car-safe form) 'let)
2055 (eq (car-safe form) 'let*)
2056 (eq (car-safe form) 'save-excursion))
2057 (while (consp (cdr form))
2058 (setq form (cdr form)))
2059 (setq form (car form)))
2060 (or (eq (car-safe form) 'list)
2061 (setq int (list 'interactive
2062 (byte-compile-top-level (nth 1 int)))))))
ffc394dd
RS
2063 ((cdr int)
2064 (byte-compile-warn "malformed interactive spec: %s"
2065 (prin1-to-string int))))))
1c393159
JB
2066 (let ((compiled (byte-compile-top-level (cons 'progn body) nil 'lambda)))
2067 (if (and (eq 'byte-code (car-safe compiled))
b890df1a
RS
2068 (not (byte-compile-version-cond
2069 byte-compile-compatibility)))
1c393159
JB
2070 (apply 'make-byte-code
2071 (append (list arglist)
2072 ;; byte-string, constants-vector, stack depth
2073 (cdr compiled)
2074 ;; optionally, the doc string.
2075 (if (or doc int)
2076 (list doc))
2077 ;; optionally, the interactive spec.
2078 (if int
2079 (list (nth 1 int)))))
2080 (setq compiled
2081 (nconc (if int (list int))
2082 (cond ((eq (car-safe compiled) 'progn) (cdr compiled))
2083 (compiled (list compiled)))))
2084 (nconc (list 'lambda arglist)
2085 (if (or doc (stringp (car compiled)))
2086 (cons doc (cond (compiled)
2087 (body (list nil))))
2088 compiled))))))
2089
2090(defun byte-compile-constants-vector ()
2091 ;; Builds the constants-vector from the current variables and constants.
2092 ;; This modifies the constants from (const . nil) to (const . offset).
2093 ;; To keep the byte-codes to look up the vector as short as possible:
2094 ;; First 6 elements are vars, as there are one-byte varref codes for those.
2095 ;; Next up to byte-constant-limit are constants, still with one-byte codes.
2096 ;; Next variables again, to get 2-byte codes for variable lookup.
2097 ;; The rest of the constants and variables need 3-byte byte-codes.
2098 (let* ((i -1)
2099 (rest (nreverse byte-compile-variables)) ; nreverse because the first
2100 (other (nreverse byte-compile-constants)) ; vars often are used most.
2101 ret tmp
2102 (limits '(5 ; Use the 1-byte varref codes,
2103 63 ; 1-constlim ; 1-byte byte-constant codes,
2104 255 ; 2-byte varref codes,
2105 65535)) ; 3-byte codes for the rest.
2106 limit)
2107 (while (or rest other)
2108 (setq limit (car limits))
2109 (while (and rest (not (eq i limit)))
2110 (if (setq tmp (assq (car (car rest)) ret))
2111 (setcdr (car rest) (cdr tmp))
2112 (setcdr (car rest) (setq i (1+ i)))
2113 (setq ret (cons (car rest) ret)))
2114 (setq rest (cdr rest)))
2115 (setq limits (cdr limits)
2116 rest (prog1 other
2117 (setq other rest))))
2118 (apply 'vector (nreverse (mapcar 'car ret)))))
2119
2120;; Given an expression FORM, compile it and return an equivalent byte-code
2121;; expression (a call to the function byte-code).
2122(defun byte-compile-top-level (form &optional for-effect output-type)
2123 ;; OUTPUT-TYPE advises about how form is expected to be used:
2124 ;; 'eval or nil -> a single form,
2125 ;; 'progn or t -> a list of forms,
2126 ;; 'lambda -> body of a lambda,
2127 ;; 'file -> used at file-level.
285cdf4e
RS
2128 (let ((byte-compile-constants nil)
2129 (byte-compile-variables nil)
2130 (byte-compile-tag-number 0)
2131 (byte-compile-depth 0)
2132 (byte-compile-maxdepth 0)
2133 (byte-compile-output nil))
d9e42bcf
RS
2134 (if (memq byte-optimize '(t source))
2135 (setq form (byte-optimize-form form for-effect)))
2136 (while (and (eq (car-safe form) 'progn) (null (cdr (cdr form))))
2137 (setq form (nth 1 form)))
2138 (if (and (eq 'byte-code (car-safe form))
2139 (not (memq byte-optimize '(t byte)))
2140 (stringp (nth 1 form)) (vectorp (nth 2 form))
2141 (natnump (nth 3 form)))
2142 form
2143 (byte-compile-form form for-effect)
285cdf4e 2144 (byte-compile-out-toplevel for-effect output-type))))
1c393159
JB
2145
2146(defun byte-compile-out-toplevel (&optional for-effect output-type)
2147 (if for-effect
2148 ;; The stack is empty. Push a value to be returned from (byte-code ..).
2149 (if (eq (car (car byte-compile-output)) 'byte-discard)
2150 (setq byte-compile-output (cdr byte-compile-output))
2151 (byte-compile-push-constant
2152 ;; Push any constant - preferably one which already is used, and
2153 ;; a number or symbol - ie not some big sequence. The return value
2154 ;; isn't returned, but it would be a shame if some textually large
2155 ;; constant was not optimized away because we chose to return it.
2156 (and (not (assq nil byte-compile-constants)) ; Nil is often there.
2157 (let ((tmp (reverse byte-compile-constants)))
2158 (while (and tmp (not (or (symbolp (car (car tmp)))
2159 (numberp (car (car tmp))))))
2160 (setq tmp (cdr tmp)))
2161 (car (car tmp)))))))
2162 (byte-compile-out 'byte-return 0)
2163 (setq byte-compile-output (nreverse byte-compile-output))
2164 (if (memq byte-optimize '(t byte))
2165 (setq byte-compile-output
2166 (byte-optimize-lapcode byte-compile-output for-effect)))
2167
2168 ;; Decompile trivial functions:
2169 ;; only constants and variables, or a single funcall except in lambdas.
2170 ;; Except for Lisp_Compiled objects, forms like (foo "hi")
2171 ;; are still quicker than (byte-code "..." [foo "hi"] 2).
2172 ;; Note that even (quote foo) must be parsed just as any subr by the
2173 ;; interpreter, so quote should be compiled into byte-code in some contexts.
2174 ;; What to leave uncompiled:
69dc83fd
KH
2175 ;; lambda -> never. we used to leave it uncompiled if the body was
2176 ;; a single atom, but that causes confusion if the docstring
2177 ;; uses the (file . pos) syntax. Besides, now that we have
2178 ;; the Lisp_Compiled type, the compiled form is faster.
1c393159
JB
2179 ;; eval -> atom, quote or (function atom atom atom)
2180 ;; progn -> as <<same-as-eval>> or (progn <<same-as-eval>> atom)
2181 ;; file -> as progn, but takes both quotes and atoms, and longer forms.
2182 (let (rest
2183 (maycall (not (eq output-type 'lambda))) ; t if we may make a funcall.
2184 tmp body)
2185 (cond
2186 ;; #### This should be split out into byte-compile-nontrivial-function-p.
69dc83fd
KH
2187 ((or (eq output-type 'lambda)
2188 (nthcdr (if (eq output-type 'file) 50 8) byte-compile-output)
1c393159
JB
2189 (assq 'TAG byte-compile-output) ; Not necessary, but speeds up a bit.
2190 (not (setq tmp (assq 'byte-return byte-compile-output)))
2191 (progn
2192 (setq rest (nreverse
2193 (cdr (memq tmp (reverse byte-compile-output)))))
2194 (while (cond
2195 ((memq (car (car rest)) '(byte-varref byte-constant))
2196 (setq tmp (car (cdr (car rest))))
469414a0
RS
2197 (if (if (eq (car (car rest)) 'byte-constant)
2198 (or (consp tmp)
2199 (and (symbolp tmp)
2200 (not (memq tmp '(nil t))))))
2201 (if maycall
2202 (setq body (cons (list 'quote tmp) body)))
2203 (setq body (cons tmp body))))
1c393159
JB
2204 ((and maycall
2205 ;; Allow a funcall if at most one atom follows it.
2206 (null (nthcdr 3 rest))
2207 (setq tmp (get (car (car rest)) 'byte-opcode-invert))
2208 (or (null (cdr rest))
2209 (and (memq output-type '(file progn t))
2210 (cdr (cdr rest))
2211 (eq (car (nth 1 rest)) 'byte-discard)
2212 (progn (setq rest (cdr rest)) t))))
2213 (setq maycall nil) ; Only allow one real function call.
2214 (setq body (nreverse body))
2215 (setq body (list
2216 (if (and (eq tmp 'funcall)
2217 (eq (car-safe (car body)) 'quote))
2218 (cons (nth 1 (car body)) (cdr body))
2219 (cons tmp body))))
2220 (or (eq output-type 'file)
2221 (not (delq nil (mapcar 'consp (cdr (car body))))))))
2222 (setq rest (cdr rest)))
69dc83fd 2223 rest))
1c393159
JB
2224 (let ((byte-compile-vector (byte-compile-constants-vector)))
2225 (list 'byte-code (byte-compile-lapcode byte-compile-output)
2226 byte-compile-vector byte-compile-maxdepth)))
2227 ;; it's a trivial function
2228 ((cdr body) (cons 'progn (nreverse body)))
2229 ((car body)))))
2230
2231;; Given BODY, compile it and return a new body.
2232(defun byte-compile-top-level-body (body &optional for-effect)
2233 (setq body (byte-compile-top-level (cons 'progn body) for-effect t))
2234 (cond ((eq (car-safe body) 'progn)
2235 (cdr body))
2236 (body
2237 (list body))))
2238\f
2239;; This is the recursive entry point for compiling each subform of an
2240;; expression.
2241;; If for-effect is non-nil, byte-compile-form will output a byte-discard
2242;; before terminating (ie no value will be left on the stack).
2243;; A byte-compile handler may, when for-effect is non-nil, choose output code
2244;; which does not leave a value on the stack, and then set for-effect to nil
2245;; (to prevent byte-compile-form from outputting the byte-discard).
2246;; If a handler wants to call another handler, it should do so via
2247;; byte-compile-form, or take extreme care to handle for-effect correctly.
2248;; (Use byte-compile-form-do-effect to reset the for-effect flag too.)
2249;;
2250(defun byte-compile-form (form &optional for-effect)
2251 (setq form (macroexpand form byte-compile-macro-environment))
2252 (cond ((not (consp form))
2253 (cond ((or (not (symbolp form)) (memq form '(nil t)))
2254 (byte-compile-constant form))
2255 ((and for-effect byte-compile-delete-errors)
2256 (setq for-effect nil))
2257 (t (byte-compile-variable-ref 'byte-varref form))))
2258 ((symbolp (car form))
2259 (let* ((fn (car form))
2260 (handler (get fn 'byte-compile)))
9e2b097b
JB
2261 (if (memq fn '(t nil))
2262 (byte-compile-warn "%s called as a function" fn))
1c393159 2263 (if (and handler
e27c3564
JB
2264 (or (not (byte-compile-version-cond
2265 byte-compile-compatibility))
1c393159
JB
2266 (not (get (get fn 'byte-opcode) 'emacs19-opcode))))
2267 (funcall handler form)
2268 (if (memq 'callargs byte-compile-warnings)
2269 (byte-compile-callargs-warn form))
2270 (byte-compile-normal-call form))))
ed015bdd 2271 ((and (or (byte-code-function-p (car form))
1c393159
JB
2272 (eq (car-safe (car form)) 'lambda))
2273 ;; if the form comes out the same way it went in, that's
2274 ;; because it was malformed, and we couldn't unfold it.
2275 (not (eq form (setq form (byte-compile-unfold-lambda form)))))
2276 (byte-compile-form form for-effect)
2277 (setq for-effect nil))
2278 ((byte-compile-normal-call form)))
2279 (if for-effect
2280 (byte-compile-discard)))
2281
2282(defun byte-compile-normal-call (form)
2283 (if byte-compile-generate-call-tree
2284 (byte-compile-annotate-call-tree form))
2285 (byte-compile-push-constant (car form))
2286 (mapcar 'byte-compile-form (cdr form)) ; wasteful, but faster.
2287 (byte-compile-out 'byte-call (length (cdr form))))
2288
2289(defun byte-compile-variable-ref (base-op var)
2290 (if (or (not (symbolp var)) (memq var '(nil t)))
2291 (byte-compile-warn (if (eq base-op 'byte-varbind)
2292 "Attempt to let-bind %s %s"
2293 "Variable reference to %s %s")
2294 (if (symbolp var) "constant" "nonvariable")
2295 (prin1-to-string var))
9290191f
RS
2296 (if (and (get var 'byte-obsolete-variable)
2297 (memq 'obsolete byte-compile-warnings))
9e2b097b
JB
2298 (let ((ob (get var 'byte-obsolete-variable)))
2299 (byte-compile-warn "%s is an obsolete variable; %s" var
2300 (if (stringp ob)
2301 ob
2302 (format "use %s instead." ob)))))
1c393159
JB
2303 (if (memq 'free-vars byte-compile-warnings)
2304 (if (eq base-op 'byte-varbind)
2305 (setq byte-compile-bound-variables
2306 (cons var byte-compile-bound-variables))
2307 (or (boundp var)
2308 (memq var byte-compile-bound-variables)
2309 (if (eq base-op 'byte-varset)
2310 (or (memq var byte-compile-free-assignments)
2311 (progn
2312 (byte-compile-warn "assignment to free variable %s" var)
2313 (setq byte-compile-free-assignments
2314 (cons var byte-compile-free-assignments))))
2315 (or (memq var byte-compile-free-references)
2316 (progn
2317 (byte-compile-warn "reference to free variable %s" var)
2318 (setq byte-compile-free-references
2319 (cons var byte-compile-free-references)))))))))
2320 (let ((tmp (assq var byte-compile-variables)))
2321 (or tmp
2322 (setq tmp (list var)
2323 byte-compile-variables (cons tmp byte-compile-variables)))
2324 (byte-compile-out base-op tmp)))
2325
2326(defmacro byte-compile-get-constant (const)
2327 (` (or (if (stringp (, const))
2328 (assoc (, const) byte-compile-constants)
2329 (assq (, const) byte-compile-constants))
2330 (car (setq byte-compile-constants
2331 (cons (list (, const)) byte-compile-constants))))))
2332
2333;; Use this when the value of a form is a constant. This obeys for-effect.
2334(defun byte-compile-constant (const)
2335 (if for-effect
2336 (setq for-effect nil)
2337 (byte-compile-out 'byte-constant (byte-compile-get-constant const))))
2338
2339;; Use this for a constant that is not the value of its containing form.
2340;; This ignores for-effect.
2341(defun byte-compile-push-constant (const)
2342 (let ((for-effect nil))
2343 (inline (byte-compile-constant const))))
2344
2345\f
2346;; Compile those primitive ordinary functions
2347;; which have special byte codes just for speed.
2348
2349(defmacro byte-defop-compiler (function &optional compile-handler)
2350 ;; add a compiler-form for FUNCTION.
2351 ;; If function is a symbol, then the variable "byte-SYMBOL" must name
2352 ;; the opcode to be used. If function is a list, the first element
2353 ;; is the function and the second element is the bytecode-symbol.
2354 ;; COMPILE-HANDLER is the function to use to compile this byte-op, or
2355 ;; may be the abbreviations 0, 1, 2, 3, 0-1, or 1-2.
2356 ;; If it is nil, then the handler is "byte-compile-SYMBOL."
2357 (let (opcode)
2358 (if (symbolp function)
2359 (setq opcode (intern (concat "byte-" (symbol-name function))))
2360 (setq opcode (car (cdr function))
2361 function (car function)))
2362 (let ((fnform
2363 (list 'put (list 'quote function) ''byte-compile
2364 (list 'quote
2365 (or (cdr (assq compile-handler
2366 '((0 . byte-compile-no-args)
2367 (1 . byte-compile-one-arg)
2368 (2 . byte-compile-two-args)
2369 (3 . byte-compile-three-args)
2370 (0-1 . byte-compile-zero-or-one-arg)
2371 (1-2 . byte-compile-one-or-two-args)
2372 (2-3 . byte-compile-two-or-three-args)
2373 )))
2374 compile-handler
2375 (intern (concat "byte-compile-"
2376 (symbol-name function))))))))
2377 (if opcode
2378 (list 'progn fnform
2379 (list 'put (list 'quote function)
2380 ''byte-opcode (list 'quote opcode))
2381 (list 'put (list 'quote opcode)
2382 ''byte-opcode-invert (list 'quote function)))
2383 fnform))))
2384
2385(defmacro byte-defop-compiler19 (function &optional compile-handler)
2386 ;; Just like byte-defop-compiler, but defines an opcode that will only
e27c3564 2387 ;; be used when byte-compile-compatibility is false.
1c393159 2388 (if (and (byte-compile-single-version)
e27c3564 2389 byte-compile-compatibility)
9e2b097b
JB
2390 ;; #### instead of doing nothing, this should do some remprops,
2391 ;; #### to protect against the case where a single-version compiler
2392 ;; #### is loaded into a world that has contained a multi-version one.
1c393159
JB
2393 nil
2394 (list 'progn
2395 (list 'put
2396 (list 'quote
2397 (or (car (cdr-safe function))
2398 (intern (concat "byte-"
2399 (symbol-name (or (car-safe function) function))))))
2400 ''emacs19-opcode t)
2401 (list 'byte-defop-compiler function compile-handler))))
2402
2403(defmacro byte-defop-compiler-1 (function &optional compile-handler)
2404 (list 'byte-defop-compiler (list function nil) compile-handler))
2405
2406\f
2407(put 'byte-call 'byte-opcode-invert 'funcall)
2408(put 'byte-list1 'byte-opcode-invert 'list)
2409(put 'byte-list2 'byte-opcode-invert 'list)
2410(put 'byte-list3 'byte-opcode-invert 'list)
2411(put 'byte-list4 'byte-opcode-invert 'list)
2412(put 'byte-listN 'byte-opcode-invert 'list)
2413(put 'byte-concat2 'byte-opcode-invert 'concat)
2414(put 'byte-concat3 'byte-opcode-invert 'concat)
2415(put 'byte-concat4 'byte-opcode-invert 'concat)
2416(put 'byte-concatN 'byte-opcode-invert 'concat)
2417(put 'byte-insertN 'byte-opcode-invert 'insert)
2418
2419(byte-defop-compiler (dot byte-point) 0)
2420(byte-defop-compiler (dot-max byte-point-max) 0)
2421(byte-defop-compiler (dot-min byte-point-min) 0)
2422(byte-defop-compiler point 0)
2423;;(byte-defop-compiler mark 0) ;; obsolete
2424(byte-defop-compiler point-max 0)
2425(byte-defop-compiler point-min 0)
2426(byte-defop-compiler following-char 0)
2427(byte-defop-compiler preceding-char 0)
2428(byte-defop-compiler current-column 0)
2429(byte-defop-compiler eolp 0)
2430(byte-defop-compiler eobp 0)
2431(byte-defop-compiler bolp 0)
2432(byte-defop-compiler bobp 0)
2433(byte-defop-compiler current-buffer 0)
2434;;(byte-defop-compiler read-char 0) ;; obsolete
2435(byte-defop-compiler interactive-p 0)
2436(byte-defop-compiler19 widen 0)
2437(byte-defop-compiler19 end-of-line 0-1)
2438(byte-defop-compiler19 forward-char 0-1)
2439(byte-defop-compiler19 forward-line 0-1)
2440(byte-defop-compiler symbolp 1)
2441(byte-defop-compiler consp 1)
2442(byte-defop-compiler stringp 1)
2443(byte-defop-compiler listp 1)
2444(byte-defop-compiler not 1)
2445(byte-defop-compiler (null byte-not) 1)
2446(byte-defop-compiler car 1)
2447(byte-defop-compiler cdr 1)
2448(byte-defop-compiler length 1)
2449(byte-defop-compiler symbol-value 1)
2450(byte-defop-compiler symbol-function 1)
2451(byte-defop-compiler (1+ byte-add1) 1)
2452(byte-defop-compiler (1- byte-sub1) 1)
2453(byte-defop-compiler goto-char 1)
b8ae93ad 2454(byte-defop-compiler char-after 0-1)
1c393159
JB
2455(byte-defop-compiler set-buffer 1)
2456;;(byte-defop-compiler set-mark 1) ;; obsolete
2457(byte-defop-compiler19 forward-word 1)
2458(byte-defop-compiler19 char-syntax 1)
2459(byte-defop-compiler19 nreverse 1)
2460(byte-defop-compiler19 car-safe 1)
2461(byte-defop-compiler19 cdr-safe 1)
2462(byte-defop-compiler19 numberp 1)
2463(byte-defop-compiler19 integerp 1)
2464(byte-defop-compiler19 skip-chars-forward 1-2)
2465(byte-defop-compiler19 skip-chars-backward 1-2)
1c393159
JB
2466(byte-defop-compiler eq 2)
2467(byte-defop-compiler memq 2)
2468(byte-defop-compiler cons 2)
2469(byte-defop-compiler aref 2)
2470(byte-defop-compiler set 2)
2471(byte-defop-compiler (= byte-eqlsign) 2)
2472(byte-defop-compiler (< byte-lss) 2)
2473(byte-defop-compiler (> byte-gtr) 2)
2474(byte-defop-compiler (<= byte-leq) 2)
2475(byte-defop-compiler (>= byte-geq) 2)
2476(byte-defop-compiler get 2)
2477(byte-defop-compiler nth 2)
2478(byte-defop-compiler substring 2-3)
9e2b097b 2479(byte-defop-compiler19 (move-marker byte-set-marker) 2-3)
1c393159
JB
2480(byte-defop-compiler19 set-marker 2-3)
2481(byte-defop-compiler19 match-beginning 1)
2482(byte-defop-compiler19 match-end 1)
2483(byte-defop-compiler19 upcase 1)
2484(byte-defop-compiler19 downcase 1)
2485(byte-defop-compiler19 string= 2)
2486(byte-defop-compiler19 string< 2)
9e2b097b
JB
2487(byte-defop-compiler19 (string-equal byte-string=) 2)
2488(byte-defop-compiler19 (string-lessp byte-string<) 2)
1c393159
JB
2489(byte-defop-compiler19 equal 2)
2490(byte-defop-compiler19 nthcdr 2)
2491(byte-defop-compiler19 elt 2)
2492(byte-defop-compiler19 member 2)
2493(byte-defop-compiler19 assq 2)
9e2b097b
JB
2494(byte-defop-compiler19 (rplaca byte-setcar) 2)
2495(byte-defop-compiler19 (rplacd byte-setcdr) 2)
1c393159
JB
2496(byte-defop-compiler19 setcar 2)
2497(byte-defop-compiler19 setcdr 2)
2498(byte-defop-compiler19 buffer-substring 2)
2499(byte-defop-compiler19 delete-region 2)
2500(byte-defop-compiler19 narrow-to-region 2)
1c393159
JB
2501(byte-defop-compiler19 (% byte-rem) 2)
2502(byte-defop-compiler aset 3)
2503
2504(byte-defop-compiler max byte-compile-associative)
2505(byte-defop-compiler min byte-compile-associative)
2506(byte-defop-compiler (+ byte-plus) byte-compile-associative)
2507(byte-defop-compiler19 (* byte-mult) byte-compile-associative)
2508
2509;;####(byte-defop-compiler19 move-to-column 1)
2510(byte-defop-compiler-1 interactive byte-compile-noop)
2511
2512\f
2513(defun byte-compile-subr-wrong-args (form n)
2514 (byte-compile-warn "%s called with %d arg%s, but requires %s"
2515 (car form) (length (cdr form))
2516 (if (= 1 (length (cdr form))) "" "s") n)
2517 ;; get run-time wrong-number-of-args error.
2518 (byte-compile-normal-call form))
2519
2520(defun byte-compile-no-args (form)
2521 (if (not (= (length form) 1))
2522 (byte-compile-subr-wrong-args form "none")
2523 (byte-compile-out (get (car form) 'byte-opcode) 0)))
2524
2525(defun byte-compile-one-arg (form)
2526 (if (not (= (length form) 2))
2527 (byte-compile-subr-wrong-args form 1)
2528 (byte-compile-form (car (cdr form))) ;; Push the argument
2529 (byte-compile-out (get (car form) 'byte-opcode) 0)))
2530
2531(defun byte-compile-two-args (form)
2532 (if (not (= (length form) 3))
2533 (byte-compile-subr-wrong-args form 2)
2534 (byte-compile-form (car (cdr form))) ;; Push the arguments
2535 (byte-compile-form (nth 2 form))
2536 (byte-compile-out (get (car form) 'byte-opcode) 0)))
2537
2538(defun byte-compile-three-args (form)
2539 (if (not (= (length form) 4))
2540 (byte-compile-subr-wrong-args form 3)
2541 (byte-compile-form (car (cdr form))) ;; Push the arguments
2542 (byte-compile-form (nth 2 form))
2543 (byte-compile-form (nth 3 form))
2544 (byte-compile-out (get (car form) 'byte-opcode) 0)))
2545
2546(defun byte-compile-zero-or-one-arg (form)
2547 (let ((len (length form)))
2548 (cond ((= len 1) (byte-compile-one-arg (append form '(nil))))
2549 ((= len 2) (byte-compile-one-arg form))
2550 (t (byte-compile-subr-wrong-args form "0-1")))))
2551
2552(defun byte-compile-one-or-two-args (form)
2553 (let ((len (length form)))
2554 (cond ((= len 2) (byte-compile-two-args (append form '(nil))))
2555 ((= len 3) (byte-compile-two-args form))
2556 (t (byte-compile-subr-wrong-args form "1-2")))))
2557
2558(defun byte-compile-two-or-three-args (form)
2559 (let ((len (length form)))
2560 (cond ((= len 3) (byte-compile-three-args (append form '(nil))))
2561 ((= len 4) (byte-compile-three-args form))
2562 (t (byte-compile-subr-wrong-args form "2-3")))))
2563
2564(defun byte-compile-noop (form)
2565 (byte-compile-constant nil))
2566
2567(defun byte-compile-discard ()
2568 (byte-compile-out 'byte-discard 0))
2569
2570
2571;; Compile a function that accepts one or more args and is right-associative.
c0f43df5
RS
2572;; We do it by left-associativity so that the operations
2573;; are done in the same order as in interpreted code.
10809e0f
RS
2574;; We treat the one-arg case, as in (+ x), like (+ x 0).
2575;; in order to convert markers to numbers, and trigger expected errors.
1c393159
JB
2576(defun byte-compile-associative (form)
2577 (if (cdr form)
c0f43df5
RS
2578 (let ((opcode (get (car form) 'byte-opcode))
2579 (args (copy-sequence (cdr form))))
2580 (byte-compile-form (car args))
2581 (setq args (cdr args))
10809e0f
RS
2582 (or args (setq args '(0)
2583 opcode (get '+ 'byte-opcode)))
c0f43df5
RS
2584 (while args
2585 (byte-compile-form (car args))
2586 (byte-compile-out opcode 0)
2587 (setq args (cdr args))))
1c393159
JB
2588 (byte-compile-constant (eval form))))
2589
2590\f
2591;; more complicated compiler macros
2592
2593(byte-defop-compiler list)
2594(byte-defop-compiler concat)
2595(byte-defop-compiler fset)
2596(byte-defop-compiler (indent-to-column byte-indent-to) byte-compile-indent-to)
2597(byte-defop-compiler indent-to)
2598(byte-defop-compiler insert)
2599(byte-defop-compiler-1 function byte-compile-function-form)
2600(byte-defop-compiler-1 - byte-compile-minus)
2601(byte-defop-compiler19 (/ byte-quo) byte-compile-quo)
2602(byte-defop-compiler19 nconc)
2603(byte-defop-compiler-1 beginning-of-line)
2604
2605(defun byte-compile-list (form)
2606 (let ((count (length (cdr form))))
2607 (cond ((= count 0)
2608 (byte-compile-constant nil))
2609 ((< count 5)
2610 (mapcar 'byte-compile-form (cdr form))
2611 (byte-compile-out
2612 (aref [byte-list1 byte-list2 byte-list3 byte-list4] (1- count)) 0))
e27c3564
JB
2613 ((and (< count 256) (not (byte-compile-version-cond
2614 byte-compile-compatibility)))
1c393159
JB
2615 (mapcar 'byte-compile-form (cdr form))
2616 (byte-compile-out 'byte-listN count))
2617 (t (byte-compile-normal-call form)))))
2618
2619(defun byte-compile-concat (form)
2620 (let ((count (length (cdr form))))
2621 (cond ((and (< 1 count) (< count 5))
2622 (mapcar 'byte-compile-form (cdr form))
2623 (byte-compile-out
2624 (aref [byte-concat2 byte-concat3 byte-concat4] (- count 2))
2625 0))
2626 ;; Concat of one arg is not a no-op if arg is not a string.
2627 ((= count 0)
2628 (byte-compile-form ""))
e27c3564
JB
2629 ((and (< count 256) (not (byte-compile-version-cond
2630 byte-compile-compatibility)))
1c393159
JB
2631 (mapcar 'byte-compile-form (cdr form))
2632 (byte-compile-out 'byte-concatN count))
2633 ((byte-compile-normal-call form)))))
2634
2635(defun byte-compile-minus (form)
2636 (if (null (setq form (cdr form)))
2637 (byte-compile-constant 0)
2638 (byte-compile-form (car form))
2639 (if (cdr form)
2640 (while (setq form (cdr form))
2641 (byte-compile-form (car form))
2642 (byte-compile-out 'byte-diff 0))
2643 (byte-compile-out 'byte-negate 0))))
2644
2645(defun byte-compile-quo (form)
2646 (let ((len (length form)))
2647 (cond ((<= len 2)
2648 (byte-compile-subr-wrong-args form "2 or more"))
2649 (t
2650 (byte-compile-form (car (setq form (cdr form))))
2651 (while (setq form (cdr form))
2652 (byte-compile-form (car form))
2653 (byte-compile-out 'byte-quo 0))))))
2654
2655(defun byte-compile-nconc (form)
2656 (let ((len (length form)))
2657 (cond ((= len 1)
2658 (byte-compile-constant nil))
2659 ((= len 2)
2660 ;; nconc of one arg is a noop, even if that arg isn't a list.
2661 (byte-compile-form (nth 1 form)))
2662 (t
2663 (byte-compile-form (car (setq form (cdr form))))
2664 (while (setq form (cdr form))
2665 (byte-compile-form (car form))
2666 (byte-compile-out 'byte-nconc 0))))))
2667
2668(defun byte-compile-fset (form)
2669 ;; warn about forms like (fset 'foo '(lambda () ...))
2670 ;; (where the lambda expression is non-trivial...)
2671 (let ((fn (nth 2 form))
2672 body)
2673 (if (and (eq (car-safe fn) 'quote)
2674 (eq (car-safe (setq fn (nth 1 fn))) 'lambda))
2675 (progn
2676 (setq body (cdr (cdr fn)))
2677 (if (stringp (car body)) (setq body (cdr body)))
2678 (if (eq 'interactive (car-safe (car body))) (setq body (cdr body)))
2679 (if (and (consp (car body))
2680 (not (eq 'byte-code (car (car body)))))
2681 (byte-compile-warn
2682 "A quoted lambda form is the second argument of fset. This is probably
2683 not what you want, as that lambda cannot be compiled. Consider using
2684 the syntax (function (lambda (...) ...)) instead.")))))
2685 (byte-compile-two-args form))
2686
2687(defun byte-compile-funarg (form)
2688 ;; (mapcar '(lambda (x) ..) ..) ==> (mapcar (function (lambda (x) ..)) ..)
eb8c3be9 2689 ;; for cases where it's guaranteed that first arg will be used as a lambda.
1c393159
JB
2690 (byte-compile-normal-call
2691 (let ((fn (nth 1 form)))
2692 (if (and (eq (car-safe fn) 'quote)
2693 (eq (car-safe (nth 1 fn)) 'lambda))
2694 (cons (car form)
2695 (cons (cons 'function (cdr fn))
2696 (cdr (cdr form))))
2697 form))))
2698
5a6037bb
RS
2699(defun byte-compile-funarg-2 (form)
2700 ;; (sort ... '(lambda (x) ..)) ==> (sort ... (function (lambda (x) ..)))
2701 ;; for cases where it's guaranteed that second arg will be used as a lambda.
2702 (byte-compile-normal-call
2703 (let ((fn (nth 2 form)))
2704 (if (and (eq (car-safe fn) 'quote)
2705 (eq (car-safe (nth 1 fn)) 'lambda))
2706 (cons (car form)
2707 (cons (nth 1 form)
2708 (cons (cons 'function (cdr fn))
2709 (cdr (cdr (cdr form))))))
2710 form))))
2711
1c393159
JB
2712;; (function foo) must compile like 'foo, not like (symbol-function 'foo).
2713;; Otherwise it will be incompatible with the interpreter,
2714;; and (funcall (function foo)) will lose with autoloads.
2715
2716(defun byte-compile-function-form (form)
2717 (byte-compile-constant
2718 (cond ((symbolp (nth 1 form))
2719 (nth 1 form))
2720 ;; If we're not allowed to use #[] syntax, then output a form like
2721 ;; '(lambda (..) (byte-code ..)) instead of a call to make-byte-code.
2722 ;; In this situation, calling make-byte-code at run-time will usually
2723 ;; be less efficient than processing a call to byte-code.
52799cb8 2724 ((byte-compile-version-cond byte-compile-compatibility)
1c393159
JB
2725 (byte-compile-byte-code-unmake (byte-compile-lambda (nth 1 form))))
2726 ((byte-compile-lambda (nth 1 form))))))
2727
2728(defun byte-compile-indent-to (form)
2729 (let ((len (length form)))
2730 (cond ((= len 2)
2731 (byte-compile-form (car (cdr form)))
2732 (byte-compile-out 'byte-indent-to 0))
2733 ((= len 3)
2734 ;; no opcode for 2-arg case.
2735 (byte-compile-normal-call form))
2736 (t
2737 (byte-compile-subr-wrong-args form "1-2")))))
2738
2739(defun byte-compile-insert (form)
2740 (cond ((null (cdr form))
2741 (byte-compile-constant nil))
e27c3564
JB
2742 ((and (not (byte-compile-version-cond
2743 byte-compile-compatibility))
1c393159
JB
2744 (<= (length form) 256))
2745 (mapcar 'byte-compile-form (cdr form))
2746 (if (cdr (cdr form))
2747 (byte-compile-out 'byte-insertN (length (cdr form)))
2748 (byte-compile-out 'byte-insert 0)))
2749 ((memq t (mapcar 'consp (cdr (cdr form))))
2750 (byte-compile-normal-call form))
2751 ;; We can split it; there is no function call after inserting 1st arg.
2752 (t
2753 (while (setq form (cdr form))
2754 (byte-compile-form (car form))
2755 (byte-compile-out 'byte-insert 0)
2756 (if (cdr form)
2757 (byte-compile-discard))))))
2758
2759(defun byte-compile-beginning-of-line (form)
2760 (if (not (byte-compile-constp (nth 1 form)))
2761 (byte-compile-normal-call form)
2762 (byte-compile-form
2763 (list 'forward-line
2764 (if (integerp (setq form (or (eval (nth 1 form)) 1)))
2765 (1- form)
2766 (byte-compile-warn "Non-numeric arg to beginning-of-line: %s"
2767 form)
2768 (list '1- (list 'quote form))))
2769 t)
2770 (byte-compile-constant nil)))
2771
2772\f
2773(byte-defop-compiler-1 setq)
2774(byte-defop-compiler-1 setq-default)
2775(byte-defop-compiler-1 quote)
2776(byte-defop-compiler-1 quote-form)
2777
2778(defun byte-compile-setq (form)
2779 (let ((args (cdr form)))
2780 (if args
2781 (while args
2782 (byte-compile-form (car (cdr args)))
2783 (or for-effect (cdr (cdr args))
2784 (byte-compile-out 'byte-dup 0))
2785 (byte-compile-variable-ref 'byte-varset (car args))
2786 (setq args (cdr (cdr args))))
2787 ;; (setq), with no arguments.
2788 (byte-compile-form nil for-effect))
2789 (setq for-effect nil)))
2790
2791(defun byte-compile-setq-default (form)
ca38179a
RS
2792 (let ((args (cdr form))
2793 setters)
2794 (while args
2795 (setq setters
2796 (cons (list 'set-default (list 'quote (car args)) (car (cdr args)))
2797 setters))
2798 (setq args (cdr (cdr args))))
2799 (byte-compile-form (cons 'progn (nreverse setters)))))
1c393159
JB
2800
2801(defun byte-compile-quote (form)
2802 (byte-compile-constant (car (cdr form))))
2803
2804(defun byte-compile-quote-form (form)
2805 (byte-compile-constant (byte-compile-top-level (nth 1 form))))
2806
2807\f
2808;;; control structures
2809
2810(defun byte-compile-body (body &optional for-effect)
2811 (while (cdr body)
2812 (byte-compile-form (car body) t)
2813 (setq body (cdr body)))
2814 (byte-compile-form (car body) for-effect))
2815
52799cb8 2816(defsubst byte-compile-body-do-effect (body)
1c393159
JB
2817 (byte-compile-body body for-effect)
2818 (setq for-effect nil))
2819
52799cb8 2820(defsubst byte-compile-form-do-effect (form)
1c393159
JB
2821 (byte-compile-form form for-effect)
2822 (setq for-effect nil))
2823
2824(byte-defop-compiler-1 inline byte-compile-progn)
2825(byte-defop-compiler-1 progn)
2826(byte-defop-compiler-1 prog1)
2827(byte-defop-compiler-1 prog2)
2828(byte-defop-compiler-1 if)
2829(byte-defop-compiler-1 cond)
2830(byte-defop-compiler-1 and)
2831(byte-defop-compiler-1 or)
2832(byte-defop-compiler-1 while)
2833(byte-defop-compiler-1 funcall)
2834(byte-defop-compiler-1 apply byte-compile-funarg)
2835(byte-defop-compiler-1 mapcar byte-compile-funarg)
2836(byte-defop-compiler-1 mapatoms byte-compile-funarg)
2837(byte-defop-compiler-1 mapconcat byte-compile-funarg)
5a6037bb 2838(byte-defop-compiler-1 sort byte-compile-funarg-2)
1c393159
JB
2839(byte-defop-compiler-1 let)
2840(byte-defop-compiler-1 let*)
2841
2842(defun byte-compile-progn (form)
2843 (byte-compile-body-do-effect (cdr form)))
2844
2845(defun byte-compile-prog1 (form)
2846 (byte-compile-form-do-effect (car (cdr form)))
2847 (byte-compile-body (cdr (cdr form)) t))
2848
2849(defun byte-compile-prog2 (form)
2850 (byte-compile-form (nth 1 form) t)
2851 (byte-compile-form-do-effect (nth 2 form))
2852 (byte-compile-body (cdr (cdr (cdr form))) t))
2853
2854(defmacro byte-compile-goto-if (cond discard tag)
2855 (` (byte-compile-goto
2856 (if (, cond)
2857 (if (, discard) 'byte-goto-if-not-nil 'byte-goto-if-not-nil-else-pop)
2858 (if (, discard) 'byte-goto-if-nil 'byte-goto-if-nil-else-pop))
2859 (, tag))))
2860
2861(defun byte-compile-if (form)
2862 (byte-compile-form (car (cdr form)))
2863 (if (null (nthcdr 3 form))
2864 ;; No else-forms
2865 (let ((donetag (byte-compile-make-tag)))
2866 (byte-compile-goto-if nil for-effect donetag)
2867 (byte-compile-form (nth 2 form) for-effect)
2868 (byte-compile-out-tag donetag))
2869 (let ((donetag (byte-compile-make-tag)) (elsetag (byte-compile-make-tag)))
2870 (byte-compile-goto 'byte-goto-if-nil elsetag)
2871 (byte-compile-form (nth 2 form) for-effect)
2872 (byte-compile-goto 'byte-goto donetag)
2873 (byte-compile-out-tag elsetag)
2874 (byte-compile-body (cdr (cdr (cdr form))) for-effect)
2875 (byte-compile-out-tag donetag)))
2876 (setq for-effect nil))
2877
2878(defun byte-compile-cond (clauses)
2879 (let ((donetag (byte-compile-make-tag))
2880 nexttag clause)
2881 (while (setq clauses (cdr clauses))
2882 (setq clause (car clauses))
2883 (cond ((or (eq (car clause) t)
2884 (and (eq (car-safe (car clause)) 'quote)
2885 (car-safe (cdr-safe (car clause)))))
2886 ;; Unconditional clause
2887 (setq clause (cons t clause)
2888 clauses nil))
2889 ((cdr clauses)
2890 (byte-compile-form (car clause))
2891 (if (null (cdr clause))
2892 ;; First clause is a singleton.
2893 (byte-compile-goto-if t for-effect donetag)
2894 (setq nexttag (byte-compile-make-tag))
2895 (byte-compile-goto 'byte-goto-if-nil nexttag)
2896 (byte-compile-body (cdr clause) for-effect)
2897 (byte-compile-goto 'byte-goto donetag)
2898 (byte-compile-out-tag nexttag)))))
2899 ;; Last clause
2900 (and (cdr clause) (not (eq (car clause) t))
2901 (progn (byte-compile-form (car clause))
2902 (byte-compile-goto-if nil for-effect donetag)
2903 (setq clause (cdr clause))))
2904 (byte-compile-body-do-effect clause)
2905 (byte-compile-out-tag donetag)))
2906
2907(defun byte-compile-and (form)
2908 (let ((failtag (byte-compile-make-tag))
2909 (args (cdr form)))
2910 (if (null args)
2911 (byte-compile-form-do-effect t)
2912 (while (cdr args)
2913 (byte-compile-form (car args))
2914 (byte-compile-goto-if nil for-effect failtag)
2915 (setq args (cdr args)))
2916 (byte-compile-form-do-effect (car args))
2917 (byte-compile-out-tag failtag))))
2918
2919(defun byte-compile-or (form)
2920 (let ((wintag (byte-compile-make-tag))
2921 (args (cdr form)))
2922 (if (null args)
2923 (byte-compile-form-do-effect nil)
2924 (while (cdr args)
2925 (byte-compile-form (car args))
2926 (byte-compile-goto-if t for-effect wintag)
2927 (setq args (cdr args)))
2928 (byte-compile-form-do-effect (car args))
2929 (byte-compile-out-tag wintag))))
2930
2931(defun byte-compile-while (form)
2932 (let ((endtag (byte-compile-make-tag))
2933 (looptag (byte-compile-make-tag)))
2934 (byte-compile-out-tag looptag)
2935 (byte-compile-form (car (cdr form)))
2936 (byte-compile-goto-if nil for-effect endtag)
2937 (byte-compile-body (cdr (cdr form)) t)
2938 (byte-compile-goto 'byte-goto looptag)
2939 (byte-compile-out-tag endtag)
2940 (setq for-effect nil)))
2941
2942(defun byte-compile-funcall (form)
2943 (mapcar 'byte-compile-form (cdr form))
2944 (byte-compile-out 'byte-call (length (cdr (cdr form)))))
2945
2946
2947(defun byte-compile-let (form)
2948 ;; First compute the binding values in the old scope.
2949 (let ((varlist (car (cdr form))))
2950 (while varlist
2951 (if (consp (car varlist))
2952 (byte-compile-form (car (cdr (car varlist))))
2953 (byte-compile-push-constant nil))
2954 (setq varlist (cdr varlist))))
2955 (let ((byte-compile-bound-variables byte-compile-bound-variables) ;new scope
2956 (varlist (reverse (car (cdr form)))))
2957 (while varlist
2958 (byte-compile-variable-ref 'byte-varbind (if (consp (car varlist))
2959 (car (car varlist))
2960 (car varlist)))
2961 (setq varlist (cdr varlist)))
2962 (byte-compile-body-do-effect (cdr (cdr form)))
2963 (byte-compile-out 'byte-unbind (length (car (cdr form))))))
2964
2965(defun byte-compile-let* (form)
2966 (let ((byte-compile-bound-variables byte-compile-bound-variables) ;new scope
2967 (varlist (copy-sequence (car (cdr form)))))
2968 (while varlist
2969 (if (atom (car varlist))
2970 (byte-compile-push-constant nil)
2971 (byte-compile-form (car (cdr (car varlist))))
2972 (setcar varlist (car (car varlist))))
2973 (byte-compile-variable-ref 'byte-varbind (car varlist))
2974 (setq varlist (cdr varlist)))
2975 (byte-compile-body-do-effect (cdr (cdr form)))
2976 (byte-compile-out 'byte-unbind (length (car (cdr form))))))
2977
2978
2979(byte-defop-compiler-1 /= byte-compile-negated)
2980(byte-defop-compiler-1 atom byte-compile-negated)
2981(byte-defop-compiler-1 nlistp byte-compile-negated)
2982
2983(put '/= 'byte-compile-negated-op '=)
2984(put 'atom 'byte-compile-negated-op 'consp)
2985(put 'nlistp 'byte-compile-negated-op 'listp)
2986
2987(defun byte-compile-negated (form)
2988 (byte-compile-form-do-effect (byte-compile-negation-optimizer form)))
2989
2990;; Even when optimization is off, /= is optimized to (not (= ...)).
2991(defun byte-compile-negation-optimizer (form)
2992 ;; an optimizer for forms where <form1> is less efficient than (not <form2>)
2993 (list 'not
2994 (cons (or (get (car form) 'byte-compile-negated-op)
2995 (error
52799cb8 2996 "Compiler error: `%s' has no `byte-compile-negated-op' property"
1c393159
JB
2997 (car form)))
2998 (cdr form))))
2999\f
3000;;; other tricky macro-like special-forms
3001
3002(byte-defop-compiler-1 catch)
3003(byte-defop-compiler-1 unwind-protect)
3004(byte-defop-compiler-1 condition-case)
3005(byte-defop-compiler-1 save-excursion)
f3e472b0 3006(byte-defop-compiler-1 save-current-buffer)
1c393159
JB
3007(byte-defop-compiler-1 save-restriction)
3008(byte-defop-compiler-1 save-window-excursion)
3009(byte-defop-compiler-1 with-output-to-temp-buffer)
6e8d0db7 3010(byte-defop-compiler-1 track-mouse)
1c393159
JB
3011
3012(defun byte-compile-catch (form)
3013 (byte-compile-form (car (cdr form)))
3014 (byte-compile-push-constant
3015 (byte-compile-top-level (cons 'progn (cdr (cdr form))) for-effect))
3016 (byte-compile-out 'byte-catch 0))
3017
3018(defun byte-compile-unwind-protect (form)
3019 (byte-compile-push-constant
3020 (byte-compile-top-level-body (cdr (cdr form)) t))
3021 (byte-compile-out 'byte-unwind-protect 0)
3022 (byte-compile-form-do-effect (car (cdr form)))
3023 (byte-compile-out 'byte-unbind 1))
3024
6e8d0db7 3025(defun byte-compile-track-mouse (form)
d7846e08
RS
3026 (byte-compile-form
3027 (list
3028 'funcall
3029 (list 'quote
3030 (list 'lambda nil
3031 (cons 'track-mouse
3032 (byte-compile-top-level-body (cdr form))))))))
6e8d0db7 3033
1c393159
JB
3034(defun byte-compile-condition-case (form)
3035 (let* ((var (nth 1 form))
3036 (byte-compile-bound-variables
3037 (if var (cons var byte-compile-bound-variables)
3038 byte-compile-bound-variables)))
3039 (or (symbolp var)
3040 (byte-compile-warn
3041 "%s is not a variable-name or nil (in condition-case)" var))
3042 (byte-compile-push-constant var)
3043 (byte-compile-push-constant (byte-compile-top-level
3044 (nth 2 form) for-effect))
3045 (let ((clauses (cdr (cdr (cdr form))))
3046 compiled-clauses)
3047 (while clauses
e27c3564
JB
3048 (let* ((clause (car clauses))
3049 (condition (car clause)))
2abcddce
RS
3050 (cond ((not (or (symbolp condition)
3051 (and (listp condition)
3052 (let ((syms condition) (ok t))
3053 (while syms
3054 (if (not (symbolp (car syms)))
3055 (setq ok nil))
3056 (setq syms (cdr syms)))
3057 ok))))
e27c3564 3058 (byte-compile-warn
2abcddce 3059 "%s is not a condition name or list of such (in condition-case)"
e27c3564 3060 (prin1-to-string condition)))
2abcddce
RS
3061;; ((not (or (eq condition 't)
3062;; (and (stringp (get condition 'error-message))
3063;; (consp (get condition 'error-conditions)))))
3064;; (byte-compile-warn
3065;; "%s is not a known condition name (in condition-case)"
3066;; condition))
3067 )
1c393159 3068 (setq compiled-clauses
e27c3564 3069 (cons (cons condition
1c393159
JB
3070 (byte-compile-top-level-body
3071 (cdr clause) for-effect))
3072 compiled-clauses)))
3073 (setq clauses (cdr clauses)))
3074 (byte-compile-push-constant (nreverse compiled-clauses)))
3075 (byte-compile-out 'byte-condition-case 0)))
3076
3077
3078(defun byte-compile-save-excursion (form)
3079 (byte-compile-out 'byte-save-excursion 0)
3080 (byte-compile-body-do-effect (cdr form))
3081 (byte-compile-out 'byte-unbind 1))
3082
3083(defun byte-compile-save-restriction (form)
3084 (byte-compile-out 'byte-save-restriction 0)
3085 (byte-compile-body-do-effect (cdr form))
3086 (byte-compile-out 'byte-unbind 1))
3087
f3e472b0
RS
3088(defun byte-compile-save-current-buffer (form)
3089 (byte-compile-out 'byte-save-current-buffer 0)
3090 (byte-compile-body-do-effect (cdr form))
3091 (byte-compile-out 'byte-unbind 1))
3092
1c393159
JB
3093(defun byte-compile-save-window-excursion (form)
3094 (byte-compile-push-constant
3095 (byte-compile-top-level-body (cdr form) for-effect))
3096 (byte-compile-out 'byte-save-window-excursion 0))
3097
3098(defun byte-compile-with-output-to-temp-buffer (form)
3099 (byte-compile-form (car (cdr form)))
3100 (byte-compile-out 'byte-temp-output-buffer-setup 0)
3101 (byte-compile-body (cdr (cdr form)))
3102 (byte-compile-out 'byte-temp-output-buffer-show 0))
3103
3104\f
3105;;; top-level forms elsewhere
3106
3107(byte-defop-compiler-1 defun)
3108(byte-defop-compiler-1 defmacro)
3109(byte-defop-compiler-1 defvar)
3110(byte-defop-compiler-1 defconst byte-compile-defvar)
3111(byte-defop-compiler-1 autoload)
3112(byte-defop-compiler-1 lambda byte-compile-lambda-form)
5286a842 3113(byte-defop-compiler-1 defalias)
1c393159
JB
3114
3115(defun byte-compile-defun (form)
3116 ;; This is not used for file-level defuns with doc strings.
3117 (byte-compile-two-args ; Use this to avoid byte-compile-fset's warning.
3118 (list 'fset (list 'quote (nth 1 form))
3119 (byte-compile-byte-code-maker
3120 (byte-compile-lambda (cons 'lambda (cdr (cdr form)))))))
3121 (byte-compile-discard)
3122 (byte-compile-constant (nth 1 form)))
3123
3124(defun byte-compile-defmacro (form)
3125 ;; This is not used for file-level defmacros with doc strings.
3126 (byte-compile-body-do-effect
3127 (list (list 'fset (list 'quote (nth 1 form))
3128 (let ((code (byte-compile-byte-code-maker
3129 (byte-compile-lambda
3130 (cons 'lambda (cdr (cdr form)))))))
3131 (if (eq (car-safe code) 'make-byte-code)
3132 (list 'cons ''macro code)
3133 (list 'quote (cons 'macro (eval code))))))
3134 (list 'quote (nth 1 form)))))
3135
3136(defun byte-compile-defvar (form)
3137 ;; This is not used for file-level defvar/consts with doc strings.
3138 (let ((var (nth 1 form))
3139 (value (nth 2 form))
3140 (string (nth 3 form)))
3141 (if (memq 'free-vars byte-compile-warnings)
3142 (setq byte-compile-bound-variables
3143 (cons var byte-compile-bound-variables)))
3144 (byte-compile-body-do-effect
3145 (list (if (cdr (cdr form))
3146 (if (eq (car form) 'defconst)
3147 (list 'setq var value)
3148 (list 'or (list 'boundp (list 'quote var))
3149 (list 'setq var value))))
3e6eef95
RS
3150 ;; Put the defined variable in this library's load-history entry
3151 ;; just as a real defvar would.
3152 (list 'setq 'current-load-list
3153 (list 'cons (list 'quote var)
3154 'current-load-list))
1c393159
JB
3155 (if string
3156 (list 'put (list 'quote var) ''variable-documentation string))
3157 (list 'quote var)))))
3158
3159(defun byte-compile-autoload (form)
3160 (and (byte-compile-constp (nth 1 form))
3161 (byte-compile-constp (nth 5 form))
3162 (eval (nth 5 form)) ; macro-p
3163 (not (fboundp (eval (nth 1 form))))
3164 (byte-compile-warn
3165 "The compiler ignores `autoload' except at top level. You should
3166 probably put the autoload of the macro `%s' at top-level."
3167 (eval (nth 1 form))))
3168 (byte-compile-normal-call form))
3169
3170;; Lambda's in valid places are handled as special cases by various code.
3171;; The ones that remain are errors.
3172(defun byte-compile-lambda-form (form)
3173 (error "`lambda' used as function name is invalid"))
3174
5286a842
RS
3175;; Compile normally, but deal with warnings for the function being defined.
3176(defun byte-compile-defalias (form)
3177 (if (and (consp (cdr form)) (consp (nth 1 form))
3178 (eq (car (nth 1 form)) 'quote)
3179 (consp (cdr (nth 1 form)))
3180 (symbolp (nth 1 (nth 1 form)))
3181 (consp (nthcdr 2 form))
3182 (consp (nth 2 form))
3183 (eq (car (nth 2 form)) 'quote)
3184 (consp (cdr (nth 2 form)))
3185 (symbolp (nth 1 (nth 2 form))))
3186 (progn
3187 (byte-compile-defalias-warn (nth 1 (nth 1 form))
3188 (nth 1 (nth 2 form)))
3189 (setq byte-compile-function-environment
3190 (cons (cons (nth 1 (nth 1 form))
3191 (nth 1 (nth 2 form)))
3192 byte-compile-function-environment))))
b3848c28 3193 (byte-compile-normal-call form))
5286a842
RS
3194
3195;; Turn off warnings about prior calls to the function being defalias'd.
3196;; This could be smarter and compare those calls with
3197;; the function it is being aliased to.
3198(defun byte-compile-defalias-warn (new alias)
3199 (let ((calls (assq new byte-compile-unresolved-functions)))
3200 (if calls
3201 (setq byte-compile-unresolved-functions
3202 (delq calls byte-compile-unresolved-functions)))))
1c393159
JB
3203\f
3204;;; tags
3205
3206;; Note: Most operations will strip off the 'TAG, but it speeds up
3207;; optimization to have the 'TAG as a part of the tag.
3208;; Tags will be (TAG . (tag-number . stack-depth)).
3209(defun byte-compile-make-tag ()
3210 (list 'TAG (setq byte-compile-tag-number (1+ byte-compile-tag-number))))
3211
3212
3213(defun byte-compile-out-tag (tag)
3214 (setq byte-compile-output (cons tag byte-compile-output))
3215 (if (cdr (cdr tag))
3216 (progn
3217 ;; ## remove this someday
3218 (and byte-compile-depth
3219 (not (= (cdr (cdr tag)) byte-compile-depth))
52799cb8 3220 (error "Compiler bug: depth conflict at tag %d" (car (cdr tag))))
1c393159
JB
3221 (setq byte-compile-depth (cdr (cdr tag))))
3222 (setcdr (cdr tag) byte-compile-depth)))
3223
3224(defun byte-compile-goto (opcode tag)
3225 (setq byte-compile-output (cons (cons opcode tag) byte-compile-output))
3226 (setcdr (cdr tag) (if (memq opcode byte-goto-always-pop-ops)
3227 (1- byte-compile-depth)
3228 byte-compile-depth))
3229 (setq byte-compile-depth (and (not (eq opcode 'byte-goto))
3230 (1- byte-compile-depth))))
3231
3232(defun byte-compile-out (opcode offset)
3233 (setq byte-compile-output (cons (cons opcode offset) byte-compile-output))
3234 (cond ((eq opcode 'byte-call)
3235 (setq byte-compile-depth (- byte-compile-depth offset)))
3236 ((eq opcode 'byte-return)
3237 ;; This is actually an unnecessary case, because there should be
3238 ;; no more opcodes behind byte-return.
3239 (setq byte-compile-depth nil))
3240 (t
3241 (setq byte-compile-depth (+ byte-compile-depth
3242 (or (aref byte-stack+-info
3243 (symbol-value opcode))
3244 (- (1- offset))))
3245 byte-compile-maxdepth (max byte-compile-depth
3246 byte-compile-maxdepth))))
52799cb8 3247 ;;(if (< byte-compile-depth 0) (error "Compiler error: stack underflow"))
1c393159
JB
3248 )
3249
3250\f
3251;;; call tree stuff
3252
3253(defun byte-compile-annotate-call-tree (form)
3254 (let (entry)
3255 ;; annotate the current call
3256 (if (setq entry (assq (car form) byte-compile-call-tree))
3257 (or (memq byte-compile-current-form (nth 1 entry)) ;callers
3258 (setcar (cdr entry)
3259 (cons byte-compile-current-form (nth 1 entry))))
3260 (setq byte-compile-call-tree
3261 (cons (list (car form) (list byte-compile-current-form) nil)
3262 byte-compile-call-tree)))
3263 ;; annotate the current function
3264 (if (setq entry (assq byte-compile-current-form byte-compile-call-tree))
3265 (or (memq (car form) (nth 2 entry)) ;called
3266 (setcar (cdr (cdr entry))
3267 (cons (car form) (nth 2 entry))))
3268 (setq byte-compile-call-tree
3269 (cons (list byte-compile-current-form nil (list (car form)))
3270 byte-compile-call-tree)))
3271 ))
3272
52799cb8
RS
3273;; Renamed from byte-compile-report-call-tree
3274;; to avoid interfering with completion of byte-compile-file.
fd5285f3 3275;;;###autoload
52799cb8
RS
3276(defun display-call-tree (&optional filename)
3277 "Display a call graph of a specified file.
3278This lists which functions have been called, what functions called
3279them, and what functions they call. The list includes all functions
3280whose definitions have been compiled in this Emacs session, as well as
3281all functions called by those functions.
1c393159 3282
52799cb8
RS
3283The call graph does not include macros, inline functions, or
3284primitives that the byte-code interpreter knows about directly \(eq,
3285cons, etc.\).
1c393159
JB
3286
3287The call tree also lists those functions which are not known to be called
52799cb8
RS
3288\(that is, to which no calls have been compiled\), and which cannot be
3289invoked interactively."
1c393159
JB
3290 (interactive)
3291 (message "Generating call tree...")
3292 (with-output-to-temp-buffer "*Call-Tree*"
3293 (set-buffer "*Call-Tree*")
3294 (erase-buffer)
47cf9d3a 3295 (message "Generating call tree... (sorting on %s)"
1c393159
JB
3296 byte-compile-call-tree-sort)
3297 (insert "Call tree for "
3298 (cond ((null byte-compile-current-file) (or filename "???"))
3299 ((stringp byte-compile-current-file)
3300 byte-compile-current-file)
3301 (t (buffer-name byte-compile-current-file)))
3302 " sorted on "
3303 (prin1-to-string byte-compile-call-tree-sort)
3304 ":\n\n")
3305 (if byte-compile-call-tree-sort
3306 (setq byte-compile-call-tree
3307 (sort byte-compile-call-tree
3308 (cond ((eq byte-compile-call-tree-sort 'callers)
3309 (function (lambda (x y) (< (length (nth 1 x))
3310 (length (nth 1 y))))))
3311 ((eq byte-compile-call-tree-sort 'calls)
3312 (function (lambda (x y) (< (length (nth 2 x))
3313 (length (nth 2 y))))))
3314 ((eq byte-compile-call-tree-sort 'calls+callers)
3315 (function (lambda (x y) (< (+ (length (nth 1 x))
3316 (length (nth 2 x)))
3317 (+ (length (nth 1 y))
3318 (length (nth 2 y)))))))
3319 ((eq byte-compile-call-tree-sort 'name)
3320 (function (lambda (x y) (string< (car x)
3321 (car y)))))
52799cb8 3322 (t (error "`byte-compile-call-tree-sort': `%s' - unknown sort mode"
1c393159
JB
3323 byte-compile-call-tree-sort))))))
3324 (message "Generating call tree...")
3325 (let ((rest byte-compile-call-tree)
3326 (b (current-buffer))
3327 f p
3328 callers calls)
3329 (while rest
3330 (prin1 (car (car rest)) b)
3331 (setq callers (nth 1 (car rest))
3332 calls (nth 2 (car rest)))
3333 (insert "\t"
3334 (cond ((not (fboundp (setq f (car (car rest)))))
3335 (if (null f)
3336 " <top level>";; shouldn't insert nil then, actually -sk
3337 " <not defined>"))
3338 ((subrp (setq f (symbol-function f)))
3339 " <subr>")
3340 ((symbolp f)
3341 (format " ==> %s" f))
ed015bdd 3342 ((byte-code-function-p f)
1c393159
JB
3343 "<compiled function>")
3344 ((not (consp f))
3345 "<malformed function>")
3346 ((eq 'macro (car f))
ed015bdd 3347 (if (or (byte-code-function-p (cdr f))
1c393159
JB
3348 (assq 'byte-code (cdr (cdr (cdr f)))))
3349 " <compiled macro>"
3350 " <macro>"))
3351 ((assq 'byte-code (cdr (cdr f)))
3352 "<compiled lambda>")
3353 ((eq 'lambda (car f))
3354 "<function>")
3355 (t "???"))
3356 (format " (%d callers + %d calls = %d)"
3357 ;; Does the optimizer eliminate common subexpressions?-sk
3358 (length callers)
3359 (length calls)
3360 (+ (length callers) (length calls)))
3361 "\n")
3362 (if callers
3363 (progn
3364 (insert " called by:\n")
3365 (setq p (point))
3366 (insert " " (if (car callers)
3367 (mapconcat 'symbol-name callers ", ")
3368 "<top level>"))
3369 (let ((fill-prefix " "))
3370 (fill-region-as-paragraph p (point)))))
3371 (if calls
3372 (progn
3373 (insert " calls:\n")
3374 (setq p (point))
3375 (insert " " (mapconcat 'symbol-name calls ", "))
3376 (let ((fill-prefix " "))
3377 (fill-region-as-paragraph p (point)))))
3378 (insert "\n")
3379 (setq rest (cdr rest)))
3380
3381 (message "Generating call tree...(finding uncalled functions...)")
3382 (setq rest byte-compile-call-tree)
3383 (let ((uncalled nil))
3384 (while rest
3385 (or (nth 1 (car rest))
3386 (null (setq f (car (car rest))))
3387 (byte-compile-fdefinition f t)
3388 (commandp (byte-compile-fdefinition f nil))
3389 (setq uncalled (cons f uncalled)))
3390 (setq rest (cdr rest)))
3391 (if uncalled
3392 (let ((fill-prefix " "))
3393 (insert "Noninteractive functions not known to be called:\n ")
3394 (setq p (point))
3395 (insert (mapconcat 'symbol-name (nreverse uncalled) ", "))
3396 (fill-region-as-paragraph p (point)))))
3397 )
3398 (message "Generating call tree...done.")
3399 ))
3400
3401\f
3402;;; by crl@newton.purdue.edu
3403;;; Only works noninteractively.
fd5285f3 3404;;;###autoload
1c393159 3405(defun batch-byte-compile ()
52799cb8
RS
3406 "Run `byte-compile-file' on the files remaining on the command line.
3407Use this from the command line, with `-batch';
3408it won't work in an interactive Emacs.
3409Each file is processed even if an error occurred previously.
1c393159
JB
3410For example, invoke \"emacs -batch -f batch-byte-compile $emacs/ ~/*.el\""
3411 ;; command-line-args-left is what is left of the command line (from startup.el)
3412 (defvar command-line-args-left) ;Avoid 'free variable' warning
3413 (if (not noninteractive)
52799cb8 3414 (error "`batch-byte-compile' is to be used only with -batch"))
1c393159
JB
3415 (let ((error nil))
3416 (while command-line-args-left
3417 (if (file-directory-p (expand-file-name (car command-line-args-left)))
3418 (let ((files (directory-files (car command-line-args-left)))
3419 source dest)
3420 (while files
52799cb8 3421 (if (and (string-match emacs-lisp-file-regexp (car files))
1c393159
JB
3422 (not (auto-save-file-name-p (car files)))
3423 (setq source (expand-file-name (car files)
3424 (car command-line-args-left)))
3425 (setq dest (byte-compile-dest-file source))
3426 (file-exists-p dest)
3427 (file-newer-than-file-p source dest))
3428 (if (null (batch-byte-compile-file source))
3429 (setq error t)))
3430 (setq files (cdr files))))
3431 (if (null (batch-byte-compile-file (car command-line-args-left)))
3432 (setq error t)))
3433 (setq command-line-args-left (cdr command-line-args-left)))
3434 (message "Done")
3435 (kill-emacs (if error 1 0))))
3436
3437(defun batch-byte-compile-file (file)
3438 (condition-case err
1c57117e 3439 (byte-compile-file file)
1c393159
JB
3440 (error
3441 (message (if (cdr err)
3442 ">>Error occurred processing %s: %s (%s)"
3443 ">>Error occurred processing %s: %s")
3444 file
3445 (get (car err) 'error-message)
3446 (prin1-to-string (cdr err)))
3447 nil)))
3448
e9681c45 3449;;;###autoload
e27c3564
JB
3450(defun batch-byte-recompile-directory ()
3451 "Runs `byte-recompile-directory' on the dirs remaining on the command line.
79c6071d
RS
3452Must be used only with `-batch', and kills Emacs on completion.
3453For example, invoke `emacs -batch -f batch-byte-recompile-directory .'."
e27c3564
JB
3454 ;; command-line-args-left is what is left of the command line (startup.el)
3455 (defvar command-line-args-left) ;Avoid 'free variable' warning
3456 (if (not noninteractive)
3457 (error "batch-byte-recompile-directory is to be used only with -batch"))
3458 (or command-line-args-left
3459 (setq command-line-args-left '(".")))
3460 (while command-line-args-left
3461 (byte-recompile-directory (car command-line-args-left))
3462 (setq command-line-args-left (cdr command-line-args-left)))
3463 (kill-emacs 0))
3464
1c393159 3465
1c393159
JB
3466(make-obsolete 'dot 'point)
3467(make-obsolete 'dot-max 'point-max)
3468(make-obsolete 'dot-min 'point-min)
3469(make-obsolete 'dot-marker 'point-marker)
3470
52799cb8
RS
3471(make-obsolete 'buffer-flush-undo 'buffer-disable-undo)
3472(make-obsolete 'baud-rate "use the baud-rate variable instead")
ed015bdd 3473(make-obsolete 'compiled-function-p 'byte-code-function-p)
1814e5a9 3474(make-obsolete 'define-function 'defalias)
9e2b097b
JB
3475(make-obsolete-variable 'auto-fill-hook 'auto-fill-function)
3476(make-obsolete-variable 'blink-paren-hook 'blink-paren-function)
3477(make-obsolete-variable 'lisp-indent-hook 'lisp-indent-function)
9e2b097b 3478(make-obsolete-variable 'inhibit-local-variables
5023d9a0 3479 "use enable-local-variables (with the reversed sense).")
79d52eea 3480(make-obsolete-variable 'unread-command-char
ed015bdd
JB
3481 "use unread-command-events instead. That variable is a list of events to reread, so it now uses nil to mean `no event', instead of -1.")
3482(make-obsolete-variable 'unread-command-event
591655c7 3483 "use unread-command-events; which is a list of events rather than a single event.")
f3341900 3484(make-obsolete-variable 'suspend-hooks 'suspend-hook)
ec9a76e3 3485(make-obsolete-variable 'comment-indent-hook 'comment-indent-function)
f3341900 3486(make-obsolete-variable 'meta-flag "Use the set-input-mode function instead.")
591655c7
SM
3487(make-obsolete-variable 'executing-macro 'executing-kbd-macro)
3488(make-obsolete-variable 'before-change-function
3489 "use before-change-functions; which is a list of functions rather than a single function.")
3490(make-obsolete-variable 'after-change-function
3491 "use after-change-functions; which is a list of functions rather than a single function.")
3492(make-obsolete-variable 'font-lock-doc-string-face 'font-lock-string-face)
ed16b6f2
RS
3493(make-obsolete-variable 'post-command-idle-hook
3494 "use timers instead, with `run-with-idle-timer'.")
3495(make-obsolete-variable 'post-command-idle-delay
3496 "use timers instead, with `run-with-idle-timer'.")
1c393159
JB
3497
3498(provide 'byte-compile)
200503bb 3499(provide 'bytecomp)
1c393159
JB
3500
3501\f
3502;;; report metering (see the hacks in bytecode.c)
3503
52799cb8
RS
3504(defun byte-compile-report-ops ()
3505 (defvar byte-code-meter)
3506 (with-output-to-temp-buffer "*Meter*"
3507 (set-buffer "*Meter*")
3508 (let ((i 0) n op off)
3509 (while (< i 256)
3510 (setq n (aref (aref byte-code-meter 0) i)
3511 off nil)
3512 (if t ;(not (zerop n))
3513 (progn
3514 (setq op i)
3515 (setq off nil)
3516 (cond ((< op byte-nth)
3517 (setq off (logand op 7))
3518 (setq op (logand op 248)))
3519 ((>= op byte-constant)
3520 (setq off (- op byte-constant)
3521 op byte-constant)))
3522 (setq op (aref byte-code-vector op))
3523 (insert (format "%-4d" i))
3524 (insert (symbol-name op))
3525 (if off (insert " [" (int-to-string off) "]"))
3526 (indent-to 40)
3527 (insert (int-to-string n) "\n")))
3528 (setq i (1+ i))))))
1c393159
JB
3529\f
3530;; To avoid "lisp nesting exceeds max-lisp-eval-depth" when bytecomp compiles
3531;; itself, compile some of its most used recursive functions (at load time).
3532;;
3533(eval-when-compile
591655c7
SM
3534 (or (byte-code-function-p (symbol-function 'byte-compile-form))
3535 (assq 'byte-code (symbol-function 'byte-compile-form))
3536 (let ((byte-optimize nil) ; do it fast
3537 (byte-compile-warnings nil))
3538 (mapcar '(lambda (x)
3539 (or noninteractive (message "compiling %s..." x))
3540 (byte-compile x)
3541 (or noninteractive (message "compiling %s...done" x)))
3542 '(byte-compile-normal-call
3543 byte-compile-form
3544 byte-compile-body
3545 ;; Inserted some more than necessary, to speed it up.
3546 byte-compile-top-level
3547 byte-compile-out-toplevel
3548 byte-compile-constant
3549 byte-compile-variable-ref))))
3550 nil)
fd5285f3
RS
3551
3552;;; bytecomp.el ends here