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