(require 'backquote)
(or (fboundp 'defsubst)
(load "byte-run"))
(defmacro byte-compile-single-version () nil)
(defmacro byte-compile-version-cond (cond) cond)
(defgroup bytecomp nil
"Emacs Lisp byte-compiler."
:group 'lisp)
(defcustom emacs-lisp-file-regexp (if (eq system-type 'vax-vms)
"\\.EL\\(;[0-9]+\\)?$"
"\\.el$")
"*Regexp which matches Emacs Lisp source files.
You may want to redefine the function `byte-compile-dest-file'
if you change this variable."
:group 'bytecomp
:type 'regexp)
(defun byte-compiler-base-file-name (filename)
(let ((handler (find-file-name-handler filename
'byte-compiler-base-file-name)))
(if handler
(funcall handler 'byte-compiler-base-file-name filename)
filename)))
(or (fboundp 'byte-compile-dest-file)
(defun byte-compile-dest-file (filename)
"Convert an Emacs Lisp source file name to a compiled file name.
If FILENAME matches `emacs-lisp-file-regexp' (by default, files
with the extension `.el'), add `c' to it; otherwise add `.elc'."
(setq filename (byte-compiler-base-file-name filename))
(setq filename (file-name-sans-versions filename))
(cond ((eq system-type 'vax-vms)
(concat (substring filename 0 (string-match ";" filename)) "c"))
((string-match emacs-lisp-file-regexp filename)
(concat (substring filename 0 (match-beginning 0)) ".elc"))
(t (concat filename ".elc")))))
(autoload 'byte-compile-inline-expand "byte-opt")
(autoload 'byte-optimize-form "byte-opt")
(autoload 'byte-optimize-lapcode "byte-opt")
(autoload 'byte-compile-unfold-lambda "byte-opt")
(autoload 'byte-decompile-bytecode "byte-opt")
(defcustom byte-compile-verbose
(and (not noninteractive) (> baud-rate search-slow-speed))
"*Non-nil means print messages describing progress of byte-compiler."
:group 'bytecomp
:type 'boolean)
(defcustom byte-compile-compatibility nil
"*Non-nil means generate output that can run in Emacs 18.
This only means that it can run in principle, if it doesn't require
facilities that have been added more recently."
:group 'bytecomp
:type 'boolean)
(defcustom byte-optimize t
"*Enable optimization in the byte compiler.
Possible values are:
nil - no optimization
t - all optimizations
`source' - source-level optimizations only
`byte' - code-level optimizations only"
:group 'bytecomp
:type '(choice (const :tag "none" nil)
(const :tag "all" t)
(const :tag "source-level" source)
(const :tag "byte-level" byte)))
(defcustom byte-compile-delete-errors nil
"*If non-nil, the optimizer may delete forms that may signal an error.
This includes variable references and calls to functions such as `car'."
:group 'bytecomp
:type 'boolean)
(defvar byte-compile-dynamic nil
"If non-nil, compile function bodies so they load lazily.
They are hidden in comments in the compiled file,
and each one is brought into core when the
function is called.
To enable this option, make it a file-local variable
in the source file you want it to apply to.
For example, add -*-byte-compile-dynamic: t;-*- on the first line.
When this option is true, if you load the compiled file and then move it,
the functions you loaded will not be able to run.")
(defvar byte-compile-disable-print-circle nil
"If non-nil, disable `print-circle' on printing a byte-compiled code.")
(defcustom byte-compile-dynamic-docstrings t
"*If non-nil, compile doc strings for lazy access.
We bury the doc strings of functions and variables
inside comments in the file, and bring them into core only when they
are actually needed.
When this option is true, if you load the compiled file and then move it,
you won't be able to find the documentation of anything in that file.
To disable this option for a certain file, make it a file-local variable
in the source file. For example, add this to the first line:
-*-byte-compile-dynamic-docstrings:nil;-*-
You can also set the variable globally.
This option is enabled by default because it reduces Emacs memory usage."
:group 'bytecomp
:type 'boolean)
(defcustom byte-optimize-log nil
"*If true, the byte-compiler will log its optimizations into *Compile-Log*.
If this is 'source, then only source-level optimizations will be logged.
If it is 'byte, then only byte-level optimizations will be logged."
:group 'bytecomp
:type '(choice (const :tag "none" nil)
(const :tag "all" t)
(const :tag "source-level" source)
(const :tag "byte-level" byte)))
(defcustom byte-compile-error-on-warn nil
"*If true, the byte-compiler reports warnings with `error'."
:group 'bytecomp
:type 'boolean)
(defconst byte-compile-warning-types
'(redefine callargs free-vars unresolved
obsolete noruntime cl-functions interactive-only)
"The list of warning types used when `byte-compile-warnings' is t.")
(defcustom byte-compile-warnings t
"*List of warnings that the byte-compiler should issue (t for all).
Elements of the list may be:
free-vars references to variables not in the current lexical scope.
unresolved calls to unknown functions.
callargs function calls with args that don't match the definition.
redefine function name redefined from a macro to ordinary function or vice
versa, or redefined to take a different number of arguments.
obsolete obsolete variables and functions.
noruntime functions that may not be defined at runtime (typically
defined only under `eval-when-compile').
cl-functions calls to runtime functions from the CL package (as
distinguished from macros and aliases).
interactive-only
commands that normally shouldn't be called from Lisp code."
:group 'bytecomp
:type `(choice (const :tag "All" t)
(set :menu-tag "Some"
(const free-vars) (const unresolved)
(const callargs) (const redefine)
(const obsolete) (const noruntime)
(const cl-functions) (const interactive-only))))
(put 'byte-compile-warnings 'safe-local-variable 'byte-compile-warnings-safe-p)
(defun byte-compile-warnings-safe-p (x)
(or (booleanp x)
(and (listp x)
(equal (mapcar
(lambda (e)
(when (memq e '(free-vars unresolved
callargs redefine
obsolete noruntime
cl-functions interactive-only))
e))
x)
x))))
(defvar byte-compile-interactive-only-functions
'(beginning-of-buffer end-of-buffer replace-string replace-regexp
insert-file insert-buffer insert-file-literally)
"List of commands that are not meant to be called from Lisp.")
(defvar byte-compile-not-obsolete-var nil
"If non-nil, this is a variable that shouldn't be reported as obsolete.")
(defcustom byte-compile-generate-call-tree nil
"*Non-nil means collect call-graph information when compiling.
This records which functions were called and from where.
If the value is t, compilation displays the call graph when it finishes.
If the value is neither t nor nil, compilation asks you whether to display
the graph.
The call tree only lists functions called, not macros used. Those functions
which the byte-code interpreter knows about directly (eq, cons, etc.) are
not reported.
The call tree also lists those functions which are not known to be called
\(that is, to which no calls have been compiled). Functions which can be
invoked interactively are excluded from this list."
:group 'bytecomp
:type '(choice (const :tag "Yes" t) (const :tag "No" nil)
(other :tag "Ask" lambda)))
(defvar byte-compile-call-tree nil "Alist of functions and their call tree.
Each element looks like
\(FUNCTION CALLERS CALLS\)
where CALLERS is a list of functions that call FUNCTION, and CALLS
is a list of functions for which calls were generated while compiling
FUNCTION.")
(defcustom byte-compile-call-tree-sort 'name
"*If non-nil, sort the call tree.
The values `name', `callers', `calls', `calls+callers'
specify different fields to sort on."
:group 'bytecomp
:type '(choice (const name) (const callers) (const calls)
(const calls+callers) (const nil)))
(defvar byte-compile-debug nil)
(defvar byte-compile-constants nil
"List of all constants encountered during compilation of this form.")
(defvar byte-compile-variables nil
"List of all variables encountered during compilation of this form.")
(defvar byte-compile-bound-variables nil
"List of variables bound in the context of the current form.
This list lives partly on the stack.")
(defvar byte-compile-const-variables nil
"List of variables declared as constants during compilation of this file.")
(defvar byte-compile-free-references)
(defvar byte-compile-free-assignments)
(defvar byte-compiler-error-flag)
(defconst byte-compile-initial-macro-environment
'(
(eval-when-compile . (lambda (&rest body)
(list 'quote
(byte-compile-eval (byte-compile-top-level
(cons 'progn body))))))
(eval-and-compile . (lambda (&rest body)
(byte-compile-eval-before-compile (cons 'progn body))
(cons 'progn body))))
"The default macro-environment passed to macroexpand by the compiler.
Placing a macro here will cause a macro to have different semantics when
expanded by the compiler as when expanded by the interpreter.")
(defvar byte-compile-macro-environment byte-compile-initial-macro-environment
"Alist of macros defined in the file being compiled.
Each element looks like (MACRONAME . DEFINITION). It is
\(MACRONAME . nil) when a macro is redefined as a function.")
(defvar byte-compile-function-environment nil
"Alist of functions defined in the file being compiled.
This is so we can inline them when necessary.
Each element looks like (FUNCTIONNAME . DEFINITION). It is
\(FUNCTIONNAME . nil) when a function is redefined as a macro.
It is \(FUNCTIONNAME . t) when all we know is that it was defined,
and we don't know the definition.")
(defvar byte-compile-unresolved-functions nil
"Alist of undefined functions to which calls have been compiled.
Used for warnings when the function is not known to be defined or is later
defined with incorrect args.")
(defvar byte-compile-noruntime-functions nil
"Alist of functions called that may not be defined when the compiled code is run.
Used for warnings about calling a function that is defined during compilation
but won't necessarily be defined when the compiled file is loaded.")
(defvar byte-compile-tag-number 0)
(defvar byte-compile-output nil
"Alist describing contents to put in byte code string.
Each element is (INDEX . VALUE)")
(defvar byte-compile-depth 0 "Current depth of execution stack.")
(defvar byte-compile-maxdepth 0 "Maximum depth of execution stack.")
(defvar byte-code-vector nil
"An array containing byte-code names indexed by byte-code values.")
(defvar byte-stack+-info nil
"An array with the stack adjustment for each byte-code.")
(defmacro byte-defop (opcode stack-adjust opname &optional docstring)
(let ((v1 (or (get 'byte-code-vector 'tmp-compile-time-value)
(put 'byte-code-vector 'tmp-compile-time-value
(make-vector 256 nil))))
(v2 (or (get 'byte-stack+-info 'tmp-compile-time-value)
(put 'byte-stack+-info 'tmp-compile-time-value
(make-vector 256 nil)))))
(aset v1 opcode opname)
(aset v2 opcode stack-adjust))
(if docstring
(list 'defconst opname opcode (concat "Byte code opcode " docstring "."))
(list 'defconst opname opcode)))
(defmacro byte-extrude-byte-code-vectors ()
(prog1 (list 'setq 'byte-code-vector
(get 'byte-code-vector 'tmp-compile-time-value)
'byte-stack+-info
(get 'byte-stack+-info 'tmp-compile-time-value))
(put 'byte-code-vector 'tmp-compile-time-value nil)
(put 'byte-stack+-info 'tmp-compile-time-value nil)))
(byte-defop 8 1 byte-varref "for variable reference")
(byte-defop 16 -1 byte-varset "for setting a variable")
(byte-defop 24 -1 byte-varbind "for binding a variable")
(byte-defop 32 0 byte-call "for calling a function")
(byte-defop 40 0 byte-unbind "for unbinding special bindings")
(byte-defop 56 -1 byte-nth)
(byte-defop 57 0 byte-symbolp)
(byte-defop 58 0 byte-consp)
(byte-defop 59 0 byte-stringp)
(byte-defop 60 0 byte-listp)
(byte-defop 61 -1 byte-eq)
(byte-defop 62 -1 byte-memq)
(byte-defop 63 0 byte-not)
(byte-defop 64 0 byte-car)
(byte-defop 65 0 byte-cdr)
(byte-defop 66 -1 byte-cons)
(byte-defop 67 0 byte-list1)
(byte-defop 68 -1 byte-list2)
(byte-defop 69 -2 byte-list3)
(byte-defop 70 -3 byte-list4)
(byte-defop 71 0 byte-length)
(byte-defop 72 -1 byte-aref)
(byte-defop 73 -2 byte-aset)
(byte-defop 74 0 byte-symbol-value)
(byte-defop 75 0 byte-symbol-function) (byte-defop 76 -1 byte-set)
(byte-defop 77 -1 byte-fset) (byte-defop 78 -1 byte-get)
(byte-defop 79 -2 byte-substring)
(byte-defop 80 -1 byte-concat2)
(byte-defop 81 -2 byte-concat3)
(byte-defop 82 -3 byte-concat4)
(byte-defop 83 0 byte-sub1)
(byte-defop 84 0 byte-add1)
(byte-defop 85 -1 byte-eqlsign)
(byte-defop 86 -1 byte-gtr)
(byte-defop 87 -1 byte-lss)
(byte-defop 88 -1 byte-leq)
(byte-defop 89 -1 byte-geq)
(byte-defop 90 -1 byte-diff)
(byte-defop 91 0 byte-negate)
(byte-defop 92 -1 byte-plus)
(byte-defop 93 -1 byte-max)
(byte-defop 94 -1 byte-min)
(byte-defop 95 -1 byte-mult) (byte-defop 96 1 byte-point)
(byte-defop 98 0 byte-goto-char)
(byte-defop 99 0 byte-insert)
(byte-defop 100 1 byte-point-max)
(byte-defop 101 1 byte-point-min)
(byte-defop 102 0 byte-char-after)
(byte-defop 103 1 byte-following-char)
(byte-defop 104 1 byte-preceding-char)
(byte-defop 105 1 byte-current-column)
(byte-defop 106 0 byte-indent-to)
(byte-defop 107 0 byte-scan-buffer-OBSOLETE) (byte-defop 108 1 byte-eolp)
(byte-defop 109 1 byte-eobp)
(byte-defop 110 1 byte-bolp)
(byte-defop 111 1 byte-bobp)
(byte-defop 112 1 byte-current-buffer)
(byte-defop 113 0 byte-set-buffer)
(byte-defop 114 0 byte-save-current-buffer
"To make a binding to record the current buffer")
(byte-defop 115 0 byte-set-mark-OBSOLETE)
(byte-defop 116 1 byte-interactive-p)
(byte-defop 117 0 byte-forward-char)
(byte-defop 118 0 byte-forward-word)
(byte-defop 119 -1 byte-skip-chars-forward)
(byte-defop 120 -1 byte-skip-chars-backward)
(byte-defop 121 0 byte-forward-line)
(byte-defop 122 0 byte-char-syntax)
(byte-defop 123 -1 byte-buffer-substring)
(byte-defop 124 -1 byte-delete-region)
(byte-defop 125 -1 byte-narrow-to-region)
(byte-defop 126 1 byte-widen)
(byte-defop 127 0 byte-end-of-line)
(byte-defop 129 1 byte-constant2
"for reference to a constant with vector index >= byte-constant-limit")
(byte-defop 130 0 byte-goto "for unconditional jump")
(byte-defop 131 -1 byte-goto-if-nil "to pop value and jump if it's nil")
(byte-defop 132 -1 byte-goto-if-not-nil "to pop value and jump if it's not nil")
(byte-defop 133 -1 byte-goto-if-nil-else-pop
"to examine top-of-stack, jump and don't pop it if it's nil,
otherwise pop it")
(byte-defop 134 -1 byte-goto-if-not-nil-else-pop
"to examine top-of-stack, jump and don't pop it if it's non nil,
otherwise pop it")
(byte-defop 135 -1 byte-return "to pop a value and return it from `byte-code'")
(byte-defop 136 -1 byte-discard "to discard one value from stack")
(byte-defop 137 1 byte-dup "to duplicate the top of the stack")
(byte-defop 138 0 byte-save-excursion
"to make a binding to record the buffer, point and mark")
(byte-defop 139 0 byte-save-window-excursion
"to make a binding to record entire window configuration")
(byte-defop 140 0 byte-save-restriction
"to make a binding to record the current buffer clipping restrictions")
(byte-defop 141 -1 byte-catch
"for catch. Takes, on stack, the tag and an expression for the body")
(byte-defop 142 -1 byte-unwind-protect
"for unwind-protect. Takes, on stack, an expression for the unwind-action")
(byte-defop 143 -2 byte-condition-case)
(byte-defop 144 0 byte-temp-output-buffer-setup)
(byte-defop 145 -1 byte-temp-output-buffer-show)
(byte-defop 146 0 byte-unbind-all)
(byte-defop 147 -2 byte-set-marker)
(byte-defop 148 0 byte-match-beginning)
(byte-defop 149 0 byte-match-end)
(byte-defop 150 0 byte-upcase)
(byte-defop 151 0 byte-downcase)
(byte-defop 152 -1 byte-string=)
(byte-defop 153 -1 byte-string<)
(byte-defop 154 -1 byte-equal)
(byte-defop 155 -1 byte-nthcdr)
(byte-defop 156 -1 byte-elt)
(byte-defop 157 -1 byte-member)
(byte-defop 158 -1 byte-assq)
(byte-defop 159 0 byte-nreverse)
(byte-defop 160 -1 byte-setcar)
(byte-defop 161 -1 byte-setcdr)
(byte-defop 162 0 byte-car-safe)
(byte-defop 163 0 byte-cdr-safe)
(byte-defop 164 -1 byte-nconc)
(byte-defop 165 -1 byte-quo)
(byte-defop 166 -1 byte-rem)
(byte-defop 167 0 byte-numberp)
(byte-defop 168 0 byte-integerp)
(byte-defop 175 nil byte-listN)
(byte-defop 176 nil byte-concatN)
(byte-defop 177 nil byte-insertN)
(byte-defop 192 1 byte-constant "for reference to a constant")
(defconst byte-constant-limit 64
"Exclusive maximum index usable in the `byte-constant' opcode.")
(defconst byte-goto-ops '(byte-goto byte-goto-if-nil byte-goto-if-not-nil
byte-goto-if-nil-else-pop
byte-goto-if-not-nil-else-pop)
"List of byte-codes whose offset is a pc.")
(defconst byte-goto-always-pop-ops '(byte-goto-if-nil byte-goto-if-not-nil))
(byte-extrude-byte-code-vectors)
(defun byte-compile-lapcode (lap)
"Turns lapcode into bytecode. The lapcode is destroyed."
(let ((pc 0) op off (bytes '()) (patchlist nil)) (while lap
(setq op (car (car lap))
off (cdr (car lap)))
(cond ((not (symbolp op))
(error "Non-symbolic opcode `%s'" op))
((eq op 'TAG)
(setcar off pc)
(setq patchlist (cons off patchlist)))
((memq op byte-goto-ops)
(setq pc (+ pc 3))
(setq bytes (cons (cons pc (cdr off))
(cons nil
(cons (symbol-value op) bytes))))
(setq patchlist (cons bytes patchlist)))
(t
(setq bytes
(cond ((cond ((consp off)
(setq off (cdr off))
(eq op 'byte-constant)))
(cond ((< off byte-constant-limit)
(setq pc (1+ pc))
(cons (+ byte-constant off) bytes))
(t
(setq pc (+ 3 pc))
(cons (lsh off -8)
(cons (logand off 255)
(cons byte-constant2 bytes))))))
((<= byte-listN (symbol-value op))
(setq pc (+ 2 pc))
(cons off (cons (symbol-value op) bytes)))
((< off 6)
(setq pc (1+ pc))
(cons (+ (symbol-value op) off) bytes))
((< off 256)
(setq pc (+ 2 pc))
(cons off (cons (+ (symbol-value op) 6) bytes)))
(t
(setq pc (+ 3 pc))
(cons (lsh off -8)
(cons (logand off 255)
(cons (+ (symbol-value op) 7)
bytes))))))))
(setq lap (cdr lap)))
(let (bytes)
(while patchlist
(setq bytes (car patchlist))
(cond ((atom (car bytes))) (t (setq pc (car (cdr (car bytes)))) (setcar (cdr bytes) (logand pc 255))
(setcar bytes (lsh pc -8))))
(setq patchlist (cdr patchlist))))
(concat (nreverse bytes))))
(defun byte-compile-eval (form)
"Eval FORM and mark the functions defined therein.
Each function's symbol gets added to `byte-compile-noruntime-functions'."
(let ((hist-orig load-history)
(hist-nil-orig current-load-list))
(prog1 (eval form)
(when (memq 'noruntime byte-compile-warnings)
(let ((hist-new load-history)
(hist-nil-new current-load-list))
(while (and hist-new (not (eq hist-new hist-orig)))
(let ((xs (pop hist-new))
old-autoloads)
(unless (or (assoc (car xs) hist-orig)
(equal (car xs) "cl"))
(dolist (s xs)
(cond
((symbolp s)
(unless (memq s old-autoloads)
(push s byte-compile-noruntime-functions)))
((and (consp s) (eq t (car s)))
(push (cdr s) old-autoloads))
((and (consp s) (eq 'autoload (car s)))
(push (cdr s) byte-compile-noruntime-functions)))))))
(let (old-autoloads)
(while (and hist-nil-new (not (eq hist-nil-new hist-nil-orig)))
(let ((s (pop hist-nil-new)))
(when (and (symbolp s) (not (memq s old-autoloads)))
(push s byte-compile-noruntime-functions))
(when (and (consp s) (eq t (car s)))
(push (cdr s) old-autoloads)))))))
(when (memq 'cl-functions byte-compile-warnings)
(let ((hist-new load-history)
(hist-nil-new current-load-list))
(while (and hist-new (not (eq hist-new hist-orig)))
(let ((xs (pop hist-new))
old-autoloads)
(when (and (equal (car xs) "cl") (not (assoc (car xs) hist-orig)))
(byte-compile-find-cl-functions)))))))))
(defun byte-compile-eval-before-compile (form)
"Evaluate FORM for `eval-and-compile'."
(let ((hist-nil-orig current-load-list))
(prog1 (eval form)
(let ((tem current-load-list))
(while (not (eq tem hist-nil-orig))
(when (equal (car tem) '(require . cl))
(setq byte-compile-warnings
(remq 'cl-functions byte-compile-warnings)))
(setq tem (cdr tem)))))))
(defvar byte-compile-current-form nil)
(defvar byte-compile-dest-file nil)
(defvar byte-compile-current-file nil)
(defvar byte-compile-current-buffer nil)
(defmacro byte-compile-log (format-string &rest args)
`(and
byte-optimize
(memq byte-optimize-log '(t source))
(let ((print-escape-newlines t)
(print-level 4)
(print-length 4))
(byte-compile-log-1
(format
,format-string
,@(mapcar
(lambda (x) (if (symbolp x) (list 'prin1-to-string x) x))
args))))))
(defun byte-compile-log-1 (string)
(with-current-buffer "*Compile-Log*"
(let ((inhibit-read-only t))
(goto-char (point-max))
(byte-compile-warning-prefix nil nil)
(cond (noninteractive
(message " %s" string))
(t
(insert (format "%s\n" string)))))))
(defvar byte-compile-read-position nil
"Character position we began the last `read' from.")
(defvar byte-compile-last-position nil
"Last known character position in the input.")
(defsubst byte-compile-delete-first (elt list)
(if (eq (car list) elt)
(cdr list)
(let ((total list))
(while (and (cdr list)
(not (eq (cadr list) elt)))
(setq list (cdr list)))
(when (cdr list)
(setcdr list (cddr list)))
total)))
(defun byte-compile-set-symbol-position (sym &optional allow-previous)
(when byte-compile-read-position
(let (last entry)
(while (progn
(setq last byte-compile-last-position
entry (assq sym read-symbol-positions-list))
(when entry
(setq byte-compile-last-position
(+ byte-compile-read-position (cdr entry))
read-symbol-positions-list
(byte-compile-delete-first
entry read-symbol-positions-list)))
(or (and allow-previous (not (= last byte-compile-last-position)))
(> last byte-compile-last-position)))))))
(defvar byte-compile-last-warned-form nil)
(defvar byte-compile-last-logged-file nil)
(defun byte-compile-warning-prefix (level entry)
(let* ((inhibit-read-only t)
(dir default-directory)
(file (cond ((stringp byte-compile-current-file)
(format "%s:" (file-relative-name byte-compile-current-file dir)))
((bufferp byte-compile-current-file)
(format "Buffer %s:"
(buffer-name byte-compile-current-file)))
(t "")))
(pos (if (and byte-compile-current-file
(integerp byte-compile-read-position))
(with-current-buffer byte-compile-current-buffer
(format "%d:%d:"
(save-excursion
(goto-char byte-compile-last-position)
(1+ (count-lines (point-min) (point-at-bol))))
(save-excursion
(goto-char byte-compile-last-position)
(1+ (current-column)))))
""))
(form (if (eq byte-compile-current-form :end) "end of data"
(or byte-compile-current-form "toplevel form"))))
(when (or (and byte-compile-current-file
(not (equal byte-compile-current-file
byte-compile-last-logged-file)))
(and byte-compile-current-form
(not (eq byte-compile-current-form
byte-compile-last-warned-form))))
(insert (format "\nIn %s:\n" form)))
(when level
(insert (format "%s%s" file pos))))
(setq byte-compile-last-logged-file byte-compile-current-file
byte-compile-last-warned-form byte-compile-current-form)
entry)
(defun byte-compile-warning-series (&rest ignore)
nil)
(defun byte-compile-log-file ()
(and (not (equal byte-compile-current-file byte-compile-last-logged-file))
(not noninteractive)
(save-excursion
(set-buffer (get-buffer-create "*Compile-Log*"))
(goto-char (point-max))
(let* ((inhibit-read-only t)
(dir (and byte-compile-current-file
(file-name-directory byte-compile-current-file)))
(was-same (equal default-directory dir))
pt)
(when dir
(unless was-same
(insert (format "Leaving directory `%s'\n" default-directory))))
(unless (bolp)
(insert "\n"))
(setq pt (point-marker))
(if byte-compile-current-file
(insert "\f\nCompiling "
(if (stringp byte-compile-current-file)
(concat "file " byte-compile-current-file)
(concat "buffer " (buffer-name byte-compile-current-file)))
" at " (current-time-string) "\n")
(insert "\f\nCompiling no file at " (current-time-string) "\n"))
(when dir
(setq default-directory dir)
(unless was-same
(insert (format "Entering directory `%s'\n" default-directory))))
(setq byte-compile-last-logged-file byte-compile-current-file
byte-compile-last-warned-form nil)
(unless (eq major-mode 'compilation-mode)
(compilation-mode))
(compilation-forget-errors)
pt))))
(defun byte-compile-log-warning (string &optional fill level)
(let ((warning-prefix-function 'byte-compile-warning-prefix)
(warning-type-format "")
(warning-fill-prefix (if fill " "))
(inhibit-read-only t))
(display-warning 'bytecomp string level "*Compile-Log*")))
(defun byte-compile-warn (format &rest args)
"Issue a byte compiler warning; use (format FORMAT ARGS...) for message."
(setq format (apply 'format format args))
(if byte-compile-error-on-warn
(error "%s" format) (byte-compile-log-warning format t :warning)))
(defun byte-compile-report-error (error-info)
"Report Lisp error in compilation. ERROR-INFO is the error data."
(setq byte-compiler-error-flag t)
(byte-compile-log-warning
(error-message-string error-info)
nil :error))
(defun byte-compile-obsolete (form)
(let* ((new (get (car form) 'byte-obsolete-info))
(handler (nth 1 new))
(when (nth 2 new)))
(byte-compile-set-symbol-position (car form))
(if (memq 'obsolete byte-compile-warnings)
(byte-compile-warn "`%s' is an obsolete function%s; %s" (car form)
(if when (concat " (as of Emacs " when ")") "")
(if (stringp (car new))
(car new)
(format "use `%s' instead." (car new)))))
(funcall (or handler 'byte-compile-normal-call) form)))
(defun byte-compile-fdefinition (name macro-p)
(let* ((list (if macro-p
byte-compile-macro-environment
byte-compile-function-environment))
(env (cdr (assq name list))))
(or env
(let ((fn name))
(while (and (symbolp fn)
(fboundp fn)
(or (symbolp (symbol-function fn))
(consp (symbol-function fn))
(and (not macro-p)
(byte-code-function-p (symbol-function fn)))))
(setq fn (symbol-function fn)))
(if (and (not macro-p) (byte-code-function-p fn))
fn
(and (consp fn)
(if (eq 'macro (car fn))
(cdr fn)
(if macro-p
nil
(if (eq 'autoload (car fn))
nil
fn)))))))))
(defun byte-compile-arglist-signature (arglist)
(let ((args 0)
opts
restp)
(while arglist
(cond ((eq (car arglist) '&optional)
(or opts (setq opts 0)))
((eq (car arglist) '&rest)
(if (cdr arglist)
(setq restp t
arglist nil)))
(t
(if opts
(setq opts (1+ opts))
(setq args (1+ args)))))
(setq arglist (cdr arglist)))
(cons args (if restp nil (if opts (+ args opts) args)))))
(defun byte-compile-arglist-signatures-congruent-p (old new)
(not (or
(> (car new) (car old)) (and (null (cdr old)) (cdr new))
(and (cdr new) (cdr old) (< (cdr new) (cdr old)))
)))
(defun byte-compile-arglist-signature-string (signature)
(cond ((null (cdr signature))
(format "%d+" (car signature)))
((= (car signature) (cdr signature))
(format "%d" (car signature)))
(t (format "%d-%d" (car signature) (cdr signature)))))
(defun byte-compile-callargs-warn (form)
(let* ((def (or (byte-compile-fdefinition (car form) nil)
(byte-compile-fdefinition (car form) t)))
(sig (if (and def (not (eq def t)))
(byte-compile-arglist-signature
(if (eq 'lambda (car-safe def))
(nth 1 def)
(if (byte-code-function-p def)
(aref def 0)
'(&rest def))))
(if (and (fboundp (car form))
(subrp (symbol-function (car form))))
(subr-arity (symbol-function (car form))))))
(ncall (length (cdr form))))
(if (and (cdr-safe sig)
(not (numberp (cdr sig))))
(setcdr sig nil))
(if sig
(when (or (< ncall (car sig))
(and (cdr sig) (> ncall (cdr sig))))
(byte-compile-set-symbol-position (car form))
(byte-compile-warn
"%s called with %d argument%s, but %s %s"
(car form) ncall
(if (= 1 ncall) "" "s")
(if (< ncall (car sig))
"requires"
"accepts only")
(byte-compile-arglist-signature-string sig))))
(byte-compile-format-warn form)
(or (and (or def (fboundp (car form))) (not (memq (car form) byte-compile-noruntime-functions)))
(eq (car form) byte-compile-current-form) (let ((cons (assq (car form) byte-compile-unresolved-functions))
(n (length (cdr form))))
(if cons
(or (memq n (cdr cons))
(setcdr cons (cons n (cdr cons))))
(push (list (car form) n)
byte-compile-unresolved-functions))))))
(defun byte-compile-format-warn (form)
"Warn if FORM is `format'-like with inconsistent args.
Applies if head of FORM is a symbol with non-nil property
`byte-compile-format-like' and first arg is a constant string.
Then check the number of format fields matches the number of
extra args."
(when (and (symbolp (car form))
(stringp (nth 1 form))
(get (car form) 'byte-compile-format-like))
(let ((nfields (with-temp-buffer
(insert (nth 1 form))
(goto-char 1)
(let ((n 0))
(while (re-search-forward "%." nil t)
(unless (eq ?% (char-after (1+ (match-beginning 0))))
(setq n (1+ n))))
n)))
(nargs (- (length form) 2)))
(unless (= nargs nfields)
(byte-compile-warn
"`%s' called with %d args to fill %d format field(s)" (car form)
nargs nfields)))))
(dolist (elt '(format message error))
(put elt 'byte-compile-format-like t))
(defun byte-compile-nogroup-warn (form)
(let ((keyword-args (cdr (cdr (cdr (cdr form)))))
(name (cadr form)))
(or (not (eq (car-safe name) 'quote))
(and (eq (car form) 'custom-declare-group)
(equal name ''emacs))
(plist-get keyword-args :group)
(not (and (consp name) (eq (car name) 'quote)))
(byte-compile-warn
"%s for `%s' fails to specify containing group"
(cdr (assq (car form)
'((custom-declare-group . defgroup)
(custom-declare-face . defface)
(custom-declare-variable . defcustom))))
(cadr name)))))
(defun byte-compile-arglist-warn (form macrop)
(let ((old (byte-compile-fdefinition (nth 1 form) macrop)))
(if (and old (not (eq old t)))
(let ((sig1 (byte-compile-arglist-signature
(if (eq 'lambda (car-safe old))
(nth 1 old)
(if (byte-code-function-p old)
(aref old 0)
'(&rest def)))))
(sig2 (byte-compile-arglist-signature (nth 2 form))))
(unless (byte-compile-arglist-signatures-congruent-p sig1 sig2)
(byte-compile-set-symbol-position (nth 1 form))
(byte-compile-warn
"%s %s used to take %s %s, now takes %s"
(if (eq (car form) 'defun) "function" "macro")
(nth 1 form)
(byte-compile-arglist-signature-string sig1)
(if (equal sig1 '(1 . 1)) "argument" "arguments")
(byte-compile-arglist-signature-string sig2))))
(let ((calls (assq (nth 1 form) byte-compile-unresolved-functions))
nums sig min max)
(if calls
(progn
(setq sig (byte-compile-arglist-signature (nth 2 form))
nums (sort (copy-sequence (cdr calls)) (function <))
min (car nums)
max (car (nreverse nums)))
(when (or (< min (car sig))
(and (cdr sig) (> max (cdr sig))))
(byte-compile-set-symbol-position (nth 1 form))
(byte-compile-warn
"%s being defined to take %s%s, but was previously called with %s"
(nth 1 form)
(byte-compile-arglist-signature-string sig)
(if (equal sig '(1 . 1)) " arg" " args")
(byte-compile-arglist-signature-string (cons min max))))
(setq byte-compile-unresolved-functions
(delq calls byte-compile-unresolved-functions)))))
)))
(defvar byte-compile-cl-functions nil
"List of functions defined in CL.")
(defun byte-compile-find-cl-functions ()
(unless byte-compile-cl-functions
(dolist (elt load-history)
(when (and (stringp (car elt))
(string-match "^cl\\>" (car elt)))
(setq byte-compile-cl-functions
(append byte-compile-cl-functions
(cdr elt)))))
(let ((tail byte-compile-cl-functions))
(while tail
(if (and (consp (car tail))
(eq (car (car tail)) 'autoload))
(setcar tail (cdr (car tail))))
(setq tail (cdr tail))))))
(defun byte-compile-cl-warn (form)
"Warn if FORM is a call of a function from the CL package."
(let ((func (car-safe form)))
(if (and byte-compile-cl-functions
(memq func byte-compile-cl-functions)
(not (memq func
'(cl-block-wrapper cl-block-throw
multiple-value-call nth-value
copy-seq first second rest endp cl-member
cl-defsubst-expand cl-struct-setf-expander
macroexpand cl-macroexpand-all
cl-compiling-file)))
(not (and (eq (get func 'byte-compile)
'cl-byte-compile-compiler-macro)
(string-match "\\`c[ad]+r\\'" (symbol-name func)))))
(byte-compile-warn "Function `%s' from cl package called at runtime"
func)))
form)
(defun byte-compile-print-syms (str1 strn syms)
(when syms
(byte-compile-set-symbol-position (car syms) t))
(cond ((and (cdr syms) (not noninteractive))
(let* ((str strn)
(L (length str))
s)
(while syms
(setq s (symbol-name (pop syms))
L (+ L (length s) 2))
(if (< L (1- fill-column))
(setq str (concat str " " s (and syms ",")))
(setq str (concat str "\n " s (and syms ","))
L (+ (length s) 4))))
(byte-compile-warn "%s" str)))
((cdr syms)
(byte-compile-warn "%s %s"
strn
(mapconcat #'symbol-name syms ", ")))
(syms
(byte-compile-warn str1 (car syms)))))
(defun byte-compile-warn-about-unresolved-functions ()
(when (memq 'unresolved byte-compile-warnings)
(let ((byte-compile-current-form :end)
(noruntime nil)
(unresolved nil))
(dolist (f byte-compile-unresolved-functions)
(setq f (car f))
(if (fboundp f) (push f noruntime) (push f unresolved)))
(byte-compile-print-syms
"the function `%s' might not be defined at runtime."
"the following functions might not be defined at runtime:"
noruntime)
(byte-compile-print-syms
"the function `%s' is not known to be defined."
"the following functions are not known to be defined:"
unresolved)))
nil)
(defsubst byte-compile-const-symbol-p (symbol &optional any-value)
"Non-nil if SYMBOL is constant.
If ANY-VALUE is nil, only return non-nil if the value of the symbol is the
symbol itself."
(or (memq symbol '(nil t))
(keywordp symbol)
(if any-value (memq symbol byte-compile-const-variables))))
(defmacro byte-compile-constp (form)
"Return non-nil if FORM is a constant."
`(cond ((consp ,form) (eq (car ,form) 'quote))
((not (symbolp ,form)))
((byte-compile-const-symbol-p ,form))))
(defmacro byte-compile-close-variables (&rest body)
(cons 'let
(cons '( (byte-compile-macro-environment
(copy-alist byte-compile-initial-macro-environment))
(byte-compile-function-environment nil)
(byte-compile-bound-variables nil)
(byte-compile-const-variables nil)
(byte-compile-free-references nil)
(byte-compile-free-assignments nil)
(byte-compile-verbose byte-compile-verbose)
(byte-optimize byte-optimize)
(byte-compile-compatibility byte-compile-compatibility)
(byte-compile-dynamic byte-compile-dynamic)
(byte-compile-dynamic-docstrings
byte-compile-dynamic-docstrings)
(byte-compile-warnings (if (eq byte-compile-warnings t)
byte-compile-warning-types
byte-compile-warnings))
)
body)))
(defmacro displaying-byte-compile-warnings (&rest body)
`(let* ((--displaying-byte-compile-warnings-fn (lambda () ,@body))
(warning-series-started
(and (markerp warning-series)
(eq (marker-buffer warning-series)
(get-buffer "*Compile-Log*")))))
(byte-compile-find-cl-functions)
(if (or (eq warning-series 'byte-compile-warning-series)
warning-series-started)
(let (tem)
(setq tem (byte-compile-log-file))
(unless warning-series-started
(setq warning-series (or tem 'byte-compile-warning-series)))
(if byte-compile-debug
(funcall --displaying-byte-compile-warnings-fn)
(condition-case error-info
(funcall --displaying-byte-compile-warnings-fn)
(error (byte-compile-report-error error-info)))))
(let ((warning-series
(or (byte-compile-log-file) 'byte-compile-warning-series)))
(if byte-compile-debug
(funcall --displaying-byte-compile-warnings-fn)
(condition-case error-info
(funcall --displaying-byte-compile-warnings-fn)
(error (byte-compile-report-error error-info))))))))
(defun byte-force-recompile (directory)
"Recompile every `.el' file in DIRECTORY that already has a `.elc' file.
Files in subdirectories of DIRECTORY are processed also."
(interactive "DByte force recompile (directory): ")
(byte-recompile-directory directory nil t))
(defun byte-recompile-directory (directory &optional arg force)
"Recompile every `.el' file in DIRECTORY that needs recompilation.
This is if a `.elc' file exists but is older than the `.el' file.
Files in subdirectories of DIRECTORY are processed also.
If the `.elc' file does not exist, normally this function *does not*
compile the corresponding `.el' file. However,
if ARG (the prefix argument) is 0, that means do compile all those files.
A nonzero ARG means ask the user, for each such `.el' file,
whether to compile it.
A nonzero ARG also means ask about each subdirectory before scanning it.
If the third argument FORCE is non-nil,
recompile every `.el' file that already has a `.elc' file."
(interactive "DByte recompile directory: \nP")
(if arg
(setq arg (prefix-numeric-value arg)))
(if noninteractive
nil
(save-some-buffers)
(force-mode-line-update))
(save-current-buffer
(set-buffer (get-buffer-create "*Compile-Log*"))
(setq default-directory (expand-file-name directory))
(unless (eq major-mode 'compilation-mode)
(compilation-mode))
(let ((directories (list (expand-file-name directory)))
(default-directory default-directory)
(skip-count 0)
(fail-count 0)
(file-count 0)
(dir-count 0)
last-dir)
(displaying-byte-compile-warnings
(while directories
(setq directory (car directories))
(message "Checking %s..." directory)
(let ((files (directory-files directory))
source dest)
(dolist (file files)
(setq source (expand-file-name file directory))
(if (and (not (member file '("RCS" "CVS")))
(not (eq ?\. (aref file 0)))
(file-directory-p source)
(not (file-symlink-p source)))
(when (or (null arg)
(eq 0 arg)
(y-or-n-p (concat "Check " source "? ")))
(setq directories
(nconc directories (list source))))
(if (and (string-match emacs-lisp-file-regexp source)
(file-readable-p source)
(not (auto-save-file-name-p source))
(setq dest (byte-compile-dest-file source))
(if (file-exists-p dest)
(or force (file-newer-than-file-p source dest))
(and arg
(or (eq 0 arg)
(y-or-n-p (concat "Compile " source "? "))))))
(progn (if (and noninteractive (not byte-compile-verbose))
(message "Compiling %s..." source))
(let ((res (byte-compile-file source)))
(cond ((eq res 'no-byte-compile)
(setq skip-count (1+ skip-count)))
((eq res t)
(setq file-count (1+ file-count)))
((eq res nil)
(setq fail-count (1+ fail-count)))))
(or noninteractive
(message "Checking %s..." directory))
(if (not (eq last-dir directory))
(setq last-dir directory
dir-count (1+ dir-count)))
)))))
(setq directories (cdr directories))))
(message "Done (Total of %d file%s compiled%s%s%s)"
file-count (if (= file-count 1) "" "s")
(if (> fail-count 0) (format ", %d failed" fail-count) "")
(if (> skip-count 0) (format ", %d skipped" skip-count) "")
(if (> dir-count 1) (format " in %d directories" dir-count) "")))))
(defvar no-byte-compile nil
"Non-nil to prevent byte-compiling of emacs-lisp code.
This is normally set in local file variables at the end of the elisp file:
;; Local Variables:\n;; no-byte-compile: t\n;; End: ")
(defun byte-compile-file (filename &optional load)
"Compile a file of Lisp code named FILENAME into a file of byte code.
The output file's name is generated by passing FILENAME to the
`byte-compile-dest-file' function (which see).
With prefix arg (noninteractively: 2nd arg), LOAD the file after compiling.
The value is non-nil if there were no errors, nil if errors."
(interactive
(let ((file buffer-file-name)
(file-name nil)
(file-dir nil))
(and file
(eq (cdr (assq 'major-mode (buffer-local-variables)))
'emacs-lisp-mode)
(setq file-name (file-name-nondirectory file)
file-dir (file-name-directory file)))
(list (read-file-name (if current-prefix-arg
"Byte compile and load file: "
"Byte compile file: ")
file-dir file-name nil)
current-prefix-arg)))
(setq filename (expand-file-name filename))
(or noninteractive
(let ((b (get-file-buffer (expand-file-name filename))))
(if (and b (buffer-modified-p b)
(y-or-n-p (format "Save buffer %s first? " (buffer-name b))))
(save-excursion (set-buffer b) (save-buffer)))))
(setq byte-compile-last-logged-file nil)
(let ((byte-compile-current-file filename)
(set-auto-coding-for-load t)
target-file input-buffer output-buffer
byte-compile-dest-file)
(setq target-file (byte-compile-dest-file filename))
(setq byte-compile-dest-file target-file)
(save-excursion
(setq input-buffer (get-buffer-create " *Compiler Input*"))
(set-buffer input-buffer)
(erase-buffer)
(setq buffer-file-coding-system nil)
(set-buffer-multibyte t)
(insert-file-contents filename)
(when (or (eq last-coding-system-used 'no-conversion)
(eq (coding-system-type last-coding-system-used) 5))
(set-buffer-multibyte nil))
(let ((buffer-file-name filename)
(default-major-mode 'emacs-lisp-mode)
(enable-local-variables :safe)
(enable-local-eval nil))
(normal-mode t)
(setq filename buffer-file-name))
(setq default-directory (file-name-directory filename)))
(if (with-current-buffer input-buffer no-byte-compile)
(progn
(when (file-exists-p target-file)
(message "%s deleted because of `no-byte-compile: %s'"
(file-relative-name target-file)
(buffer-local-value 'no-byte-compile input-buffer))
(condition-case nil (delete-file target-file) (error nil)))
'no-byte-compile)
(when byte-compile-verbose
(message "Compiling %s..." filename))
(setq byte-compiler-error-flag nil)
(setq output-buffer
(save-current-buffer
(byte-compile-from-buffer input-buffer filename)))
(if byte-compiler-error-flag
nil
(when byte-compile-verbose
(message "Compiling %s...done" filename))
(kill-buffer input-buffer)
(with-current-buffer output-buffer
(goto-char (point-max))
(insert "\n") (let ((vms-stmlf-recfm t))
(if (file-writable-p target-file)
(let ((coding-system-for-write 'no-conversion))
(if (memq system-type '(ms-dos 'windows-nt))
(setq buffer-file-type t))
(when (file-exists-p target-file)
(delete-file target-file))
(write-region (point-min) (point-max) target-file))
(signal 'file-error
(list "Opening output file"
(if (file-exists-p target-file)
"cannot overwrite file"
"directory not writable or nonexistent")
target-file))))
(kill-buffer (current-buffer)))
(if (and byte-compile-generate-call-tree
(or (eq t byte-compile-generate-call-tree)
(y-or-n-p (format "Report call tree for %s? " filename))))
(save-excursion
(display-call-tree filename)))
(if load
(load target-file))
t))))
(defun compile-defun (&optional arg)
"Compile and evaluate the current top-level form.
Print the result in the echo area.
With argument, insert value in current buffer after the form."
(interactive "P")
(save-excursion
(end-of-defun)
(beginning-of-defun)
(let* ((byte-compile-current-file nil)
(byte-compile-current-buffer (current-buffer))
(byte-compile-read-position (point))
(byte-compile-last-position byte-compile-read-position)
(byte-compile-last-warned-form 'nothing)
(value (eval
(let ((read-with-symbol-positions (current-buffer))
(read-symbol-positions-list nil))
(displaying-byte-compile-warnings
(byte-compile-sexp (read (current-buffer))))))))
(cond (arg
(message "Compiling from buffer... done.")
(prin1 value (current-buffer))
(insert "\n"))
((message "%s" (prin1-to-string value)))))))
(defun byte-compile-from-buffer (inbuffer &optional filename)
(let (outbuffer
(byte-compile-current-buffer inbuffer)
(byte-compile-read-position nil)
(byte-compile-last-position nil)
(float-output-format nil)
(case-fold-search nil)
(print-length nil)
(print-level nil)
(byte-compile-constants nil)
(byte-compile-variables nil)
(byte-compile-tag-number 0)
(byte-compile-depth 0)
(byte-compile-maxdepth 0)
(byte-compile-output nil)
(read-with-symbol-positions inbuffer)
(read-symbol-positions-list nil)
)
(byte-compile-close-variables
(save-excursion
(setq outbuffer
(set-buffer (get-buffer-create " *Compiler Output*")))
(set-buffer-multibyte t)
(erase-buffer)
(setq case-fold-search nil)
(setq overwrite-mode 'overwrite-mode-binary))
(displaying-byte-compile-warnings
(and filename (byte-compile-insert-header filename inbuffer outbuffer))
(save-excursion
(set-buffer inbuffer)
(goto-char 1)
(while (progn
(while (progn (skip-chars-forward " \t\n\^l")
(looking-at ";"))
(forward-line 1))
(not (eobp)))
(setq byte-compile-read-position (point)
byte-compile-last-position byte-compile-read-position)
(let ((form (read inbuffer)))
(byte-compile-file-form form)))
(byte-compile-flush-pending)
(setq byte-compile-last-position (point-max))
(byte-compile-warn-about-unresolved-functions)
(setq byte-compile-unresolved-functions nil))
(and filename (byte-compile-fix-header filename inbuffer outbuffer))))
outbuffer))
(defun byte-compile-fix-header (filename inbuffer outbuffer)
(with-current-buffer outbuffer
(when (< (point-max) (position-bytes (point-max)))
(when (byte-compile-version-cond byte-compile-compatibility)
(error "Version-18 compatibility not valid with multibyte characters"))
(goto-char (point-min))
(search-forward "\n;;; This file")
(beginning-of-line)
(narrow-to-region (point) (point-max))
(search-forward ";;;;;;;;;;")
(beginning-of-line)
(narrow-to-region (point-min) (point))
(let ((old-header-end (point))
delta)
(goto-char (point-min))
(delete-region (point) (progn (re-search-forward "^(")
(beginning-of-line)
(point)))
(insert ";;; This file contains multibyte non-ASCII characters\n"
";;; and therefore cannot be loaded into Emacs 19.\n")
(re-search-forward "19\\(\\.[0-9]+\\)")
(replace-match "20")
(re-search-forward "19\\(\\.[0-9]+\\)")
(replace-match "20")
(setq delta (- (point-max) old-header-end))
(goto-char (point-max))
(widen)
(delete-char delta)))))
(defun byte-compile-insert-header (filename inbuffer outbuffer)
(set-buffer inbuffer)
(let ((dynamic-docstrings byte-compile-dynamic-docstrings)
(dynamic byte-compile-dynamic))
(set-buffer outbuffer)
(goto-char 1)
(insert
";ELC"
(if (byte-compile-version-cond byte-compile-compatibility) 18 20)
"\000\000\000\n"
)
(insert ";;; Compiled by "
(or (and (boundp 'user-mail-address) user-mail-address)
(concat (user-login-name) "@" (system-name)))
" on "
(current-time-string) "\n;;; from file " filename "\n")
(insert ";;; in Emacs version " emacs-version "\n")
(insert ";;; "
(cond
((eq byte-optimize 'source) "with source-level optimization only")
((eq byte-optimize 'byte) "with byte-level optimization only")
(byte-optimize "with all optimizations")
(t "without optimization"))
(if (byte-compile-version-cond byte-compile-compatibility)
"; compiled with Emacs 18 compatibility.\n"
".\n"))
(if dynamic
(insert ";;; Function definitions are lazy-loaded.\n"))
(if (not (byte-compile-version-cond byte-compile-compatibility))
(let (intro-string minimum-version)
(if dynamic-docstrings
(setq intro-string
";;; This file uses dynamic docstrings, first added in Emacs 19.29.\n"
minimum-version "19.29")
(setq intro-string
";;; This file uses opcodes which do not exist in Emacs 18.\n"
minimum-version "19"))
(insert
"\n"
intro-string
"(if (and (boundp 'emacs-version)\n"
"\t (< (aref emacs-version (1- (length emacs-version))) ?A)\n"
"\t (or (and (boundp 'epoch::version) epoch::version)\n"
(format "\t (string-lessp emacs-version \"%s\")))\n"
minimum-version)
" (error \"`"
(substring (prin1-to-string (file-name-nondirectory filename))
1 -1)
(format "' was compiled for Emacs %s or later\"))\n\n"
minimum-version)
";;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;\n\n"))
(when dynamic-docstrings
(error "Version-18 compatibility doesn't support dynamic doc strings"))
(when byte-compile-dynamic
(error "Version-18 compatibility doesn't support dynamic byte code"))
(insert "(or (boundp 'current-load-list) (setq current-load-list nil))\n"
"\n"))))
(defun byte-compile-output-file-form (form)
(if (and (memq (car-safe form) '(defun defmacro defvar defconst autoload
custom-declare-variable))
(stringp (nth 3 form)))
(byte-compile-output-docform nil nil '("\n(" 3 ")") form nil
(memq (car form)
'(autoload custom-declare-variable)))
(let ((print-escape-newlines t)
(print-length nil)
(print-level nil)
(print-quoted t)
(print-gensym t)
(print-circle (not byte-compile-disable-print-circle)))
(princ "\n" outbuffer)
(prin1 form outbuffer)
nil)))
(defvar print-gensym-alist)
(defun byte-compile-output-docform (preface name info form specindex quoted)
"Print a form with a doc string. INFO is (prefix doc-index postfix).
If PREFACE and NAME are non-nil, print them too,
before INFO and the FORM but after the doc string itself.
If SPECINDEX is non-nil, it is the index in FORM
of the function bytecode string. In that case,
we output that argument and the following argument (the constants vector)
together, for lazy loading.
QUOTED says that we have to put a quote before the
list that represents a doc string reference.
`autoload' and `custom-declare-variable' need that."
(let ((dynamic-docstrings byte-compile-dynamic-docstrings))
(set-buffer
(prog1 (current-buffer)
(set-buffer outbuffer)
(let (position)
(and (>= (nth 1 info) 0)
dynamic-docstrings
(not byte-compile-compatibility)
(progn
(insert "\n")
(setq position
(byte-compile-output-as-comment
(nth (nth 1 info) form) nil))
(setq position (- (position-bytes position) (point-min) -1))
(if (and (stringp (nth (nth 1 info) form))
(> (length (nth (nth 1 info) form)) 0)
(eq (aref (nth (nth 1 info) form) 0) ?*))
(setq position (- position)))))
(if preface
(progn
(insert preface)
(prin1 name outbuffer)))
(insert (car info))
(let ((print-escape-newlines t)
(print-quoted t)
(print-gensym '(t))
(print-circle (not byte-compile-disable-print-circle))
print-gensym-alist (print-continuous-numbering t)
print-number-table
(index 0))
(prin1 (car form) outbuffer)
(while (setq form (cdr form))
(setq index (1+ index))
(insert " ")
(cond ((and (numberp specindex) (= index specindex)
(let (non-nil)
(dotimes (i (length print-number-table))
(if (aref print-number-table i)
(setq non-nil t)))
(not non-nil)))
(let ((position
(byte-compile-output-as-comment
(cons (car form) (nth 1 form))
t)))
(setq position (- (position-bytes position) (point-min) -1))
(princ (format "(#$ . %d) nil" position) outbuffer)
(setq form (cdr form))
(setq index (1+ index))))
((= index (nth 1 info))
(if position
(princ (format (if quoted "'(#$ . %d)" "(#$ . %d)")
position)
outbuffer)
(let ((print-escape-newlines nil))
(goto-char (prog1 (1+ (point))
(prin1 (car form) outbuffer)))
(insert "\\\n")
(goto-char (point-max)))))
(t
(prin1 (car form) outbuffer)))))
(insert (nth 2 info))))))
nil)
(defun byte-compile-keep-pending (form &optional handler)
(if (memq byte-optimize '(t source))
(setq form (byte-optimize-form form t)))
(if handler
(let ((for-effect t))
(and (memq (car-safe form) '(fset defalias))
(nthcdr 300 byte-compile-output)
(byte-compile-flush-pending))
(funcall handler form)
(if for-effect
(byte-compile-discard)))
(byte-compile-form form t))
nil)
(defun byte-compile-flush-pending ()
(if byte-compile-output
(let ((form (byte-compile-out-toplevel t 'file)))
(cond ((eq (car-safe form) 'progn)
(mapc 'byte-compile-output-file-form (cdr form)))
(form
(byte-compile-output-file-form form)))
(setq byte-compile-constants nil
byte-compile-variables nil
byte-compile-depth 0
byte-compile-maxdepth 0
byte-compile-output nil))))
(defun byte-compile-file-form (form)
(let ((byte-compile-current-form nil) handler)
(cond
((not (consp form))
(byte-compile-keep-pending form))
((and (symbolp (car form))
(setq handler (get (car form) 'byte-hunk-handler)))
(cond ((setq form (funcall handler form))
(byte-compile-flush-pending)
(byte-compile-output-file-form form))))
((eq form (setq form (macroexpand form byte-compile-macro-environment)))
(byte-compile-keep-pending form))
(t
(byte-compile-file-form form)))))
(put 'defsubst 'byte-hunk-handler 'byte-compile-file-form-defsubst)
(defun byte-compile-file-form-defsubst (form)
(when (assq (nth 1 form) byte-compile-unresolved-functions)
(setq byte-compile-current-form (nth 1 form))
(byte-compile-warn "defsubst `%s' was used before it was defined"
(nth 1 form)))
(byte-compile-file-form
(macroexpand form byte-compile-macro-environment))
nil)
(put 'autoload 'byte-hunk-handler 'byte-compile-file-form-autoload)
(defun byte-compile-file-form-autoload (form)
(and (let ((form form))
(while (if (setq form (cdr form)) (byte-compile-constp (car form))))
(null form)) (eval (nth 5 form)) (eval form)) (if (and (consp (nth 1 form))
(eq (car (nth 1 form)) 'quote)
(consp (cdr (nth 1 form)))
(symbolp (nth 1 (nth 1 form))))
(push (cons (nth 1 (nth 1 form))
(cons 'autoload (cdr (cdr form))))
byte-compile-function-environment))
(if (stringp (nth 3 form))
form
(byte-compile-keep-pending form 'byte-compile-normal-call)))
(put 'defvar 'byte-hunk-handler 'byte-compile-file-form-defvar)
(put 'defconst 'byte-hunk-handler 'byte-compile-file-form-defvar)
(defun byte-compile-file-form-defvar (form)
(if (null (nth 3 form))
(byte-compile-keep-pending form)
(when (memq 'free-vars byte-compile-warnings)
(push (nth 1 form) byte-compile-bound-variables)
(if (eq (car form) 'defconst)
(push (nth 1 form) byte-compile-const-variables)))
(cond ((consp (nth 2 form))
(setq form (copy-sequence form))
(setcar (cdr (cdr form))
(byte-compile-top-level (nth 2 form) nil 'file))))
form))
(put 'custom-declare-variable 'byte-hunk-handler
'byte-compile-file-form-custom-declare-variable)
(defun byte-compile-file-form-custom-declare-variable (form)
(when (memq 'callargs byte-compile-warnings)
(byte-compile-nogroup-warn form))
(when (memq 'free-vars byte-compile-warnings)
(push (nth 1 (nth 1 form)) byte-compile-bound-variables))
(let ((tail (nthcdr 4 form)))
(while tail
(if (and (consp (car tail))
(eq (car (car tail)) 'function)
(consp (nth 1 (car tail))))
(setcar tail (byte-compile-lambda (nth 1 (car tail))))
(if (and (consp (car tail))
(eq (car (car tail)) 'lambda))
(setcar tail (byte-compile-lambda (car tail)))))
(setq tail (cdr tail))))
form)
(put 'require 'byte-hunk-handler 'byte-compile-file-form-require)
(defun byte-compile-file-form-require (form)
(let ((old-load-list current-load-list)
(args (mapcar 'eval (cdr form))))
(apply 'require args)
(if (member (car args) '("cl" cl))
(setq byte-compile-warnings
(remq 'cl-functions byte-compile-warnings))))
(byte-compile-keep-pending form 'byte-compile-normal-call))
(put 'progn 'byte-hunk-handler 'byte-compile-file-form-progn)
(put 'prog1 'byte-hunk-handler 'byte-compile-file-form-progn)
(put 'prog2 'byte-hunk-handler 'byte-compile-file-form-progn)
(defun byte-compile-file-form-progn (form)
(mapc 'byte-compile-file-form (cdr form))
nil)
(put 'eval 'byte-hunk-handler 'byte-compile-file-form-eval)
(defun byte-compile-file-form-eval (form)
(if (eq (car-safe (nth 1 form)) 'quote)
(nth 1 (nth 1 form))
(byte-compile-keep-pending form)))
(put 'defun 'byte-hunk-handler 'byte-compile-file-form-defun)
(defun byte-compile-file-form-defun (form)
(byte-compile-file-form-defmumble form nil))
(put 'defmacro 'byte-hunk-handler 'byte-compile-file-form-defmacro)
(defun byte-compile-file-form-defmacro (form)
(byte-compile-file-form-defmumble form t))
(defun byte-compile-file-form-defmumble (form macrop)
(let* ((name (car (cdr form)))
(this-kind (if macrop 'byte-compile-macro-environment
'byte-compile-function-environment))
(that-kind (if macrop 'byte-compile-function-environment
'byte-compile-macro-environment))
(this-one (assq name (symbol-value this-kind)))
(that-one (assq name (symbol-value that-kind)))
(byte-compile-free-references nil)
(byte-compile-free-assignments nil))
(byte-compile-set-symbol-position name)
(if byte-compile-generate-call-tree
(or (assq name byte-compile-call-tree)
(setq byte-compile-call-tree
(cons (list name nil nil) byte-compile-call-tree))))
(setq byte-compile-current-form name) (if (memq 'redefine byte-compile-warnings)
(byte-compile-arglist-warn form macrop))
(if byte-compile-verbose
(message "Compiling %s... (%s)" (or filename "") (nth 1 form)))
(cond (that-one
(if (and (memq 'redefine byte-compile-warnings)
(not (assq (nth 1 form)
byte-compile-initial-macro-environment)))
(byte-compile-warn
"`%s' defined multiple times, as both function and macro"
(nth 1 form)))
(setcdr that-one nil))
(this-one
(when (and (memq 'redefine byte-compile-warnings)
(not (assq (nth 1 form)
byte-compile-initial-macro-environment)))
(byte-compile-warn "%s `%s' defined multiple times in this file"
(if macrop "macro" "function")
(nth 1 form))))
((and (fboundp name)
(eq (car-safe (symbol-function name))
(if macrop 'lambda 'macro)))
(when (memq 'redefine byte-compile-warnings)
(byte-compile-warn "%s `%s' being redefined as a %s"
(if macrop "function" "macro")
(nth 1 form)
(if macrop "macro" "function")))
(set this-kind
(cons (cons name nil) (symbol-value this-kind))))
)
(let ((body (nthcdr 3 form)))
(when (and (stringp (car body))
(symbolp (car-safe (cdr-safe body)))
(car-safe (cdr-safe body))
(stringp (car-safe (cdr-safe (cdr-safe body)))))
(byte-compile-set-symbol-position (nth 1 form))
(byte-compile-warn "probable `\"' without `\\' in doc string of %s"
(nth 1 form))))
(when macrop
(let ((tail (nthcdr 2 form)))
(when (stringp (car (cdr tail)))
(setq tail (cdr tail)))
(while (and (consp (car (cdr tail)))
(eq (car (car (cdr tail))) 'declare))
(let ((declaration (car (cdr tail))))
(setcdr tail (cdr (cdr tail)))
(prin1 `(if macro-declaration-function
(funcall macro-declaration-function
',name ',declaration))
outbuffer)))))
(let* ((new-one (byte-compile-lambda (nthcdr 2 form) t))
(code (byte-compile-byte-code-maker new-one)))
(if this-one
(setcdr this-one new-one)
(set this-kind
(cons (cons name new-one) (symbol-value this-kind))))
(if (and (stringp (nth 3 form))
(eq 'quote (car-safe code))
(eq 'lambda (car-safe (nth 1 code))))
(cons (car form)
(cons name (cdr (nth 1 code))))
(byte-compile-flush-pending)
(if (not (stringp (nth 3 form)))
(byte-compile-output-docform
(if (byte-compile-version-cond byte-compile-compatibility)
"\n(fset '" "\n(defalias '")
name
(cond ((atom code)
(if macrop '(" '(macro . #[" -1 "])") '(" #[" -1 "]")))
((eq (car code) 'quote)
(setq code new-one)
(if macrop '(" '(macro " -1 ")") '(" '(" -1 ")")))
((if macrop '(" (cons 'macro (" -1 "))") '(" (" -1 ")"))))
(append code nil)
(and (atom code) byte-compile-dynamic
1)
nil)
(byte-compile-output-docform
(if (byte-compile-version-cond byte-compile-compatibility)
"\n(fset '" "\n(defalias '")
name
(cond ((atom code)
(if macrop '(" '(macro . #[" 4 "])") '(" #[" 4 "]")))
((eq (car code) 'quote)
(setq code new-one)
(if macrop '(" '(macro " 2 ")") '(" '(" 2 ")")))
((if macrop '(" (cons 'macro (" 5 "))") '(" (" 5 ")"))))
(append code nil)
(and (atom code) byte-compile-dynamic
1)
nil))
(princ ")" outbuffer)
nil))))
(defun byte-compile-output-as-comment (exp quoted)
(let ((position (point)))
(set-buffer
(prog1 (current-buffer)
(set-buffer outbuffer)
(insert " ")
(if quoted
(prin1 exp outbuffer)
(princ exp outbuffer))
(goto-char position)
(while (search-forward "\^A" nil t)
(replace-match "\^A\^A" t t))
(goto-char position)
(while (search-forward "\000" nil t)
(replace-match "\^A0" t t))
(goto-char position)
(while (search-forward "\037" nil t)
(replace-match "\^A_" t t))
(goto-char (point-max))
(insert "\037")
(goto-char position)
(insert "#@" (format "%d" (- (position-bytes (point-max))
(position-bytes position))))
(setq position (point))
(goto-char (point-max))))
position))
(defun byte-compile (form)
"If FORM is a symbol, byte-compile its function definition.
If FORM is a lambda or a macro, byte-compile it as a function."
(displaying-byte-compile-warnings
(byte-compile-close-variables
(let* ((fun (if (symbolp form)
(and (fboundp form) (symbol-function form))
form))
(macro (eq (car-safe fun) 'macro)))
(if macro
(setq fun (cdr fun)))
(cond ((eq (car-safe fun) 'lambda)
(setq fun (if macro
(cons 'macro (byte-compile-lambda fun))
(byte-compile-lambda fun)))
(if (symbolp form)
(defalias form fun)
fun)))))))
(defun byte-compile-sexp (sexp)
"Compile and return SEXP."
(displaying-byte-compile-warnings
(byte-compile-close-variables
(byte-compile-top-level sexp))))
(defun byte-compile-byte-code-maker (fun)
(cond
((byte-compile-version-cond byte-compile-compatibility)
(list 'quote (byte-compile-byte-code-unmake fun)))
((atom fun) fun)
((let (tmp)
(if (and (setq tmp (assq 'byte-code (cdr-safe (cdr fun))))
(null (cdr (memq tmp fun))))
(let* ((interactive (assq 'interactive (cdr (cdr fun)))))
(nconc (list 'make-byte-code
(list 'quote (nth 1 fun)) (nth 1 tmp) (nth 2 tmp) (nth 3 tmp)) (cond ((stringp (nth 2 fun))
(list (nth 2 fun))) (interactive
(list nil)))
(cond (interactive
(list (if (or (null (nth 1 interactive))
(stringp (nth 1 interactive)))
(nth 1 interactive)
(list 'quote (nth 1 interactive))))))))
(list 'quote fun))))))
(defun byte-compile-byte-code-unmake (function)
(if (consp function)
function (setq function (append function nil)) (nconc (list 'lambda (nth 0 function))
(and (nth 4 function) (list (nth 4 function)))
(if (nthcdr 5 function)
(list (cons 'interactive (if (nth 5 function)
(nthcdr 5 function)))))
(list (list 'byte-code
(nth 1 function) (nth 2 function)
(nth 3 function))))))
(defun byte-compile-check-lambda-list (list)
"Check lambda-list LIST for errors."
(let (vars)
(while list
(let ((arg (car list)))
(when (symbolp arg)
(byte-compile-set-symbol-position arg))
(cond ((or (not (symbolp arg))
(byte-compile-const-symbol-p arg t))
(error "Invalid lambda variable %s" arg))
((eq arg '&rest)
(unless (cdr list)
(error "&rest without variable name"))
(when (cddr list)
(error "Garbage following &rest VAR in lambda-list")))
((eq arg '&optional)
(unless (cdr list)
(error "Variable name missing after &optional")))
((memq arg vars)
(byte-compile-warn "repeated variable %s in lambda-list" arg))
(t
(push arg vars))))
(setq list (cdr list)))))
(defun byte-compile-lambda (fun &optional add-lambda)
(if add-lambda
(setq fun (cons 'lambda fun))
(unless (eq 'lambda (car-safe fun))
(error "Not a lambda list: %S" fun))
(byte-compile-set-symbol-position 'lambda))
(byte-compile-check-lambda-list (nth 1 fun))
(let* ((arglist (nth 1 fun))
(byte-compile-bound-variables
(nconc (and (memq 'free-vars byte-compile-warnings)
(delq '&rest (delq '&optional (copy-sequence arglist))))
byte-compile-bound-variables))
(body (cdr (cdr fun)))
(doc (if (stringp (car body))
(prog1 (car body)
(if (cdr body)
(setq body (cdr body))))))
(int (assq 'interactive body)))
(when int
(byte-compile-set-symbol-position 'interactive)
(if (eq int (car body))
(setq body (cdr body)))
(cond ((consp (cdr int))
(if (cdr (cdr int))
(byte-compile-warn "malformed interactive spec: %s"
(prin1-to-string int)))
(let ((form (nth 1 int)))
(while (memq (car-safe form) '(let let* progn save-excursion))
(while (consp (cdr form))
(setq form (cdr form)))
(setq form (car form)))
(if (eq (car-safe form) 'list)
(byte-compile-top-level (nth 1 int))
(setq int (list 'interactive
(byte-compile-top-level (nth 1 int)))))))
((cdr int)
(byte-compile-warn "malformed interactive spec: %s"
(prin1-to-string int)))))
(let ((compiled (byte-compile-top-level (cons 'progn body) nil 'lambda)))
(if (and (eq 'byte-code (car-safe compiled))
(not (byte-compile-version-cond
byte-compile-compatibility)))
(apply 'make-byte-code
(append (list arglist)
(cdr compiled)
(if (or doc int)
(list doc))
(if int
(list (nth 1 int)))))
(setq compiled
(nconc (if int (list int))
(cond ((eq (car-safe compiled) 'progn) (cdr compiled))
(compiled (list compiled)))))
(nconc (list 'lambda arglist)
(if (or doc (stringp (car compiled)))
(cons doc (cond (compiled)
(body (list nil))))
compiled))))))
(defun byte-compile-constants-vector ()
(let* ((i -1)
(rest (nreverse byte-compile-variables)) (other (nreverse byte-compile-constants)) ret tmp
(limits '(5 63 255 65535)) limit)
(while (or rest other)
(setq limit (car limits))
(while (and rest (not (eq i limit)))
(if (setq tmp (assq (car (car rest)) ret))
(setcdr (car rest) (cdr tmp))
(setcdr (car rest) (setq i (1+ i)))
(setq ret (cons (car rest) ret)))
(setq rest (cdr rest)))
(setq limits (cdr limits)
rest (prog1 other
(setq other rest))))
(apply 'vector (nreverse (mapcar 'car ret)))))
(defun byte-compile-top-level (form &optional for-effect output-type)
(let ((byte-compile-constants nil)
(byte-compile-variables nil)
(byte-compile-tag-number 0)
(byte-compile-depth 0)
(byte-compile-maxdepth 0)
(byte-compile-output nil))
(if (memq byte-optimize '(t source))
(setq form (byte-optimize-form form for-effect)))
(while (and (eq (car-safe form) 'progn) (null (cdr (cdr form))))
(setq form (nth 1 form)))
(if (and (eq 'byte-code (car-safe form))
(not (memq byte-optimize '(t byte)))
(stringp (nth 1 form)) (vectorp (nth 2 form))
(natnump (nth 3 form)))
form
(byte-compile-form form for-effect)
(byte-compile-out-toplevel for-effect output-type))))
(defun byte-compile-out-toplevel (&optional for-effect output-type)
(if for-effect
(if (eq (car (car byte-compile-output)) 'byte-discard)
(setq byte-compile-output (cdr byte-compile-output))
(byte-compile-push-constant
(and (not (assq nil byte-compile-constants)) (let ((tmp (reverse byte-compile-constants)))
(while (and tmp (not (or (symbolp (caar tmp))
(numberp (caar tmp)))))
(setq tmp (cdr tmp)))
(caar tmp))))))
(byte-compile-out 'byte-return 0)
(setq byte-compile-output (nreverse byte-compile-output))
(if (memq byte-optimize '(t byte))
(setq byte-compile-output
(byte-optimize-lapcode byte-compile-output for-effect)))
(let (rest
(maycall (not (eq output-type 'lambda))) tmp body)
(cond
((or (eq output-type 'lambda)
(nthcdr (if (eq output-type 'file) 50 8) byte-compile-output)
(assq 'TAG byte-compile-output) (not (setq tmp (assq 'byte-return byte-compile-output)))
(progn
(setq rest (nreverse
(cdr (memq tmp (reverse byte-compile-output)))))
(while (cond
((memq (car (car rest)) '(byte-varref byte-constant))
(setq tmp (car (cdr (car rest))))
(if (if (eq (car (car rest)) 'byte-constant)
(or (consp tmp)
(and (symbolp tmp)
(not (byte-compile-const-symbol-p tmp)))))
(if maycall
(setq body (cons (list 'quote tmp) body)))
(setq body (cons tmp body))))
((and maycall
(null (nthcdr 3 rest))
(setq tmp (get (car (car rest)) 'byte-opcode-invert))
(or (null (cdr rest))
(and (memq output-type '(file progn t))
(cdr (cdr rest))
(eq (car (nth 1 rest)) 'byte-discard)
(progn (setq rest (cdr rest)) t))))
(setq maycall nil) (setq body (nreverse body))
(setq body (list
(if (and (eq tmp 'funcall)
(eq (car-safe (car body)) 'quote))
(cons (nth 1 (car body)) (cdr body))
(cons tmp body))))
(or (eq output-type 'file)
(not (delq nil (mapcar 'consp (cdr (car body))))))))
(setq rest (cdr rest)))
rest))
(let ((byte-compile-vector (byte-compile-constants-vector)))
(list 'byte-code (byte-compile-lapcode byte-compile-output)
byte-compile-vector byte-compile-maxdepth)))
((cdr body) (cons 'progn (nreverse body)))
((car body)))))
(defun byte-compile-top-level-body (body &optional for-effect)
(setq body (byte-compile-top-level (cons 'progn body) for-effect t))
(cond ((eq (car-safe body) 'progn)
(cdr body))
(body
(list body))))
(defun byte-compile-form (form &optional for-effect)
(setq form (macroexpand form byte-compile-macro-environment))
(cond ((not (consp form))
(cond ((or (not (symbolp form)) (byte-compile-const-symbol-p form))
(when (symbolp form)
(byte-compile-set-symbol-position form))
(byte-compile-constant form))
((and for-effect byte-compile-delete-errors)
(when (symbolp form)
(byte-compile-set-symbol-position form))
(setq for-effect nil))
(t (byte-compile-variable-ref 'byte-varref form))))
((symbolp (car form))
(let* ((fn (car form))
(handler (get fn 'byte-compile)))
(when (byte-compile-const-symbol-p fn)
(byte-compile-warn "`%s' called as a function" fn))
(and (memq 'interactive-only byte-compile-warnings)
(memq fn byte-compile-interactive-only-functions)
(byte-compile-warn "`%s' used from Lisp code\n\
That command is designed for interactive use only" fn))
(if (and handler
(or (not (memq handler '(cl-byte-compile-compiler-macro)))
(functionp handler))
(not (and (byte-compile-version-cond
byte-compile-compatibility)
(get (get fn 'byte-opcode) 'emacs19-opcode))))
(funcall handler form)
(when (memq 'callargs byte-compile-warnings)
(if (memq fn '(custom-declare-group custom-declare-variable custom-declare-face))
(byte-compile-nogroup-warn form))
(byte-compile-callargs-warn form))
(byte-compile-normal-call form))
(if (memq 'cl-functions byte-compile-warnings)
(byte-compile-cl-warn form))))
((and (or (byte-code-function-p (car form))
(eq (car-safe (car form)) 'lambda))
(not (eq form (setq form (byte-compile-unfold-lambda form)))))
(byte-compile-form form for-effect)
(setq for-effect nil))
((byte-compile-normal-call form)))
(if for-effect
(byte-compile-discard)))
(defun byte-compile-normal-call (form)
(if byte-compile-generate-call-tree
(byte-compile-annotate-call-tree form))
(byte-compile-push-constant (car form))
(mapc 'byte-compile-form (cdr form)) (byte-compile-out 'byte-call (length (cdr form))))
(defun byte-compile-variable-ref (base-op var)
(when (symbolp var)
(byte-compile-set-symbol-position var))
(if (or (not (symbolp var))
(byte-compile-const-symbol-p var (not (eq base-op 'byte-varref))))
(byte-compile-warn
(cond ((eq base-op 'byte-varbind) "attempt to let-bind %s `%s'")
((eq base-op 'byte-varset) "variable assignment to %s `%s'")
(t "variable reference to %s `%s'"))
(if (symbolp var) "constant" "nonvariable")
(prin1-to-string var))
(if (and (get var 'byte-obsolete-variable)
(memq 'obsolete byte-compile-warnings)
(not (eq var byte-compile-not-obsolete-var)))
(let* ((ob (get var 'byte-obsolete-variable))
(when (cdr ob)))
(byte-compile-warn "`%s' is an obsolete variable%s; %s" var
(if when (concat " (as of Emacs " when ")") "")
(if (stringp (car ob))
(car ob)
(format "use `%s' instead." (car ob))))))
(if (memq 'free-vars byte-compile-warnings)
(if (eq base-op 'byte-varbind)
(push var byte-compile-bound-variables)
(or (boundp var)
(memq var byte-compile-bound-variables)
(if (eq base-op 'byte-varset)
(or (memq var byte-compile-free-assignments)
(progn
(byte-compile-warn "assignment to free variable `%s'" var)
(push var byte-compile-free-assignments)))
(or (memq var byte-compile-free-references)
(progn
(byte-compile-warn "reference to free variable `%s'" var)
(push var byte-compile-free-references))))))))
(let ((tmp (assq var byte-compile-variables)))
(unless tmp
(setq tmp (list var))
(push tmp byte-compile-variables))
(byte-compile-out base-op tmp)))
(defmacro byte-compile-get-constant (const)
`(or (if (stringp ,const)
(let (result)
(dolist (elt byte-compile-constants)
(if (equal-including-properties (car elt) ,const)
(setq result elt)))
result)
(assq ,const byte-compile-constants))
(car (setq byte-compile-constants
(cons (list ,const) byte-compile-constants)))))
(defun byte-compile-constant (const)
(if for-effect
(setq for-effect nil)
(when (symbolp const)
(byte-compile-set-symbol-position const))
(byte-compile-out 'byte-constant (byte-compile-get-constant const))))
(defun byte-compile-push-constant (const)
(let ((for-effect nil))
(inline (byte-compile-constant const))))
(defmacro byte-defop-compiler (function &optional compile-handler)
(let (opcode)
(if (symbolp function)
(setq opcode (intern (concat "byte-" (symbol-name function))))
(setq opcode (car (cdr function))
function (car function)))
(let ((fnform
(list 'put (list 'quote function) ''byte-compile
(list 'quote
(or (cdr (assq compile-handler
'((0 . byte-compile-no-args)
(1 . byte-compile-one-arg)
(2 . byte-compile-two-args)
(3 . byte-compile-three-args)
(0-1 . byte-compile-zero-or-one-arg)
(1-2 . byte-compile-one-or-two-args)
(2-3 . byte-compile-two-or-three-args)
)))
compile-handler
(intern (concat "byte-compile-"
(symbol-name function))))))))
(if opcode
(list 'progn fnform
(list 'put (list 'quote function)
''byte-opcode (list 'quote opcode))
(list 'put (list 'quote opcode)
''byte-opcode-invert (list 'quote function)))
fnform))))
(defmacro byte-defop-compiler19 (function &optional compile-handler)
(if (and (byte-compile-single-version)
byte-compile-compatibility)
nil
(list 'progn
(list 'put
(list 'quote
(or (car (cdr-safe function))
(intern (concat "byte-"
(symbol-name (or (car-safe function) function))))))
''emacs19-opcode t)
(list 'byte-defop-compiler function compile-handler))))
(defmacro byte-defop-compiler-1 (function &optional compile-handler)
(list 'byte-defop-compiler (list function nil) compile-handler))
(put 'byte-call 'byte-opcode-invert 'funcall)
(put 'byte-list1 'byte-opcode-invert 'list)
(put 'byte-list2 'byte-opcode-invert 'list)
(put 'byte-list3 'byte-opcode-invert 'list)
(put 'byte-list4 'byte-opcode-invert 'list)
(put 'byte-listN 'byte-opcode-invert 'list)
(put 'byte-concat2 'byte-opcode-invert 'concat)
(put 'byte-concat3 'byte-opcode-invert 'concat)
(put 'byte-concat4 'byte-opcode-invert 'concat)
(put 'byte-concatN 'byte-opcode-invert 'concat)
(put 'byte-insertN 'byte-opcode-invert 'insert)
(byte-defop-compiler point 0)
(byte-defop-compiler point-max 0)
(byte-defop-compiler point-min 0)
(byte-defop-compiler following-char 0)
(byte-defop-compiler preceding-char 0)
(byte-defop-compiler current-column 0)
(byte-defop-compiler eolp 0)
(byte-defop-compiler eobp 0)
(byte-defop-compiler bolp 0)
(byte-defop-compiler bobp 0)
(byte-defop-compiler current-buffer 0)
(byte-defop-compiler interactive-p 0)
(byte-defop-compiler19 widen 0)
(byte-defop-compiler19 end-of-line 0-1)
(byte-defop-compiler19 forward-char 0-1)
(byte-defop-compiler19 forward-line 0-1)
(byte-defop-compiler symbolp 1)
(byte-defop-compiler consp 1)
(byte-defop-compiler stringp 1)
(byte-defop-compiler listp 1)
(byte-defop-compiler not 1)
(byte-defop-compiler (null byte-not) 1)
(byte-defop-compiler car 1)
(byte-defop-compiler cdr 1)
(byte-defop-compiler length 1)
(byte-defop-compiler symbol-value 1)
(byte-defop-compiler symbol-function 1)
(byte-defop-compiler (1+ byte-add1) 1)
(byte-defop-compiler (1- byte-sub1) 1)
(byte-defop-compiler goto-char 1)
(byte-defop-compiler char-after 0-1)
(byte-defop-compiler set-buffer 1)
(byte-defop-compiler19 forward-word 0-1)
(byte-defop-compiler19 char-syntax 1)
(byte-defop-compiler19 nreverse 1)
(byte-defop-compiler19 car-safe 1)
(byte-defop-compiler19 cdr-safe 1)
(byte-defop-compiler19 numberp 1)
(byte-defop-compiler19 integerp 1)
(byte-defop-compiler19 skip-chars-forward 1-2)
(byte-defop-compiler19 skip-chars-backward 1-2)
(byte-defop-compiler eq 2)
(byte-defop-compiler memq 2)
(byte-defop-compiler cons 2)
(byte-defop-compiler aref 2)
(byte-defop-compiler set 2)
(byte-defop-compiler (= byte-eqlsign) 2)
(byte-defop-compiler (< byte-lss) 2)
(byte-defop-compiler (> byte-gtr) 2)
(byte-defop-compiler (<= byte-leq) 2)
(byte-defop-compiler (>= byte-geq) 2)
(byte-defop-compiler get 2)
(byte-defop-compiler nth 2)
(byte-defop-compiler substring 2-3)
(byte-defop-compiler19 (move-marker byte-set-marker) 2-3)
(byte-defop-compiler19 set-marker 2-3)
(byte-defop-compiler19 match-beginning 1)
(byte-defop-compiler19 match-end 1)
(byte-defop-compiler19 upcase 1)
(byte-defop-compiler19 downcase 1)
(byte-defop-compiler19 string= 2)
(byte-defop-compiler19 string< 2)
(byte-defop-compiler19 (string-equal byte-string=) 2)
(byte-defop-compiler19 (string-lessp byte-string<) 2)
(byte-defop-compiler19 equal 2)
(byte-defop-compiler19 nthcdr 2)
(byte-defop-compiler19 elt 2)
(byte-defop-compiler19 member 2)
(byte-defop-compiler19 assq 2)
(byte-defop-compiler19 (rplaca byte-setcar) 2)
(byte-defop-compiler19 (rplacd byte-setcdr) 2)
(byte-defop-compiler19 setcar 2)
(byte-defop-compiler19 setcdr 2)
(byte-defop-compiler19 buffer-substring 2)
(byte-defop-compiler19 delete-region 2)
(byte-defop-compiler19 narrow-to-region 2)
(byte-defop-compiler19 (% byte-rem) 2)
(byte-defop-compiler aset 3)
(byte-defop-compiler max byte-compile-associative)
(byte-defop-compiler min byte-compile-associative)
(byte-defop-compiler (+ byte-plus) byte-compile-associative)
(byte-defop-compiler19 (* byte-mult) byte-compile-associative)
(byte-defop-compiler-1 interactive byte-compile-noop)
(defun byte-compile-subr-wrong-args (form n)
(byte-compile-set-symbol-position (car form))
(byte-compile-warn "`%s' called with %d arg%s, but requires %s"
(car form) (length (cdr form))
(if (= 1 (length (cdr form))) "" "s") n)
(byte-compile-normal-call form))
(defun byte-compile-no-args (form)
(if (not (= (length form) 1))
(byte-compile-subr-wrong-args form "none")
(byte-compile-out (get (car form) 'byte-opcode) 0)))
(defun byte-compile-one-arg (form)
(if (not (= (length form) 2))
(byte-compile-subr-wrong-args form 1)
(byte-compile-form (car (cdr form))) (byte-compile-out (get (car form) 'byte-opcode) 0)))
(defun byte-compile-two-args (form)
(if (not (= (length form) 3))
(byte-compile-subr-wrong-args form 2)
(byte-compile-form (car (cdr form))) (byte-compile-form (nth 2 form))
(byte-compile-out (get (car form) 'byte-opcode) 0)))
(defun byte-compile-three-args (form)
(if (not (= (length form) 4))
(byte-compile-subr-wrong-args form 3)
(byte-compile-form (car (cdr form))) (byte-compile-form (nth 2 form))
(byte-compile-form (nth 3 form))
(byte-compile-out (get (car form) 'byte-opcode) 0)))
(defun byte-compile-zero-or-one-arg (form)
(let ((len (length form)))
(cond ((= len 1) (byte-compile-one-arg (append form '(nil))))
((= len 2) (byte-compile-one-arg form))
(t (byte-compile-subr-wrong-args form "0-1")))))
(defun byte-compile-one-or-two-args (form)
(let ((len (length form)))
(cond ((= len 2) (byte-compile-two-args (append form '(nil))))
((= len 3) (byte-compile-two-args form))
(t (byte-compile-subr-wrong-args form "1-2")))))
(defun byte-compile-two-or-three-args (form)
(let ((len (length form)))
(cond ((= len 3) (byte-compile-three-args (append form '(nil))))
((= len 4) (byte-compile-three-args form))
(t (byte-compile-subr-wrong-args form "2-3")))))
(defun byte-compile-noop (form)
(byte-compile-constant nil))
(defun byte-compile-discard ()
(byte-compile-out 'byte-discard 0))
(defun byte-compile-associative (form)
(if (cdr form)
(let ((opcode (get (car form) 'byte-opcode))
(args (copy-sequence (cdr form))))
(byte-compile-form (car args))
(setq args (cdr args))
(or args (setq args '(0)
opcode (get '+ 'byte-opcode)))
(dolist (arg args)
(byte-compile-form arg)
(byte-compile-out opcode 0)))
(byte-compile-constant (eval form))))
(byte-defop-compiler char-before)
(byte-defop-compiler backward-char)
(byte-defop-compiler backward-word)
(byte-defop-compiler list)
(byte-defop-compiler concat)
(byte-defop-compiler fset)
(byte-defop-compiler (indent-to-column byte-indent-to) byte-compile-indent-to)
(byte-defop-compiler indent-to)
(byte-defop-compiler insert)
(byte-defop-compiler-1 function byte-compile-function-form)
(byte-defop-compiler-1 - byte-compile-minus)
(byte-defop-compiler19 (/ byte-quo) byte-compile-quo)
(byte-defop-compiler19 nconc)
(defun byte-compile-char-before (form)
(cond ((= 2 (length form))
(byte-compile-form (list 'char-after (if (numberp (nth 1 form))
(1- (nth 1 form))
`(1- ,(nth 1 form))))))
((= 1 (length form))
(byte-compile-form '(char-after (1- (point)))))
(t (byte-compile-subr-wrong-args form "0-1"))))
(defun byte-compile-backward-char (form)
(cond ((= 2 (length form))
(byte-compile-form (list 'forward-char (if (numberp (nth 1 form))
(- (nth 1 form))
`(- ,(nth 1 form))))))
((= 1 (length form))
(byte-compile-form '(forward-char -1)))
(t (byte-compile-subr-wrong-args form "0-1"))))
(defun byte-compile-backward-word (form)
(cond ((= 2 (length form))
(byte-compile-form (list 'forward-word (if (numberp (nth 1 form))
(- (nth 1 form))
`(- ,(nth 1 form))))))
((= 1 (length form))
(byte-compile-form '(forward-word -1)))
(t (byte-compile-subr-wrong-args form "0-1"))))
(defun byte-compile-list (form)
(let ((count (length (cdr form))))
(cond ((= count 0)
(byte-compile-constant nil))
((< count 5)
(mapc 'byte-compile-form (cdr form))
(byte-compile-out
(aref [byte-list1 byte-list2 byte-list3 byte-list4] (1- count)) 0))
((and (< count 256) (not (byte-compile-version-cond
byte-compile-compatibility)))
(mapc 'byte-compile-form (cdr form))
(byte-compile-out 'byte-listN count))
(t (byte-compile-normal-call form)))))
(defun byte-compile-concat (form)
(let ((count (length (cdr form))))
(cond ((and (< 1 count) (< count 5))
(mapc 'byte-compile-form (cdr form))
(byte-compile-out
(aref [byte-concat2 byte-concat3 byte-concat4] (- count 2))
0))
((= count 0)
(byte-compile-form ""))
((and (< count 256) (not (byte-compile-version-cond
byte-compile-compatibility)))
(mapc 'byte-compile-form (cdr form))
(byte-compile-out 'byte-concatN count))
((byte-compile-normal-call form)))))
(defun byte-compile-minus (form)
(if (null (setq form (cdr form)))
(byte-compile-constant 0)
(byte-compile-form (car form))
(if (cdr form)
(while (setq form (cdr form))
(byte-compile-form (car form))
(byte-compile-out 'byte-diff 0))
(byte-compile-out 'byte-negate 0))))
(defun byte-compile-quo (form)
(let ((len (length form)))
(cond ((<= len 2)
(byte-compile-subr-wrong-args form "2 or more"))
(t
(byte-compile-form (car (setq form (cdr form))))
(while (setq form (cdr form))
(byte-compile-form (car form))
(byte-compile-out 'byte-quo 0))))))
(defun byte-compile-nconc (form)
(let ((len (length form)))
(cond ((= len 1)
(byte-compile-constant nil))
((= len 2)
(byte-compile-form (nth 1 form)))
(t
(byte-compile-form (car (setq form (cdr form))))
(while (setq form (cdr form))
(byte-compile-form (car form))
(byte-compile-out 'byte-nconc 0))))))
(defun byte-compile-fset (form)
(let ((fn (nth 2 form))
body)
(if (and (eq (car-safe fn) 'quote)
(eq (car-safe (setq fn (nth 1 fn))) 'lambda))
(progn
(setq body (cdr (cdr fn)))
(if (stringp (car body)) (setq body (cdr body)))
(if (eq 'interactive (car-safe (car body))) (setq body (cdr body)))
(if (and (consp (car body))
(not (eq 'byte-code (car (car body)))))
(byte-compile-warn
"A quoted lambda form is the second argument of `fset'. This is probably
not what you want, as that lambda cannot be compiled. Consider using
the syntax (function (lambda (...) ...)) instead.")))))
(byte-compile-two-args form))
(defun byte-compile-funarg (form)
(byte-compile-normal-call
(let ((fn (nth 1 form)))
(if (and (eq (car-safe fn) 'quote)
(eq (car-safe (nth 1 fn)) 'lambda))
(cons (car form)
(cons (cons 'function (cdr fn))
(cdr (cdr form))))
form))))
(defun byte-compile-funarg-2 (form)
(byte-compile-normal-call
(let ((fn (nth 2 form)))
(if (and (eq (car-safe fn) 'quote)
(eq (car-safe (nth 1 fn)) 'lambda))
(cons (car form)
(cons (nth 1 form)
(cons (cons 'function (cdr fn))
(cdr (cdr (cdr form))))))
form))))
(defun byte-compile-function-form (form)
(byte-compile-constant
(cond ((symbolp (nth 1 form))
(nth 1 form))
((byte-compile-version-cond byte-compile-compatibility)
(byte-compile-byte-code-unmake (byte-compile-lambda (nth 1 form))))
((byte-compile-lambda (nth 1 form))))))
(defun byte-compile-indent-to (form)
(let ((len (length form)))
(cond ((= len 2)
(byte-compile-form (car (cdr form)))
(byte-compile-out 'byte-indent-to 0))
((= len 3)
(byte-compile-normal-call form))
(t
(byte-compile-subr-wrong-args form "1-2")))))
(defun byte-compile-insert (form)
(cond ((null (cdr form))
(byte-compile-constant nil))
((and (not (byte-compile-version-cond
byte-compile-compatibility))
(<= (length form) 256))
(mapc 'byte-compile-form (cdr form))
(if (cdr (cdr form))
(byte-compile-out 'byte-insertN (length (cdr form)))
(byte-compile-out 'byte-insert 0)))
((memq t (mapcar 'consp (cdr (cdr form))))
(byte-compile-normal-call form))
(t
(while (setq form (cdr form))
(byte-compile-form (car form))
(byte-compile-out 'byte-insert 0)
(if (cdr form)
(byte-compile-discard))))))
(byte-defop-compiler-1 setq)
(byte-defop-compiler-1 setq-default)
(byte-defop-compiler-1 quote)
(byte-defop-compiler-1 quote-form)
(defun byte-compile-setq (form)
(let ((args (cdr form)))
(if args
(while args
(byte-compile-form (car (cdr args)))
(or for-effect (cdr (cdr args))
(byte-compile-out 'byte-dup 0))
(byte-compile-variable-ref 'byte-varset (car args))
(setq args (cdr (cdr args))))
(byte-compile-form nil for-effect))
(setq for-effect nil)))
(defun byte-compile-setq-default (form)
(let ((args (cdr form))
setters)
(while args
(setq setters
(cons (list 'set-default (list 'quote (car args)) (car (cdr args)))
setters))
(setq args (cdr (cdr args))))
(byte-compile-form (cons 'progn (nreverse setters)))))
(defun byte-compile-quote (form)
(byte-compile-constant (car (cdr form))))
(defun byte-compile-quote-form (form)
(byte-compile-constant (byte-compile-top-level (nth 1 form))))
(defun byte-compile-body (body &optional for-effect)
(while (cdr body)
(byte-compile-form (car body) t)
(setq body (cdr body)))
(byte-compile-form (car body) for-effect))
(defsubst byte-compile-body-do-effect (body)
(byte-compile-body body for-effect)
(setq for-effect nil))
(defsubst byte-compile-form-do-effect (form)
(byte-compile-form form for-effect)
(setq for-effect nil))
(byte-defop-compiler-1 inline byte-compile-progn)
(byte-defop-compiler-1 progn)
(byte-defop-compiler-1 prog1)
(byte-defop-compiler-1 prog2)
(byte-defop-compiler-1 if)
(byte-defop-compiler-1 cond)
(byte-defop-compiler-1 and)
(byte-defop-compiler-1 or)
(byte-defop-compiler-1 while)
(byte-defop-compiler-1 funcall)
(byte-defop-compiler-1 apply byte-compile-funarg)
(byte-defop-compiler-1 mapcar byte-compile-funarg)
(byte-defop-compiler-1 mapatoms byte-compile-funarg)
(byte-defop-compiler-1 mapconcat byte-compile-funarg)
(byte-defop-compiler-1 mapc byte-compile-funarg)
(byte-defop-compiler-1 maphash byte-compile-funarg)
(byte-defop-compiler-1 map-char-table byte-compile-funarg)
(byte-defop-compiler-1 sort byte-compile-funarg-2)
(byte-defop-compiler-1 let)
(byte-defop-compiler-1 let*)
(defun byte-compile-progn (form)
(byte-compile-body-do-effect (cdr form)))
(defun byte-compile-prog1 (form)
(byte-compile-form-do-effect (car (cdr form)))
(byte-compile-body (cdr (cdr form)) t))
(defun byte-compile-prog2 (form)
(byte-compile-form (nth 1 form) t)
(byte-compile-form-do-effect (nth 2 form))
(byte-compile-body (cdr (cdr (cdr form))) t))
(defmacro byte-compile-goto-if (cond discard tag)
`(byte-compile-goto
(if ,cond
(if ,discard 'byte-goto-if-not-nil 'byte-goto-if-not-nil-else-pop)
(if ,discard 'byte-goto-if-nil 'byte-goto-if-nil-else-pop))
,tag))
(defmacro byte-compile-maybe-guarded (condition &rest body)
"Execute forms in BODY, potentially guarded by CONDITION.
CONDITION is a variable whose value is a test in an `if' or `cond'.
BODY is the code to compile first arm of the if or the body of the
cond clause. If CONDITION's value is of the form (fboundp 'foo)
or (boundp 'foo), the relevant warnings from BODY about foo's
being undefined will be suppressed.
If CONDITION's value is (not (featurep 'emacs)) or (featurep 'xemacs),
that suppresses all warnings during execution of BODY."
(declare (indent 1) (debug t))
`(let* ((fbound
(if (eq 'fboundp (car-safe ,condition))
(and (eq 'quote (car-safe (nth 1 ,condition)))
(not (assq (nth 1 (nth 1 ,condition)) byte-compile-unresolved-functions))
(nth 1 (nth 1 ,condition)))))
(bound (if (or (eq 'boundp (car-safe ,condition))
(eq 'default-boundp (car-safe ,condition)))
(and (eq 'quote (car-safe (nth 1 ,condition)))
(nth 1 (nth 1 ,condition)))))
(byte-compile-bound-variables
(if bound
(cons bound byte-compile-bound-variables)
byte-compile-bound-variables))
(byte-compile-warnings
(if (member ,condition '((featurep 'xemacs)
(not (featurep 'emacs))))
nil byte-compile-warnings)))
(unwind-protect
(progn ,@body)
(if fbound
(setq byte-compile-unresolved-functions
(delq (assq fbound byte-compile-unresolved-functions)
byte-compile-unresolved-functions))))))
(defun byte-compile-if (form)
(byte-compile-form (car (cdr form)))
(let ((clause (nth 1 form))
(donetag (byte-compile-make-tag)))
(if (null (nthcdr 3 form))
(progn
(byte-compile-goto-if nil for-effect donetag)
(byte-compile-maybe-guarded clause
(byte-compile-form (nth 2 form) for-effect))
(byte-compile-out-tag donetag))
(let ((elsetag (byte-compile-make-tag)))
(byte-compile-goto 'byte-goto-if-nil elsetag)
(byte-compile-maybe-guarded clause
(byte-compile-form (nth 2 form) for-effect))
(byte-compile-goto 'byte-goto donetag)
(byte-compile-out-tag elsetag)
(byte-compile-maybe-guarded (list 'not clause)
(byte-compile-body (cdr (cdr (cdr form))) for-effect))
(byte-compile-out-tag donetag))))
(setq for-effect nil))
(defun byte-compile-cond (clauses)
(let ((donetag (byte-compile-make-tag))
nexttag clause)
(while (setq clauses (cdr clauses))
(setq clause (car clauses))
(cond ((or (eq (car clause) t)
(and (eq (car-safe (car clause)) 'quote)
(car-safe (cdr-safe (car clause)))))
(setq clause (cons t clause)
clauses nil))
((cdr clauses)
(byte-compile-form (car clause))
(if (null (cdr clause))
(byte-compile-goto-if t for-effect donetag)
(setq nexttag (byte-compile-make-tag))
(byte-compile-goto 'byte-goto-if-nil nexttag)
(byte-compile-maybe-guarded (car clause)
(byte-compile-body (cdr clause) for-effect))
(byte-compile-goto 'byte-goto donetag)
(byte-compile-out-tag nexttag)))))
(let ((guard (car clause)))
(and (cdr clause) (not (eq guard t))
(progn (byte-compile-form guard)
(byte-compile-goto-if nil for-effect donetag)
(setq clause (cdr clause))))
(byte-compile-maybe-guarded guard
(byte-compile-body-do-effect clause)))
(byte-compile-out-tag donetag)))
(defun byte-compile-and (form)
(let ((failtag (byte-compile-make-tag))
(args (cdr form)))
(if (null args)
(byte-compile-form-do-effect t)
(byte-compile-and-recursion args failtag))))
(defun byte-compile-and-recursion (rest failtag)
(if (cdr rest)
(progn
(byte-compile-form (car rest))
(byte-compile-goto-if nil for-effect failtag)
(byte-compile-maybe-guarded (car rest)
(byte-compile-and-recursion (cdr rest) failtag)))
(byte-compile-form-do-effect (car rest))
(byte-compile-out-tag failtag)))
(defun byte-compile-or (form)
(let ((wintag (byte-compile-make-tag))
(args (cdr form)))
(if (null args)
(byte-compile-form-do-effect nil)
(byte-compile-or-recursion args wintag))))
(defun byte-compile-or-recursion (rest wintag)
(if (cdr rest)
(progn
(byte-compile-form (car rest))
(byte-compile-goto-if t for-effect wintag)
(byte-compile-maybe-guarded (list 'not (car rest))
(byte-compile-or-recursion (cdr rest) wintag)))
(byte-compile-form-do-effect (car rest))
(byte-compile-out-tag wintag)))
(defun byte-compile-while (form)
(let ((endtag (byte-compile-make-tag))
(looptag (byte-compile-make-tag)))
(byte-compile-out-tag looptag)
(byte-compile-form (car (cdr form)))
(byte-compile-goto-if nil for-effect endtag)
(byte-compile-body (cdr (cdr form)) t)
(byte-compile-goto 'byte-goto looptag)
(byte-compile-out-tag endtag)
(setq for-effect nil)))
(defun byte-compile-funcall (form)
(mapc 'byte-compile-form (cdr form))
(byte-compile-out 'byte-call (length (cdr (cdr form)))))
(defun byte-compile-let (form)
(let ((varlist (car (cdr form))))
(dolist (var varlist)
(if (consp var)
(byte-compile-form (car (cdr var)))
(byte-compile-push-constant nil))))
(let ((byte-compile-bound-variables byte-compile-bound-variables) (varlist (reverse (car (cdr form)))))
(dolist (var varlist)
(byte-compile-variable-ref 'byte-varbind (if (consp var) (car var) var)))
(byte-compile-body-do-effect (cdr (cdr form)))
(byte-compile-out 'byte-unbind (length (car (cdr form))))))
(defun byte-compile-let* (form)
(let ((byte-compile-bound-variables byte-compile-bound-variables) (varlist (copy-sequence (car (cdr form)))))
(dolist (var varlist)
(if (atom var)
(byte-compile-push-constant nil)
(byte-compile-form (car (cdr var)))
(setq var (car var)))
(byte-compile-variable-ref 'byte-varbind var))
(byte-compile-body-do-effect (cdr (cdr form)))
(byte-compile-out 'byte-unbind (length (car (cdr form))))))
(byte-defop-compiler-1 /= byte-compile-negated)
(byte-defop-compiler-1 atom byte-compile-negated)
(byte-defop-compiler-1 nlistp byte-compile-negated)
(put '/= 'byte-compile-negated-op '=)
(put 'atom 'byte-compile-negated-op 'consp)
(put 'nlistp 'byte-compile-negated-op 'listp)
(defun byte-compile-negated (form)
(byte-compile-form-do-effect (byte-compile-negation-optimizer form)))
(defun byte-compile-negation-optimizer (form)
(byte-compile-set-symbol-position (car form))
(list 'not
(cons (or (get (car form) 'byte-compile-negated-op)
(error
"Compiler error: `%s' has no `byte-compile-negated-op' property"
(car form)))
(cdr form))))
(byte-defop-compiler-1 catch)
(byte-defop-compiler-1 unwind-protect)
(byte-defop-compiler-1 condition-case)
(byte-defop-compiler-1 save-excursion)
(byte-defop-compiler-1 save-current-buffer)
(byte-defop-compiler-1 save-restriction)
(byte-defop-compiler-1 save-window-excursion)
(byte-defop-compiler-1 with-output-to-temp-buffer)
(byte-defop-compiler-1 track-mouse)
(defun byte-compile-catch (form)
(byte-compile-form (car (cdr form)))
(byte-compile-push-constant
(byte-compile-top-level (cons 'progn (cdr (cdr form))) for-effect))
(byte-compile-out 'byte-catch 0))
(defun byte-compile-unwind-protect (form)
(byte-compile-push-constant
(byte-compile-top-level-body (cdr (cdr form)) t))
(byte-compile-out 'byte-unwind-protect 0)
(byte-compile-form-do-effect (car (cdr form)))
(byte-compile-out 'byte-unbind 1))
(defun byte-compile-track-mouse (form)
(byte-compile-form
`(funcall '(lambda nil
(track-mouse ,@(byte-compile-top-level-body (cdr form)))))))
(defun byte-compile-condition-case (form)
(let* ((var (nth 1 form))
(byte-compile-bound-variables
(if var (cons var byte-compile-bound-variables)
byte-compile-bound-variables)))
(byte-compile-set-symbol-position 'condition-case)
(unless (symbolp var)
(byte-compile-warn
"`%s' is not a variable-name or nil (in condition-case)" var))
(byte-compile-push-constant var)
(byte-compile-push-constant (byte-compile-top-level
(nth 2 form) for-effect))
(let ((clauses (cdr (cdr (cdr form))))
compiled-clauses)
(while clauses
(let* ((clause (car clauses))
(condition (car clause)))
(cond ((not (or (symbolp condition)
(and (listp condition)
(let ((syms condition) (ok t))
(while syms
(if (not (symbolp (car syms)))
(setq ok nil))
(setq syms (cdr syms)))
ok))))
(byte-compile-warn
"`%s' is not a condition name or list of such (in condition-case)"
(prin1-to-string condition)))
)
(setq compiled-clauses
(cons (cons condition
(byte-compile-top-level-body
(cdr clause) for-effect))
compiled-clauses)))
(setq clauses (cdr clauses)))
(byte-compile-push-constant (nreverse compiled-clauses)))
(byte-compile-out 'byte-condition-case 0)))
(defun byte-compile-save-excursion (form)
(byte-compile-out 'byte-save-excursion 0)
(byte-compile-body-do-effect (cdr form))
(byte-compile-out 'byte-unbind 1))
(defun byte-compile-save-restriction (form)
(byte-compile-out 'byte-save-restriction 0)
(byte-compile-body-do-effect (cdr form))
(byte-compile-out 'byte-unbind 1))
(defun byte-compile-save-current-buffer (form)
(byte-compile-out 'byte-save-current-buffer 0)
(byte-compile-body-do-effect (cdr form))
(byte-compile-out 'byte-unbind 1))
(defun byte-compile-save-window-excursion (form)
(byte-compile-push-constant
(byte-compile-top-level-body (cdr form) for-effect))
(byte-compile-out 'byte-save-window-excursion 0))
(defun byte-compile-with-output-to-temp-buffer (form)
(byte-compile-form (car (cdr form)))
(byte-compile-out 'byte-temp-output-buffer-setup 0)
(byte-compile-body (cdr (cdr form)))
(byte-compile-out 'byte-temp-output-buffer-show 0))
(byte-defop-compiler-1 defun)
(byte-defop-compiler-1 defmacro)
(byte-defop-compiler-1 defvar)
(byte-defop-compiler-1 defconst byte-compile-defvar)
(byte-defop-compiler-1 autoload)
(byte-defop-compiler-1 lambda byte-compile-lambda-form)
(defun byte-compile-defun (form)
(if (symbolp (car form))
(byte-compile-set-symbol-position (car form))
(byte-compile-set-symbol-position 'defun)
(error "defun name must be a symbol, not %s" (car form)))
(if (byte-compile-version-cond byte-compile-compatibility)
(progn
(byte-compile-two-args (list 'fset
(list 'quote (nth 1 form))
(byte-compile-byte-code-maker
(byte-compile-lambda (cdr (cdr form)) t))))
(byte-compile-discard))
(byte-compile-form
(list 'defalias
(list 'quote (nth 1 form))
(byte-compile-byte-code-maker
(byte-compile-lambda (cdr (cdr form)) t)))
t))
(byte-compile-constant (nth 1 form)))
(defun byte-compile-defmacro (form)
(byte-compile-body-do-effect
(list (list 'fset (list 'quote (nth 1 form))
(let ((code (byte-compile-byte-code-maker
(byte-compile-lambda (cdr (cdr form)) t))))
(if (eq (car-safe code) 'make-byte-code)
(list 'cons ''macro code)
(list 'quote (cons 'macro (eval code))))))
(list 'quote (nth 1 form)))))
(defun byte-compile-defvar (form)
(let ((fun (nth 0 form))
(var (nth 1 form))
(value (nth 2 form))
(string (nth 3 form)))
(byte-compile-set-symbol-position fun)
(when (or (> (length form) 4)
(and (eq fun 'defconst) (null (cddr form))))
(let ((ncall (length (cdr form))))
(byte-compile-warn
"`%s' called with %d argument%s, but %s %s"
fun ncall
(if (= 1 ncall) "" "s")
(if (< ncall 2) "requires" "accepts only")
"2-3")))
(when (memq 'free-vars byte-compile-warnings)
(push var byte-compile-bound-variables)
(if (eq fun 'defconst)
(push var byte-compile-const-variables)))
(byte-compile-body-do-effect
(list
(when (and (cddr form) (null byte-compile-current-form))
`(push ',var current-load-list))
(when (> (length form) 3)
(when (and string (not (stringp string)))
(byte-compile-warn "third arg to `%s %s' is not a string: %s"
fun var string))
`(put ',var 'variable-documentation ,string))
(if (cddr form) (let ((byte-compile-not-obsolete-var var))
(if (eq fun 'defconst)
(let ((tmp (make-symbol "defconst-tmp-var")))
`(funcall '(lambda (,tmp) (defconst ,var ,tmp))
,value))
`(if (not (default-boundp ',var)) (setq-default ,var ,value))))
(when (eq fun 'defconst)
`(eval ',form)))
`',var))))
(defun byte-compile-autoload (form)
(byte-compile-set-symbol-position 'autoload)
(and (byte-compile-constp (nth 1 form))
(byte-compile-constp (nth 5 form))
(eval (nth 5 form)) (not (fboundp (eval (nth 1 form))))
(byte-compile-warn
"The compiler ignores `autoload' except at top level. You should
probably put the autoload of the macro `%s' at top-level."
(eval (nth 1 form))))
(byte-compile-normal-call form))
(defun byte-compile-lambda-form (form)
(byte-compile-set-symbol-position 'lambda)
(error "`lambda' used as function name is invalid"))
(put 'defalias 'byte-hunk-handler 'byte-compile-file-form-defalias)
(defun byte-compile-file-form-defalias (form)
(if (and (consp (cdr form)) (consp (nth 1 form))
(eq (car (nth 1 form)) 'quote)
(consp (cdr (nth 1 form)))
(symbolp (nth 1 (nth 1 form))))
(let ((constant
(and (consp (nthcdr 2 form))
(consp (nth 2 form))
(eq (car (nth 2 form)) 'quote)
(consp (cdr (nth 2 form)))
(symbolp (nth 1 (nth 2 form))))))
(byte-compile-defalias-warn (nth 1 (nth 1 form)))
(push (cons (nth 1 (nth 1 form))
(if constant (nth 1 (nth 2 form)) t))
byte-compile-function-environment)))
(byte-compile-keep-pending form)
nil)
(defun byte-compile-defalias-warn (new)
(let ((calls (assq new byte-compile-unresolved-functions)))
(if calls
(setq byte-compile-unresolved-functions
(delq calls byte-compile-unresolved-functions)))))
(byte-defop-compiler-1 with-no-warnings byte-compile-no-warnings)
(defun byte-compile-no-warnings (form)
(let (byte-compile-warnings)
(byte-compile-form (cons 'progn (cdr form)))))
(byte-defop-compiler-1 make-variable-buffer-local byte-compile-make-variable-buffer-local)
(defun byte-compile-make-variable-buffer-local (form)
(if (eq (car-safe (car-safe (cdr-safe form))) 'quote)
(byte-compile-warn
"`make-variable-buffer-local' should be called at toplevel"))
(byte-compile-normal-call form))
(put 'make-variable-buffer-local
'byte-hunk-handler 'byte-compile-form-make-variable-buffer-local)
(defun byte-compile-form-make-variable-buffer-local (form)
(byte-compile-keep-pending form 'byte-compile-normal-call))
(defun byte-compile-make-tag ()
(list 'TAG (setq byte-compile-tag-number (1+ byte-compile-tag-number))))
(defun byte-compile-out-tag (tag)
(setq byte-compile-output (cons tag byte-compile-output))
(if (cdr (cdr tag))
(progn
(and byte-compile-depth
(not (= (cdr (cdr tag)) byte-compile-depth))
(error "Compiler bug: depth conflict at tag %d" (car (cdr tag))))
(setq byte-compile-depth (cdr (cdr tag))))
(setcdr (cdr tag) byte-compile-depth)))
(defun byte-compile-goto (opcode tag)
(push (cons opcode tag) byte-compile-output)
(setcdr (cdr tag) (if (memq opcode byte-goto-always-pop-ops)
(1- byte-compile-depth)
byte-compile-depth))
(setq byte-compile-depth (and (not (eq opcode 'byte-goto))
(1- byte-compile-depth))))
(defun byte-compile-out (opcode offset)
(push (cons opcode offset) byte-compile-output)
(cond ((eq opcode 'byte-call)
(setq byte-compile-depth (- byte-compile-depth offset)))
((eq opcode 'byte-return)
(setq byte-compile-depth nil))
(t
(setq byte-compile-depth (+ byte-compile-depth
(or (aref byte-stack+-info
(symbol-value opcode))
(- (1- offset))))
byte-compile-maxdepth (max byte-compile-depth
byte-compile-maxdepth))))
)
(defun byte-compile-annotate-call-tree (form)
(let (entry)
(if (setq entry (assq (car form) byte-compile-call-tree))
(or (memq byte-compile-current-form (nth 1 entry)) (setcar (cdr entry)
(cons byte-compile-current-form (nth 1 entry))))
(setq byte-compile-call-tree
(cons (list (car form) (list byte-compile-current-form) nil)
byte-compile-call-tree)))
(if (setq entry (assq byte-compile-current-form byte-compile-call-tree))
(or (memq (car form) (nth 2 entry)) (setcar (cdr (cdr entry))
(cons (car form) (nth 2 entry))))
(setq byte-compile-call-tree
(cons (list byte-compile-current-form nil (list (car form)))
byte-compile-call-tree)))
))
(defun display-call-tree (&optional filename)
"Display a call graph of a specified file.
This lists which functions have been called, what functions called
them, and what functions they call. The list includes all functions
whose definitions have been compiled in this Emacs session, as well as
all functions called by those functions.
The call graph does not include macros, inline functions, or
primitives that the byte-code interpreter knows about directly \(eq,
cons, etc.\).
The call tree also lists those functions which are not known to be called
\(that is, to which no calls have been compiled\), and which cannot be
invoked interactively."
(interactive)
(message "Generating call tree...")
(with-output-to-temp-buffer "*Call-Tree*"
(set-buffer "*Call-Tree*")
(erase-buffer)
(message "Generating call tree... (sorting on %s)"
byte-compile-call-tree-sort)
(insert "Call tree for "
(cond ((null byte-compile-current-file) (or filename "???"))
((stringp byte-compile-current-file)
byte-compile-current-file)
(t (buffer-name byte-compile-current-file)))
" sorted on "
(prin1-to-string byte-compile-call-tree-sort)
":\n\n")
(if byte-compile-call-tree-sort
(setq byte-compile-call-tree
(sort byte-compile-call-tree
(cond ((eq byte-compile-call-tree-sort 'callers)
(function (lambda (x y) (< (length (nth 1 x))
(length (nth 1 y))))))
((eq byte-compile-call-tree-sort 'calls)
(function (lambda (x y) (< (length (nth 2 x))
(length (nth 2 y))))))
((eq byte-compile-call-tree-sort 'calls+callers)
(function (lambda (x y) (< (+ (length (nth 1 x))
(length (nth 2 x)))
(+ (length (nth 1 y))
(length (nth 2 y)))))))
((eq byte-compile-call-tree-sort 'name)
(function (lambda (x y) (string< (car x)
(car y)))))
(t (error "`byte-compile-call-tree-sort': `%s' - unknown sort mode"
byte-compile-call-tree-sort))))))
(message "Generating call tree...")
(let ((rest byte-compile-call-tree)
(b (current-buffer))
f p
callers calls)
(while rest
(prin1 (car (car rest)) b)
(setq callers (nth 1 (car rest))
calls (nth 2 (car rest)))
(insert "\t"
(cond ((not (fboundp (setq f (car (car rest)))))
(if (null f)
" <top level>" " <not defined>"))
((subrp (setq f (symbol-function f)))
" <subr>")
((symbolp f)
(format " ==> %s" f))
((byte-code-function-p f)
"<compiled function>")
((not (consp f))
"<malformed function>")
((eq 'macro (car f))
(if (or (byte-code-function-p (cdr f))
(assq 'byte-code (cdr (cdr (cdr f)))))
" <compiled macro>"
" <macro>"))
((assq 'byte-code (cdr (cdr f)))
"<compiled lambda>")
((eq 'lambda (car f))
"<function>")
(t "???"))
(format " (%d callers + %d calls = %d)"
(length callers)
(length calls)
(+ (length callers) (length calls)))
"\n")
(if callers
(progn
(insert " called by:\n")
(setq p (point))
(insert " " (if (car callers)
(mapconcat 'symbol-name callers ", ")
"<top level>"))
(let ((fill-prefix " "))
(fill-region-as-paragraph p (point)))
(unless (= 0 (current-column))
(insert "\n"))))
(if calls
(progn
(insert " calls:\n")
(setq p (point))
(insert " " (mapconcat 'symbol-name calls ", "))
(let ((fill-prefix " "))
(fill-region-as-paragraph p (point)))
(unless (= 0 (current-column))
(insert "\n"))))
(setq rest (cdr rest)))
(message "Generating call tree...(finding uncalled functions...)")
(setq rest byte-compile-call-tree)
(let ((uncalled nil))
(while rest
(or (nth 1 (car rest))
(null (setq f (car (car rest))))
(functionp (byte-compile-fdefinition f t))
(commandp (byte-compile-fdefinition f nil))
(setq uncalled (cons f uncalled)))
(setq rest (cdr rest)))
(if uncalled
(let ((fill-prefix " "))
(insert "Noninteractive functions not known to be called:\n ")
(setq p (point))
(insert (mapconcat 'symbol-name (nreverse uncalled) ", "))
(fill-region-as-paragraph p (point)))))
)
(message "Generating call tree...done.")
))
(defun batch-byte-compile-if-not-done ()
"Like `byte-compile-file' but doesn't recompile if already up to date.
Use this from the command line, with `-batch';
it won't work in an interactive Emacs."
(batch-byte-compile t))
(defun batch-byte-compile (&optional noforce)
"Run `byte-compile-file' on the files remaining on the command line.
Use this from the command line, with `-batch';
it won't work in an interactive Emacs.
Each file is processed even if an error occurred previously.
For example, invoke \"emacs -batch -f batch-byte-compile $emacs/ ~/*.el\".
If NOFORCE is non-nil, don't recompile a file that seems to be
already up-to-date."
(defvar command-line-args-left) (if (not noninteractive)
(error "`batch-byte-compile' is to be used only with -batch"))
(let ((error nil))
(while command-line-args-left
(if (file-directory-p (expand-file-name (car command-line-args-left)))
(let ((files (directory-files (car command-line-args-left)))
source dest)
(dolist (file files)
(if (and (string-match emacs-lisp-file-regexp file)
(not (auto-save-file-name-p file))
(setq source (expand-file-name file
(car command-line-args-left)))
(setq dest (byte-compile-dest-file source))
(file-exists-p dest)
(file-newer-than-file-p source dest))
(if (null (batch-byte-compile-file source))
(setq error t)))))
(if (or (not noforce)
(let* ((source (car command-line-args-left))
(dest (byte-compile-dest-file source)))
(or (not (file-exists-p dest))
(file-newer-than-file-p source dest))))
(if (null (batch-byte-compile-file (car command-line-args-left)))
(setq error t))))
(setq command-line-args-left (cdr command-line-args-left)))
(kill-emacs (if error 1 0))))
(defun batch-byte-compile-file (file)
(if debug-on-error
(byte-compile-file file)
(condition-case err
(byte-compile-file file)
(file-error
(message (if (cdr err)
">>Error occurred processing %s: %s (%s)"
">>Error occurred processing %s: %s")
file
(get (car err) 'error-message)
(prin1-to-string (cdr err)))
(let ((destfile (byte-compile-dest-file file)))
(if (file-exists-p destfile)
(delete-file destfile)))
nil)
(error
(message (if (cdr err)
">>Error occurred processing %s: %s (%s)"
">>Error occurred processing %s: %s")
file
(get (car err) 'error-message)
(prin1-to-string (cdr err)))
nil))))
(defun batch-byte-recompile-directory (&optional arg)
"Run `byte-recompile-directory' on the dirs remaining on the command line.
Must be used only with `-batch', and kills Emacs on completion.
For example, invoke `emacs -batch -f batch-byte-recompile-directory .'.
Optional argument ARG is passed as second argument ARG to
`batch-recompile-directory'; see there for its possible values
and corresponding effects."
(defvar command-line-args-left) (if (not noninteractive)
(error "batch-byte-recompile-directory is to be used only with -batch"))
(or command-line-args-left
(setq command-line-args-left '(".")))
(while command-line-args-left
(byte-recompile-directory (car command-line-args-left) arg)
(setq command-line-args-left (cdr command-line-args-left)))
(kill-emacs 0))
(provide 'byte-compile)
(provide 'bytecomp)
(defvar byte-code-meter)
(defun byte-compile-report-ops ()
(with-output-to-temp-buffer "*Meter*"
(set-buffer "*Meter*")
(let ((i 0) n op off)
(while (< i 256)
(setq n (aref (aref byte-code-meter 0) i)
off nil)
(if t (progn
(setq op i)
(setq off nil)
(cond ((< op byte-nth)
(setq off (logand op 7))
(setq op (logand op 248)))
((>= op byte-constant)
(setq off (- op byte-constant)
op byte-constant)))
(setq op (aref byte-code-vector op))
(insert (format "%-4d" i))
(insert (symbol-name op))
(if off (insert " [" (int-to-string off) "]"))
(indent-to 40)
(insert (int-to-string n) "\n")))
(setq i (1+ i))))))
(eval-when-compile
(or (byte-code-function-p (symbol-function 'byte-compile-form))
(assq 'byte-code (symbol-function 'byte-compile-form))
(let ((byte-optimize nil) (byte-compile-warnings nil))
(mapcar (lambda (x)
(or noninteractive (message "compiling %s..." x))
(byte-compile x)
(or noninteractive (message "compiling %s...done" x)))
'(byte-compile-normal-call
byte-compile-form
byte-compile-body
byte-compile-top-level
byte-compile-out-toplevel
byte-compile-constant
byte-compile-variable-ref))))
nil)
(run-hooks 'bytecomp-load-hook)