summaryrefslogtreecommitdiff
path: root/lisp/emacs-lisp
diff options
context:
space:
mode:
authorJim Blandy <jimb@redhat.com>1992-07-10 22:06:47 +0000
committerJim Blandy <jimb@redhat.com>1992-07-10 22:06:47 +0000
commit1c393159a24ae0c5891c7f6367db53459f76d2e0 (patch)
tree9dac588dc566f724c3e5ba5825a6f960e92488a3 /lisp/emacs-lisp
parent06b1a5ef11625ecec550c540b4fbbe5730fac312 (diff)
downloademacs-1c393159a24ae0c5891c7f6367db53459f76d2e0.tar.gz
emacs-1c393159a24ae0c5891c7f6367db53459f76d2e0.tar.bz2
emacs-1c393159a24ae0c5891c7f6367db53459f76d2e0.zip
Initial revision
Diffstat (limited to 'lisp/emacs-lisp')
-rw-r--r--lisp/emacs-lisp/byte-opt.el1730
-rw-r--r--lisp/emacs-lisp/bytecomp.el3000
-rw-r--r--lisp/emacs-lisp/disass.el224
3 files changed, 4954 insertions, 0 deletions
diff --git a/lisp/emacs-lisp/byte-opt.el b/lisp/emacs-lisp/byte-opt.el
new file mode 100644
index 00000000000..b595d6699d9
--- /dev/null
+++ b/lisp/emacs-lisp/byte-opt.el
@@ -0,0 +1,1730 @@
+;;; -*- Mode:Emacs-Lisp -*-
+;;; The optimization passes of the emacs-lisp byte compiler.
+
+;; By Jamie Zawinski <jwz@lucid.com> and Hallvard Furuseth <hbf@ulrik.uio.no>.
+;; last modified 29-oct-91.
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 1, or (at your option)
+;; any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs; see the file COPYING. If not, write to
+;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
+
+;;; ========================================================================
+;;; "No matter how hard you try, you can't make a racehorse out of a pig.
+;;; you can, however, make a faster pig."
+;;;
+;;; Or, to put it another way, the emacs byte compiler is a VW Bug. This code
+;;; makes it be a VW Bug with fuel injection and a turbocharger... You're
+;;; still not going to make it go faster than 70 mph, but it might be easier
+;;; to get it there.
+;;;
+
+;;; TO DO:
+;;;
+;;; (apply '(lambda (x &rest y) ...) 1 (foo))
+;;;
+;;; collapse common subexpressions
+;;;
+;;; maintain a list of functions known not to access any global variables
+;;; (actually, give them a 'dynamically-safe property) and then
+;;; (let ( v1 v2 ... vM vN ) <...dynamically-safe...> ) ==>
+;;; (let ( v1 v2 ... vM ) vN <...dynamically-safe...> )
+;;; by recursing on this, we might be able to eliminate the entire let.
+;;; However certain variables should never have their bindings optimized
+;;; away, because they affect everything.
+;;; (put 'debug-on-error 'binding-is-magic t)
+;;; (put 'debug-on-abort 'binding-is-magic t)
+;;; (put 'inhibit-quit 'binding-is-magic t)
+;;; (put 'quit-flag 'binding-is-magic t)
+;;; others?
+;;;
+;;; Simple defsubsts often produce forms like
+;;; (let ((v1 (f1)) (v2 (f2)) ...)
+;;; (FN v1 v2 ...))
+;;; It would be nice if we could optimize this to
+;;; (FN (f1) (f2) ...)
+;;; but we can't unless FN is dynamically-safe (it might be dynamically
+;;; referring to the bindings that the lambda arglist established.)
+;;; One of the uncountable lossages introduced by dynamic scope...
+;;;
+;;; Maybe there should be a control-structure that says "turn on
+;;; fast-and-loose type-assumptive optimizations here." Then when
+;;; we see a form like (car foo) we can from then on assume that
+;;; the variable foo is of type cons, and optimize based on that.
+;;; But, this won't win much because of (you guessed it) dynamic
+;;; scope. Anything down the stack could change the value.
+;;;
+;;; It would be nice if redundant sequences could be factored out as well,
+;;; when they are known to have no side-effects:
+;;; (list (+ a b c) (+ a b c)) --> a b add c add dup list-2
+;;; but beware of traps like
+;;; (cons (list x y) (list x y))
+;;;
+;;; Tail-recursion elimination is not really possible in elisp. Tail-recursion
+;;; elimination is almost always impossible when all variables have dynamic
+;;; scope, but given that the "return" byteop requires the binding stack to be
+;;; empty (rather than emptying it itself), there can be no truly tail-
+;;; recursive elisp functions that take any arguments or make any bindings.
+;;;
+;;; Here is an example of an elisp function which could safely be
+;;; byte-compiled tail-recursively:
+;;;
+;;; (defun tail-map (fn list)
+;;; (cond (list
+;;; (funcall fn (car list))
+;;; (tail-map fn (cdr list)))))
+;;;
+;;; However, if there was even a single let-binding around the COND,
+;;; it could not be byte-compiled, because there would be an "unbind"
+;;; byte-op between the final "call" and "return." Adding a
+;;; Bunbind_all byteop would fix this.
+;;;
+;;; (defun foo (x y z) ... (foo a b c))
+;;; ... (const foo) (varref a) (varref b) (varref c) (call 3) END: (return)
+;;; ... (varref a) (varbind x) (varref b) (varbind y) (varref c) (varbind z) (goto 0) END: (unbind-all) (return)
+;;; ... (varref a) (varset x) (varref b) (varset y) (varref c) (varset z) (goto 0) END: (return)
+;;;
+;;; this also can be considered tail recursion:
+;;;
+;;; ... (const foo) (varref a) (call 1) (goto X) ... X: (return)
+;;; could generalize this by doing the optimization
+;;; (goto X) ... X: (return) --> (return)
+;;;
+;;; But this doesn't solve all of the problems: although by doing tail-
+;;; recursion elimination in this way, the call-stack does not grow, the
+;;; binding-stack would grow with each recursive step, and would eventually
+;;; overflow. I don't believe there is any way around this without lexical
+;;; scope.
+;;;
+;;; Wouldn't it be nice if elisp had lexical scope.
+;;;
+;;; Idea: the form (lexical-scope) in a file means that the file may be
+;;; compiled lexically. This proclamation is file-local. Then, within
+;;; that file, "let" would establish lexical bindings, and "let-dynamic"
+;;; would do things the old way. (Or we could use CL "declare" forms.)
+;;; We'd have to notice defvars and defconsts, since those variables should
+;;; always be dynamic, and attempting to do a lexical binding of them
+;;; should simply do a dynamic binding instead.
+;;; But! We need to know about variables that were not necessarily defvarred
+;;; in the file being compiled (doing a boundp check isn't good enough.)
+;;; Fdefvar() would have to be modified to add something to the plist.
+;;;
+;;; A major disadvantage of this scheme is that the interpreter and compiler
+;;; would have different semantics for files compiled with (dynamic-scope).
+;;; Since this would be a file-local optimization, there would be no way to
+;;; modify the interpreter to obey this (unless the loader was hacked
+;;; in some grody way, but that's a really bad idea.)
+;;;
+;;; Really the Right Thing is to make lexical scope the default across
+;;; the board, in the interpreter and compiler, and just FIX all of
+;;; the code that relies on dynamic scope of non-defvarred variables.
+
+
+(require 'byte-compile "bytecomp")
+
+(or (fboundp 'byte-compile-lapcode)
+ (error "loading bytecomp got the wrong version of the compiler."))
+
+(defun byte-compile-log-lap-1 (format &rest args)
+ (if (aref byte-code-vector 0)
+ (error "The old version of the disassembler is loaded. Reload new-bytecomp as well."))
+ (byte-compile-log-1
+ (apply 'format format
+ (let (c a)
+ (mapcar '(lambda (arg)
+ (if (not (consp arg))
+ (if (and (symbolp arg)
+ (string-match "^byte-" (symbol-name arg)))
+ (intern (substring (symbol-name arg) 5))
+ arg)
+ (if (integerp (setq c (car arg)))
+ (error "non-symbolic byte-op %s" c))
+ (if (eq c 'TAG)
+ (setq c arg)
+ (setq a (cond ((memq c byte-goto-ops)
+ (car (cdr (cdr arg))))
+ ((memq c byte-constref-ops)
+ (car (cdr arg)))
+ (t (cdr arg))))
+ (setq c (symbol-name c))
+ (if (string-match "^byte-." c)
+ (setq c (intern (substring c 5)))))
+ (if (eq c 'constant) (setq c 'const))
+ (if (and (eq (cdr arg) 0)
+ (not (memq c '(unbind call const))))
+ c
+ (format "(%s %s)" c a))))
+ args)))))
+
+(defmacro byte-compile-log-lap (format-string &rest args)
+ (list 'and
+ '(memq byte-optimize-log '(t byte))
+ (cons 'byte-compile-log-lap-1
+ (cons format-string args))))
+
+
+;;; byte-compile optimizers to support inlining
+
+(put 'inline 'byte-optimizer 'byte-optimize-inline-handler)
+
+(defun byte-optimize-inline-handler (form)
+ "byte-optimize-handler for the `inline' special-form."
+ (cons 'progn
+ (mapcar
+ '(lambda (sexp)
+ (let ((fn (car-safe sexp)))
+ (if (and (symbolp fn)
+ (or (cdr (assq fn byte-compile-function-environment))
+ (and (fboundp fn)
+ (not (or (cdr (assq fn byte-compile-macro-environment))
+ (and (consp (setq fn (symbol-function fn)))
+ (eq (car fn) 'macro))
+ (subrp fn))))))
+ (byte-compile-inline-expand sexp)
+ sexp)))
+ (cdr form))))
+
+
+(defun byte-inline-lapcode (lap)
+ "splice the given lap code into the current instruction stream.
+If it has any labels in it, you're responsible for making sure there
+are no collisions, and that byte-compile-tag-number is reasonable
+after this is spliced in. the provided list is destroyed."
+ (setq byte-compile-output (nconc (nreverse lap) byte-compile-output)))
+
+
+(defun byte-compile-inline-expand (form)
+ (let* ((name (car form))
+ (fn (or (cdr (assq name byte-compile-function-environment))
+ (and (fboundp name) (symbol-function name)))))
+ (if (null fn)
+ (progn
+ (byte-compile-warn "attempt to inline %s before it was defined" name)
+ form)
+ ;; else
+ (if (and (consp fn) (eq (car fn) 'autoload))
+ (load (nth 1 fn)))
+ (if (and (consp fn) (eq (car fn) 'autoload))
+ (error "file \"%s\" didn't define \"%s\"" (nth 1 fn) name))
+ (if (symbolp fn)
+ (byte-compile-inline-expand (cons fn (cdr form)))
+ (if (compiled-function-p fn)
+ (cons (list 'lambda (aref fn 0)
+ (list 'byte-code (aref fn 1) (aref fn 2) (aref fn 3)))
+ (cdr form))
+ (if (not (eq (car fn) 'lambda)) (error "%s is not a lambda" name))
+ (cons fn (cdr form)))))))
+
+;;; ((lambda ...) ...)
+;;;
+(defun byte-compile-unfold-lambda (form &optional name)
+ (or name (setq name "anonymous lambda"))
+ (let ((lambda (car form))
+ (values (cdr form)))
+ (if (compiled-function-p lambda)
+ (setq lambda (list 'lambda (nth 0 form)
+ (list 'byte-code
+ (nth 1 form) (nth 2 form) (nth 3 form)))))
+ (let ((arglist (nth 1 lambda))
+ (body (cdr (cdr lambda)))
+ optionalp restp
+ bindings)
+ (if (and (stringp (car body)) (cdr body))
+ (setq body (cdr body)))
+ (if (and (consp (car body)) (eq 'interactive (car (car body))))
+ (setq body (cdr body)))
+ (while arglist
+ (cond ((eq (car arglist) '&optional)
+ ;; ok, I'll let this slide because funcall_lambda() does...
+ ;; (if optionalp (error "multiple &optional keywords in %s" name))
+ (if restp (error "&optional found after &rest in %s" name))
+ (if (null (cdr arglist))
+ (error "nothing after &optional in %s" name))
+ (setq optionalp t))
+ ((eq (car arglist) '&rest)
+ ;; ...but it is by no stretch of the imagination a reasonable
+ ;; thing that funcall_lambda() allows (&rest x y) and
+ ;; (&rest x &optional y) in arglists.
+ (if (null (cdr arglist))
+ (error "nothing after &rest in %s" name))
+ (if (cdr (cdr arglist))
+ (error "multiple vars after &rest in %s" name))
+ (setq restp t))
+ (restp
+ (setq bindings (cons (list (car arglist)
+ (and values (cons 'list values)))
+ bindings)
+ values nil))
+ ((and (not optionalp) (null values))
+ (byte-compile-warn "attempt to open-code %s with too few arguments" name)
+ (setq arglist nil values 'too-few))
+ (t
+ (setq bindings (cons (list (car arglist) (car values))
+ bindings)
+ values (cdr values))))
+ (setq arglist (cdr arglist)))
+ (if values
+ (progn
+ (or (eq values 'too-few)
+ (byte-compile-warn
+ "attempt to open-code %s with too many arguments" name))
+ form)
+ (let ((newform
+ (if bindings
+ (cons 'let (cons (nreverse bindings) body))
+ (cons 'progn body))))
+ (byte-compile-log " %s\t==>\t%s" form newform)
+ newform)))))
+
+
+;;; implementing source-level optimizers
+
+(defun byte-optimize-form-code-walker (form for-effect)
+ ;;
+ ;; For normal function calls, We can just mapcar the optimizer the cdr. But
+ ;; we need to have special knowledge of the syntax of the special forms
+ ;; like let and defun (that's why they're special forms :-). (Actually,
+ ;; the important aspect is that they are subrs that don't evaluate all of
+ ;; their args.)
+ ;;
+ (let ((fn (car-safe form))
+ tmp)
+ (cond ((not (consp form))
+ (if (not (and for-effect
+ (or byte-compile-delete-errors
+ (not (symbolp form))
+ (eq form t))))
+ form))
+ ((eq fn 'quote)
+ (if (cdr (cdr form))
+ (byte-compile-warn "malformed quote form: %s"
+ (prin1-to-string form)))
+ ;; map (quote nil) to nil to simplify optimizer logic.
+ ;; map quoted constants to nil if for-effect (just because).
+ (and (nth 1 form)
+ (not for-effect)
+ form))
+ ((or (compiled-function-p fn)
+ (eq 'lambda (car-safe fn)))
+ (byte-compile-unfold-lambda form))
+ ((memq fn '(let let*))
+ ;; recursively enter the optimizer for the bindings and body
+ ;; of a let or let*. This for depth-firstness: forms that
+ ;; are more deeply nested are optimized first.
+ (cons fn
+ (cons
+ (mapcar '(lambda (binding)
+ (if (symbolp binding)
+ binding
+ (if (cdr (cdr binding))
+ (byte-compile-warn "malformed let binding: %s"
+ (prin1-to-string binding)))
+ (list (car binding)
+ (byte-optimize-form (nth 1 binding) nil))))
+ (nth 1 form))
+ (byte-optimize-body (cdr (cdr form)) for-effect))))
+ ((eq fn 'cond)
+ (cons fn
+ (mapcar '(lambda (clause)
+ (if (consp clause)
+ (cons
+ (byte-optimize-form (car clause) nil)
+ (byte-optimize-body (cdr clause) for-effect))
+ (byte-compile-warn "malformed cond form: %s"
+ (prin1-to-string clause))
+ clause))
+ (cdr form))))
+ ((eq fn 'progn)
+ ;; as an extra added bonus, this simplifies (progn <x>) --> <x>
+ (if (cdr (cdr form))
+ (progn
+ (setq tmp (byte-optimize-body (cdr form) for-effect))
+ (if (cdr tmp) (cons 'progn tmp) (car tmp)))
+ (byte-optimize-form (nth 1 form) for-effect)))
+ ((eq fn 'prog1)
+ (if (cdr (cdr form))
+ (cons 'prog1
+ (cons (byte-optimize-form (nth 1 form) for-effect)
+ (byte-optimize-body (cdr (cdr form)) t)))
+ (byte-optimize-form (nth 1 form) for-effect)))
+ ((eq fn 'prog2)
+ (cons 'prog2
+ (cons (byte-optimize-form (nth 1 form) t)
+ (cons (byte-optimize-form (nth 2 form) for-effect)
+ (byte-optimize-body (cdr (cdr (cdr form))) t)))))
+
+ ((memq fn '(save-excursion save-restriction))
+ ;; those subrs which have an implicit progn; it's not quite good
+ ;; enough to treat these like normal function calls.
+ ;; This can turn (save-excursion ...) into (save-excursion) which
+ ;; will be optimized away in the lap-optimize pass.
+ (cons fn (byte-optimize-body (cdr form) for-effect)))
+
+ ((eq fn 'with-output-to-temp-buffer)
+ ;; this is just like the above, except for the first argument.
+ (cons fn
+ (cons
+ (byte-optimize-form (nth 1 form) nil)
+ (byte-optimize-body (cdr (cdr form)) for-effect))))
+
+ ((eq fn 'if)
+ (cons fn
+ (cons (byte-optimize-form (nth 1 form) nil)
+ (cons
+ (byte-optimize-form (nth 2 form) for-effect)
+ (byte-optimize-body (nthcdr 3 form) for-effect)))))
+
+ ((memq fn '(and or)) ; remember, and/or are control structures.
+ ;; take forms off the back until we can't any more.
+ ;; In the future it could concievably be a problem that the
+ ;; subexpressions of these forms are optimized in the reverse
+ ;; order, but it's ok for now.
+ (if for-effect
+ (let ((backwards (reverse (cdr form))))
+ (while (and backwards
+ (null (setcar backwards
+ (byte-optimize-form (car backwards)
+ for-effect))))
+ (setq backwards (cdr backwards)))
+ (if (and (cdr form) (null backwards))
+ (byte-compile-log
+ " all subforms of %s called for effect; deleted" form))
+ (and backwards
+ (cons fn (nreverse backwards))))
+ (cons fn (mapcar 'byte-optimize-form (cdr form)))))
+
+ ((eq fn 'interactive)
+ (byte-compile-warn "misplaced interactive spec: %s"
+ (prin1-to-string form))
+ nil)
+
+ ((memq fn '(defun defmacro function
+ condition-case save-window-excursion))
+ ;; These forms are compiled as constants or by breaking out
+ ;; all the subexpressions and compiling them separately.
+ form)
+
+ ((eq fn 'unwind-protect)
+ ;; the "protected" part of an unwind-protect is compiled (and thus
+ ;; optimized) as a top-level form, so don't do it here. But the
+ ;; non-protected part has the same for-effect status as the
+ ;; unwind-protect itself. (The protected part is always for effect,
+ ;; but that isn't handled properly yet.)
+ (cons fn
+ (cons (byte-optimize-form (nth 1 form) for-effect)
+ (cdr (cdr form)))))
+
+ ((eq fn 'catch)
+ ;; the body of a catch is compiled (and thus optimized) as a
+ ;; top-level form, so don't do it here. The tag is never
+ ;; for-effect. The body should have the same for-effect status
+ ;; as the catch form itself, but that isn't handled properly yet.
+ (cons fn
+ (cons (byte-optimize-form (nth 1 form) nil)
+ (cdr (cdr form)))))
+
+ ;; If optimization is on, this is the only place that macros are
+ ;; expanded. If optimization is off, then macroexpansion happens
+ ;; in byte-compile-form. Otherwise, the macros are already expanded
+ ;; by the time that is reached.
+ ((not (eq form
+ (setq form (macroexpand form
+ byte-compile-macro-environment))))
+ (byte-optimize-form form for-effect))
+
+ ((not (symbolp fn))
+ (or (eq 'mocklisp (car-safe fn)) ; ha!
+ (byte-compile-warn "%s is a malformed function"
+ (prin1-to-string fn)))
+ form)
+
+ ((and for-effect (setq tmp (get fn 'side-effect-free))
+ (or byte-compile-delete-errors
+ (eq tmp 'error-free)
+ (progn
+ (byte-compile-warn "%s called for effect"
+ (prin1-to-string form))
+ nil)))
+ (byte-compile-log " %s called for effect; deleted" fn)
+ ;; appending a nil here might not be necessary, but it can't hurt.
+ (byte-optimize-form
+ (cons 'progn (append (cdr form) '(nil))) t))
+
+ (t
+ ;; Otherwise, no args can be considered to be for-effect,
+ ;; even if the called function is for-effect, because we
+ ;; don't know anything about that function.
+ (cons fn (mapcar 'byte-optimize-form (cdr form)))))))
+
+
+(defun byte-optimize-form (form &optional for-effect)
+ "The source-level pass of the optimizer."
+ ;;
+ ;; First, optimize all sub-forms of this one.
+ (setq form (byte-optimize-form-code-walker form for-effect))
+ ;;
+ ;; after optimizing all subforms, optimize this form until it doesn't
+ ;; optimize any further. This means that some forms will be passed through
+ ;; the optimizer many times, but that's necessary to make the for-effect
+ ;; processing do as much as possible.
+ ;;
+ (let (opt new)
+ (if (and (consp form)
+ (symbolp (car form))
+ (or (and for-effect
+ ;; we don't have any of these yet, but we might.
+ (setq opt (get (car form) 'byte-for-effect-optimizer)))
+ (setq opt (get (car form) 'byte-optimizer)))
+ (not (eq form (setq new (funcall opt form)))))
+ (progn
+;; (if (equal form new) (error "bogus optimizer -- %s" opt))
+ (byte-compile-log " %s\t==>\t%s" form new)
+ (setq new (byte-optimize-form new for-effect))
+ new)
+ form)))
+
+
+(defun byte-optimize-body (forms all-for-effect)
+ ;; optimize the cdr of a progn or implicit progn; all forms is a list of
+ ;; forms, all but the last of which are optimized with the assumption that
+ ;; they are being called for effect. the last is for-effect as well if
+ ;; all-for-effect is true. returns a new list of forms.
+ (let ((rest forms)
+ (result nil)
+ fe new)
+ (while rest
+ (setq fe (or all-for-effect (cdr rest)))
+ (setq new (and (car rest) (byte-optimize-form (car rest) fe)))
+ (if (or new (not fe))
+ (setq result (cons new result)))
+ (setq rest (cdr rest)))
+ (nreverse result)))
+
+
+;;; some source-level optimizers
+;;;
+;;; when writing optimizers, be VERY careful that the optimizer returns
+;;; something not EQ to its argument if and ONLY if it has made a change.
+;;; This implies that you cannot simply destructively modify the list;
+;;; you must return something not EQ to it if you make an optimization.
+;;;
+;;; It is now safe to optimize code such that it introduces new bindings.
+
+;; I'd like this to be a defsubst, but let's not be self-referental...
+(defmacro byte-compile-trueconstp (form)
+ ;; Returns non-nil if FORM is a non-nil constant.
+ (` (cond ((consp (, form)) (eq (car (, form)) 'quote))
+ ((not (symbolp (, form))))
+ ((eq (, form) t)))))
+
+(defun byte-optimize-associative-math (form)
+ "If the function is being called with constant numeric args,
+evaluate as much as possible at compile-time. This optimizer
+assumes that the function is associative, like + or *."
+ (let ((args nil)
+ (constants nil)
+ (rest (cdr form)))
+ (while rest
+ (if (numberp (car rest))
+ (setq constants (cons (car rest) constants))
+ (setq args (cons (car rest) args)))
+ (setq rest (cdr rest)))
+ (if (cdr constants)
+ (if args
+ (list (car form)
+ (apply (car form) constants)
+ (if (cdr args)
+ (cons (car form) (nreverse args))
+ (car args)))
+ (apply (car form) constants))
+ form)))
+
+(defun byte-optimize-nonassociative-math (form)
+ "If the function is being called with constant numeric args,
+evaluate as much as possible at compile-time. This optimizer
+assumes that the function is nonassociative, like - or /."
+ (if (or (not (numberp (car (cdr form))))
+ (not (numberp (car (cdr (cdr form))))))
+ form
+ (let ((constant (car (cdr form)))
+ (rest (cdr (cdr form))))
+ (while (numberp (car rest))
+ (setq constant (funcall (car form) constant (car rest))
+ rest (cdr rest)))
+ (if rest
+ (cons (car form) (cons constant rest))
+ constant))))
+
+;;(defun byte-optimize-associative-two-args-math (form)
+;; (setq form (byte-optimize-associative-math form))
+;; (if (consp form)
+;; (byte-optimize-two-args-left form)
+;; form))
+
+;;(defun byte-optimize-nonassociative-two-args-math (form)
+;; (setq form (byte-optimize-nonassociative-math form))
+;; (if (consp form)
+;; (byte-optimize-two-args-right form)
+;; form))
+
+(defun byte-optimize-delay-constants-math (form start fun)
+ ;; Merge all FORM's constants from number START, call FUN on them
+ ;; and put the result at the end.
+ (let ((rest (nthcdr (1- start) form)))
+ (while (cdr (setq rest (cdr rest)))
+ (if (numberp (car rest))
+ (let (constants)
+ (setq form (copy-sequence form)
+ rest (nthcdr (1- start) form))
+ (while (setq rest (cdr rest))
+ (cond ((numberp (car rest))
+ (setq constants (cons (car rest) constants))
+ (setcar rest nil))))
+ (setq form (nconc (delq nil form)
+ (list (apply fun (nreverse constants))))))))
+ form))
+
+(defun byte-optimize-plus (form)
+ (setq form (byte-optimize-delay-constants-math form 1 '+))
+ (if (memq 0 form) (setq form (delq 0 (copy-sequence form))))
+ ;;(setq form (byte-optimize-associative-two-args-math form))
+ (cond ((null (cdr form))
+ (condition-case ()
+ (eval form)
+ (error form)))
+ ((null (cdr (cdr form))) (nth 1 form))
+ (t form)))
+
+(defun byte-optimize-minus (form)
+ ;; Put constants at the end, except the last constant.
+ (setq form (byte-optimize-delay-constants-math form 2 '+))
+ ;; Now only first and last element can be a number.
+ (let ((last (car (reverse (nthcdr 3 form)))))
+ (cond ((eq 0 last)
+ ;; (- x y ... 0) --> (- x y ...)
+ (setq form (copy-sequence form))
+ (setcdr (cdr (cdr form)) (delq 0 (nthcdr 3 form))))
+ ;; If form is (- CONST foo... CONST), merge first and last.
+ ((and (numberp (nth 1 form))
+ (numberp last))
+ (setq form (nconc (list '- (- (nth 1 form) last) (nth 2 form))
+ (delq last (copy-sequence (nthcdr 3 form))))))))
+ (if (eq (nth 2 form) 0)
+ (nth 1 form) ; (- x 0) --> x
+ (byte-optimize-predicate
+ (if (and (null (cdr (cdr (cdr form))))
+ (eq (nth 1 form) 0)) ; (- 0 x) --> (- x)
+ (cons (car form) (cdr (cdr form)))
+ form))))
+
+(defun byte-optimize-multiply (form)
+ (setq form (byte-optimize-delay-constants-math form 1 '*))
+ ;; If there is a constant in FORM, it is now the last element.
+ (cond ((null (cdr form)) 1)
+ ((null (cdr (cdr form))) (nth 1 form))
+ ((let ((last (car (reverse form))))
+ (cond ((eq 0 last) (list 'progn (cdr form)))
+ ((eq 1 last) (delq 1 (copy-sequence form)))
+ ((eq -1 last) (list '- (delq -1 (copy-sequence form))))
+ ((and (eq 2 last)
+ (memq t (mapcar 'symbolp (cdr form))))
+ (prog1 (setq form (delq 2 (copy-sequence form)))
+ (while (not (symbolp (car (setq form (cdr form))))))
+ (setcar form (list '+ (car form) (car form)))))
+ (form))))))
+
+(defsubst byte-compile-butlast (form)
+ (nreverse (cdr (reverse form))))
+
+(defun byte-optimize-divide (form)
+ (setq form (byte-optimize-delay-constants-math form 2 '*))
+ (let ((last (car (reverse (cdr (cdr form))))))
+ (if (numberp last)
+ (cond ((= last 1)
+ (setq form (byte-compile-butlast form)))
+ ((numberp (nth 1 form))
+ (setq form (cons (car form)
+ (cons (/ (nth 1 form) last)
+ (byte-compile-butlast (cdr (cdr form)))))
+ last nil))))
+ (cond ((null (cdr (cdr form)))
+ (nth 1 form))
+ ((eq (nth 1 form) 0)
+ (append '(progn) (cdr (cdr form)) '(0)))
+ ((eq last -1)
+ (list '- (if (nthcdr 3 form)
+ (byte-compile-butlast form)
+ (nth 1 form))))
+ (form))))
+
+(defun byte-optimize-logmumble (form)
+ (setq form (byte-optimize-delay-constants-math form 1 (car form)))
+ (byte-optimize-predicate
+ (cond ((memq 0 form)
+ (setq form (if (eq (car form) 'logand)
+ (cons 'progn (cdr form))
+ (delq 0 (copy-sequence form)))))
+ ((and (eq (car-safe form) 'logior)
+ (memq -1 form))
+ (delq -1 (copy-sequence form)))
+ (form))))
+
+
+(defun byte-optimize-binary-predicate (form)
+ (if (byte-compile-constp (nth 1 form))
+ (if (byte-compile-constp (nth 2 form))
+ (condition-case ()
+ (list 'quote (eval form))
+ (error form))
+ ;; This can enable some lapcode optimizations.
+ (list (car form) (nth 2 form) (nth 1 form)))
+ form))
+
+(defun byte-optimize-predicate (form)
+ (let ((ok t)
+ (rest (cdr form)))
+ (while (and rest ok)
+ (setq ok (byte-compile-constp (car rest))
+ rest (cdr rest)))
+ (if ok
+ (condition-case ()
+ (list 'quote (eval form))
+ (error form))
+ form)))
+
+(defun byte-optimize-identity (form)
+ (if (and (cdr form) (null (cdr (cdr form))))
+ (nth 1 form)
+ (byte-compile-warn "identity called with %d arg%s, but requires 1"
+ (length (cdr form))
+ (if (= 1 (length (cdr form))) "" "s"))
+ form))
+
+(put 'identity 'byte-optimizer 'byte-optimize-identity)
+
+(put '+ 'byte-optimizer 'byte-optimize-plus)
+(put '* 'byte-optimizer 'byte-optimize-multiply)
+(put '- 'byte-optimizer 'byte-optimize-minus)
+(put '/ 'byte-optimizer 'byte-optimize-divide)
+(put 'max 'byte-optimizer 'byte-optimize-associative-math)
+(put 'min 'byte-optimizer 'byte-optimize-associative-math)
+
+(put '= 'byte-optimizer 'byte-optimize-binary-predicate)
+(put 'eq 'byte-optimizer 'byte-optimize-binary-predicate)
+(put 'eql 'byte-optimizer 'byte-optimize-binary-predicate)
+(put 'equal 'byte-optimizer 'byte-optimize-binary-predicate)
+(put 'string= 'byte-optimizer 'byte-optimize-binary-predicate)
+(put 'string-equal 'byte-optimizer 'byte-optimize-binary-predicate)
+
+(put '< 'byte-optimizer 'byte-optimize-predicate)
+(put '> 'byte-optimizer 'byte-optimize-predicate)
+(put '<= 'byte-optimizer 'byte-optimize-predicate)
+(put '>= 'byte-optimizer 'byte-optimize-predicate)
+(put '1+ 'byte-optimizer 'byte-optimize-predicate)
+(put '1- 'byte-optimizer 'byte-optimize-predicate)
+(put 'not 'byte-optimizer 'byte-optimize-predicate)
+(put 'null 'byte-optimizer 'byte-optimize-predicate)
+(put 'memq 'byte-optimizer 'byte-optimize-predicate)
+(put 'consp 'byte-optimizer 'byte-optimize-predicate)
+(put 'listp 'byte-optimizer 'byte-optimize-predicate)
+(put 'symbolp 'byte-optimizer 'byte-optimize-predicate)
+(put 'stringp 'byte-optimizer 'byte-optimize-predicate)
+(put 'string< 'byte-optimizer 'byte-optimize-predicate)
+(put 'string-lessp 'byte-optimizer 'byte-optimize-predicate)
+
+(put 'logand 'byte-optimizer 'byte-optimize-logmumble)
+(put 'logior 'byte-optimizer 'byte-optimize-logmumble)
+(put 'logxor 'byte-optimizer 'byte-optimize-logmumble)
+(put 'lognot 'byte-optimizer 'byte-optimize-predicate)
+
+(put 'car 'byte-optimizer 'byte-optimize-predicate)
+(put 'cdr 'byte-optimizer 'byte-optimize-predicate)
+(put 'car-safe 'byte-optimizer 'byte-optimize-predicate)
+(put 'cdr-safe 'byte-optimizer 'byte-optimize-predicate)
+
+
+;; I'm not convinced that this is necessary. Doesn't the optimizer loop
+;; take care of this? - Jamie
+;; I think this may some times be necessary to reduce ie (quote 5) to 5,
+;; so arithmetic optimizers recognize the numerinc constant. - Hallvard
+(put 'quote 'byte-optimizer 'byte-optimize-quote)
+(defun byte-optimize-quote (form)
+ (if (or (consp (nth 1 form))
+ (and (symbolp (nth 1 form))
+ (not (memq (nth 1 form) '(nil t)))))
+ form
+ (nth 1 form)))
+
+(defun byte-optimize-zerop (form)
+ (cond ((numberp (nth 1 form))
+ (eval form))
+ (byte-compile-delete-errors
+ (list '= (nth 1 form) 0))
+ (form)))
+
+(put 'zerop 'byte-optimizer 'byte-optimize-zerop)
+
+(defun byte-optimize-and (form)
+ ;; Simplify if less than 2 args.
+ ;; if there is a literal nil in the args to `and', throw it and following
+ ;; forms away, and surround the `and' with (progn ... nil).
+ (cond ((null (cdr form)))
+ ((memq nil form)
+ (list 'progn
+ (byte-optimize-and
+ (prog1 (setq form (copy-sequence form))
+ (while (nth 1 form)
+ (setq form (cdr form)))
+ (setcdr form nil)))
+ nil))
+ ((null (cdr (cdr form)))
+ (nth 1 form))
+ ((byte-optimize-predicate form))))
+
+(defun byte-optimize-or (form)
+ ;; Throw away nil's, and simplify if less than 2 args.
+ ;; If there is a literal non-nil constant in the args to `or', throw away all
+ ;; following forms.
+ (if (memq nil form)
+ (setq form (delq nil (copy-sequence form))))
+ (let ((rest form))
+ (while (cdr (setq rest (cdr rest)))
+ (if (byte-compile-trueconstp (car rest))
+ (setq form (copy-sequence form)
+ rest (setcdr (memq (car rest) form) nil))))
+ (if (cdr (cdr form))
+ (byte-optimize-predicate form)
+ (nth 1 form))))
+
+(defun byte-optimize-cond (form)
+ ;; if any clauses have a literal nil as their test, throw them away.
+ ;; if any clause has a literal non-nil constant as its test, throw
+ ;; away all following clauses.
+ (let (rest)
+ ;; This must be first, to reduce (cond (t ...) (nil)) to (progn t ...)
+ (while (setq rest (assq nil (cdr form)))
+ (setq form (delq rest (copy-sequence form))))
+ (if (memq nil (cdr form))
+ (setq form (delq nil (copy-sequence form))))
+ (setq rest form)
+ (while (setq rest (cdr rest))
+ (cond ((byte-compile-trueconstp (car-safe (car rest)))
+ (cond ((eq rest (cdr form))
+ (setq form
+ (if (cdr (car rest))
+ (if (cdr (cdr (car rest)))
+ (cons 'progn (cdr (car rest)))
+ (nth 1 (car rest)))
+ (car (car rest)))))
+ ((cdr rest)
+ (setq form (copy-sequence form))
+ (setcdr (memq (car rest) form) nil)))
+ (setq rest nil)))))
+ ;;
+ ;; Turn (cond (( <x> )) ... ) into (or <x> (cond ... ))
+ (if (eq 'cond (car-safe form))
+ (let ((clauses (cdr form)))
+ (if (and (consp (car clauses))
+ (null (cdr (car clauses))))
+ (list 'or (car (car clauses))
+ (byte-optimize-cond
+ (cons (car form) (cdr (cdr form)))))
+ form))
+ form))
+
+(defun byte-optimize-if (form)
+ ;; (if <true-constant> <then> <else...>) ==> <then>
+ ;; (if <false-constant> <then> <else...>) ==> (progn <else...>)
+ ;; (if <test> nil <else...>) ==> (if (not <test>) (progn <else...>))
+ ;; (if <test> <then> nil) ==> (if <test> <then>)
+ (let ((clause (nth 1 form)))
+ (cond ((byte-compile-trueconstp clause)
+ (nth 2 form))
+ ((null clause)
+ (if (nthcdr 4 form)
+ (cons 'progn (nthcdr 3 form))
+ (nth 3 form)))
+ ((nth 2 form)
+ (if (equal '(nil) (nthcdr 3 form))
+ (list 'if clause (nth 2 form))
+ form))
+ ((or (nth 3 form) (nthcdr 4 form))
+ (list 'if (list 'not clause)
+ (if (nthcdr 4 form)
+ (cons 'progn (nthcdr 3 form))
+ (nth 3 form))))
+ (t
+ (list 'progn clause nil)))))
+
+(defun byte-optimize-while (form)
+ (if (nth 1 form)
+ form))
+
+(put 'and 'byte-optimizer 'byte-optimize-and)
+(put 'or 'byte-optimizer 'byte-optimize-or)
+(put 'cond 'byte-optimizer 'byte-optimize-cond)
+(put 'if 'byte-optimizer 'byte-optimize-if)
+(put 'while 'byte-optimizer 'byte-optimize-while)
+
+;; byte-compile-negation-optimizer lives in bytecomp.el
+(put '/= 'byte-optimizer 'byte-compile-negation-optimizer)
+(put 'atom 'byte-optimizer 'byte-compile-negation-optimizer)
+(put 'nlistp 'byte-optimizer 'byte-compile-negation-optimizer)
+
+
+(defun byte-optimize-funcall (form)
+ ;; (funcall '(lambda ...) ...) ==> ((lambda ...) ...)
+ ;; (funcall 'foo ...) ==> (foo ...)
+ (let ((fn (nth 1 form)))
+ (if (memq (car-safe fn) '(quote function))
+ (cons (nth 1 fn) (cdr (cdr form)))
+ form)))
+
+(defun byte-optimize-apply (form)
+ ;; If the last arg is a literal constant, turn this into a funcall.
+ ;; The funcall optimizer can then transform (funcall 'foo ...) -> (foo ...).
+ (let ((fn (nth 1 form))
+ (last (nth (1- (length form)) form))) ; I think this really is fastest
+ (or (if (or (null last)
+ (eq (car-safe last) 'quote))
+ (if (listp (nth 1 last))
+ (let ((butlast (nreverse (cdr (reverse (cdr (cdr form)))))))
+ (nconc (list 'funcall fn) butlast (nth 1 last)))
+ (byte-compile-warn
+ "last arg to apply can't be a literal atom: %s"
+ (prin1-to-string last))
+ nil))
+ form)))
+
+(put 'funcall 'byte-optimizer 'byte-optimize-funcall)
+(put 'apply 'byte-optimizer 'byte-optimize-apply)
+
+
+(put 'let 'byte-optimizer 'byte-optimize-letX)
+(put 'let* 'byte-optimizer 'byte-optimize-letX)
+(defun byte-optimize-letX (form)
+ (cond ((null (nth 1 form))
+ ;; No bindings
+ (cons 'progn (cdr (cdr form))))
+ ((or (nth 2 form) (nthcdr 3 form))
+ form)
+ ;; The body is nil
+ ((eq (car form) 'let)
+ (append '(progn) (mapcar 'car (mapcar 'cdr (nth 1 form))) '(nil)))
+ (t
+ (let ((binds (reverse (nth 1 form))))
+ (list 'let* (reverse (cdr binds)) (nth 1 (car binds)) nil)))))
+
+
+(put 'nth 'byte-optimizer 'byte-optimize-nth)
+(defun byte-optimize-nth (form)
+ (if (memq (nth 1 form) '(0 1))
+ (list 'car (if (zerop (nth 1 form))
+ (nth 2 form)
+ (list 'cdr (nth 2 form))))
+ (byte-optimize-predicate form)))
+
+(put 'nthcdr 'byte-optimizer 'byte-optimize-nthcdr)
+(defun byte-optimize-nthcdr (form)
+ (let ((count (nth 1 form)))
+ (if (not (memq count '(0 1 2)))
+ (byte-optimize-predicate form)
+ (setq form (nth 2 form))
+ (while (natnump (setq count (1- count)))
+ (setq form (list 'cdr form)))
+ form)))
+
+;;; enumerating those functions which need not be called if the returned
+;;; value is not used. That is, something like
+;;; (progn (list (something-with-side-effects) (yow))
+;;; (foo))
+;;; may safely be turned into
+;;; (progn (progn (something-with-side-effects) (yow))
+;;; (foo))
+;;; Further optimizations will turn (progn (list 1 2 3) 'foo) into 'foo.
+
+;;; I wonder if I missed any :-\)
+(let ((side-effect-free-fns
+ '(% * + / /= 1+ < <= = > >= append aref ash assoc assq boundp
+ buffer-file-name buffer-local-variables buffer-modified-p
+ buffer-substring capitalize car cdr concat coordinates-in-window-p
+ copy-marker count-lines documentation downcase elt fboundp featurep
+ file-directory-p file-exists-p file-locked-p file-name-absolute-p
+ file-newer-than-file-p file-readable-p file-symlink-p file-writable-p
+ format get get-buffer get-buffer-window getenv get-file-buffer length
+ logand logior lognot logxor lsh marker-buffer max member memq min mod
+ next-window nth nthcdr previous-window rassq regexp-quote reverse
+ string< string= string-lessp string-equal substring user-variable-p
+ window-buffer window-edges window-height window-hscroll window-width
+ zerop))
+ ;; could also add plusp, minusp, signum. If anyone ever defines
+ ;; these, they will certainly be side-effect free.
+ (side-effect-and-error-free-fns
+ '(arrayp atom bobp bolp buffer-end buffer-list buffer-size
+ buffer-string bufferp char-or-string-p commandp cons consp
+ current-buffer dot dot-marker eobp eolp eq eql equal
+ get-largest-window identity integerp integer-or-marker-p
+ interactive-p keymapp list listp make-marker mark mark-marker
+ markerp minibuffer-window natnump nlistp not null numberp
+ one-window-p point point-marker processp selected-window sequencep
+ stringp subrp symbolp syntax-table-p vector vectorp windowp)))
+ (while side-effect-free-fns
+ (put (car side-effect-free-fns) 'side-effect-free t)
+ (setq side-effect-free-fns (cdr side-effect-free-fns)))
+ (while side-effect-and-error-free-fns
+ (put (car side-effect-and-error-free-fns) 'side-effect-free 'error-free)
+ (setq side-effect-and-error-free-fns (cdr side-effect-and-error-free-fns)))
+ nil)
+
+
+(defun byte-compile-splice-in-already-compiled-code (form)
+ ;; form is (byte-code "..." [...] n)
+ (if (not (memq byte-optimize '(t lap)))
+ (byte-compile-normal-call form)
+ (byte-inline-lapcode
+ (byte-decompile-bytecode-1 (nth 1 form) (nth 2 form) t))
+ (setq byte-compile-maxdepth (max (+ byte-compile-depth (nth 3 form))
+ byte-compile-maxdepth))
+ (setq byte-compile-depth (1+ byte-compile-depth))))
+
+(put 'byte-code 'byte-compile 'byte-compile-splice-in-already-compiled-code)
+
+
+(defconst byte-constref-ops
+ '(byte-constant byte-constant2 byte-varref byte-varset byte-varbind))
+
+;;; This function extracts the bitfields from variable-length opcodes.
+;;; Originally defined in disass.el (which no longer uses it.)
+
+(defun disassemble-offset ()
+ "Don't call this!"
+ ;; fetch and return the offset for the current opcode.
+ ;; return NIL if this opcode has no offset
+ ;; OP, PTR and BYTES are used and set dynamically
+ (defvar op)
+ (defvar ptr)
+ (defvar bytes)
+ (cond ((< op byte-nth)
+ (let ((tem (logand op 7)))
+ (setq op (logand op 248))
+ (cond ((eq tem 6)
+ (setq ptr (1+ ptr)) ;offset in next byte
+ (aref bytes ptr))
+ ((eq tem 7)
+ (setq ptr (1+ ptr)) ;offset in next 2 bytes
+ (+ (aref bytes ptr)
+ (progn (setq ptr (1+ ptr))
+ (lsh (aref bytes ptr) 8))))
+ (t tem)))) ;offset was in opcode
+ ((>= op byte-constant)
+ (prog1 (- op byte-constant) ;offset in opcode
+ (setq op byte-constant)))
+ ((and (>= op byte-constant2)
+ (<= op byte-goto-if-not-nil-else-pop))
+ (setq ptr (1+ ptr)) ;offset in next 2 bytes
+ (+ (aref bytes ptr)
+ (progn (setq ptr (1+ ptr))
+ (lsh (aref bytes ptr) 8))))
+ ((and (>= op byte-rel-goto)
+ (<= op byte-insertN))
+ (setq ptr (1+ ptr)) ;offset in next byte
+ (aref bytes ptr))))
+
+
+;;; This de-compiler is used for inline expansion of compiled functions,
+;;; and by the disassembler.
+;;;
+(defun byte-decompile-bytecode (bytes constvec)
+ "Turns BYTECODE into lapcode, refering to CONSTVEC."
+ (let ((byte-compile-constants nil)
+ (byte-compile-variables nil)
+ (byte-compile-tag-number 0))
+ (byte-decompile-bytecode-1 bytes constvec)))
+
+(defun byte-decompile-bytecode-1 (bytes constvec &optional make-splicable)
+ "As byte-decompile-bytecode, but updates
+byte-compile-{constants, variables, tag-number}.
+If the optional 3rd arg is true, then `return' opcodes are replaced
+with `goto's destined for the end of the code."
+ (let ((length (length bytes))
+ (ptr 0) optr tag tags op offset
+ lap tmp
+ endtag
+ (retcount 0))
+ (while (not (= ptr length))
+ (setq op (aref bytes ptr)
+ optr ptr
+ offset (disassemble-offset)) ; this does dynamic-scope magic
+ (setq op (aref byte-code-vector op))
+ (cond ((or (memq op byte-goto-ops)
+ (cond ((memq op byte-rel-goto-ops)
+ (setq op (aref byte-code-vector
+ (- (symbol-value op)
+ (- byte-rel-goto byte-goto))))
+ (setq offset (+ ptr (- offset 127)))
+ t)))
+ ;; it's a pc
+ (setq offset
+ (cdr (or (assq offset tags)
+ (car (setq tags
+ (cons (cons offset
+ (byte-compile-make-tag))
+ tags)))))))
+ ((cond ((eq op 'byte-constant2) (setq op 'byte-constant) t)
+ ((memq op byte-constref-ops)))
+ (setq tmp (aref constvec offset)
+ offset (if (eq op 'byte-constant)
+ (byte-compile-get-constant tmp)
+ (or (assq tmp byte-compile-variables)
+ (car (setq byte-compile-variables
+ (cons (list tmp)
+ byte-compile-variables)))))))
+ ((and make-splicable
+ (eq op 'byte-return))
+ (if (= ptr (1- length))
+ (setq op nil)
+ (setq offset (or endtag (setq endtag (byte-compile-make-tag)))
+ op 'byte-goto))))
+ ;; lap = ( [ (pc . (op . arg)) ]* )
+ (setq lap (cons (cons optr (cons op (or offset 0)))
+ lap))
+ (setq ptr (1+ ptr)))
+ ;; take off the dummy nil op that we replaced a trailing "return" with.
+ (let ((rest lap))
+ (while rest
+ (cond ((setq tmp (assq (car (car rest)) tags))
+ ;; this addr is jumped to
+ (setcdr rest (cons (cons nil (cdr tmp))
+ (cdr rest)))
+ (setq tags (delq tmp tags))
+ (setq rest (cdr rest))))
+ (setq rest (cdr rest))))
+ (if tags (error "optimizer error: missed tags %s" tags))
+ (if (null (car (cdr (car lap))))
+ (setq lap (cdr lap)))
+ (if endtag
+ (setq lap (cons (cons nil endtag) lap)))
+ ;; remove addrs, lap = ( [ (op . arg) | (TAG tagno) ]* )
+ (mapcar 'cdr (nreverse lap))))
+
+
+;;; peephole optimizer
+
+(defconst byte-tagref-ops (cons 'TAG byte-goto-ops))
+
+(defconst byte-conditional-ops
+ '(byte-goto-if-nil byte-goto-if-not-nil byte-goto-if-nil-else-pop
+ byte-goto-if-not-nil-else-pop))
+
+(defconst byte-after-unbind-ops
+ '(byte-constant byte-dup
+ byte-symbolp byte-consp byte-stringp byte-listp byte-numberp byte-integerp
+ byte-eq byte-equal byte-not
+ byte-cons byte-list1 byte-list2 ; byte-list3 byte-list4
+ byte-interactive-p
+ ;; How about other side-effect-free-ops? Is it safe to move an
+ ;; error invocation (such as from nth) out of an unwind-protect?
+ "Byte-codes that can be moved past an unbind."))
+
+(defconst byte-compile-side-effect-and-error-free-ops
+ '(byte-constant byte-dup byte-symbolp byte-consp byte-stringp byte-listp
+ byte-integerp byte-numberp byte-eq byte-equal byte-not byte-car-safe
+ byte-cdr-safe byte-cons byte-list1 byte-list2 byte-point byte-point-max
+ byte-point-min byte-following-char byte-preceding-char
+ byte-current-column byte-eolp byte-eobp byte-bolp byte-bobp
+ byte-current-buffer byte-interactive-p))
+
+(defconst byte-compile-side-effect-free-ops
+ (nconc
+ '(byte-varref byte-nth byte-memq byte-car byte-cdr byte-length byte-aref
+ byte-symbol-value byte-get byte-concat2 byte-concat3 byte-sub1 byte-add1
+ byte-eqlsign byte-gtr byte-lss byte-leq byte-geq byte-diff byte-negate
+ byte-plus byte-max byte-min byte-mult byte-char-after byte-char-syntax
+ byte-buffer-substring byte-string= byte-string< byte-nthcdr byte-elt
+ byte-member byte-assq byte-quo byte-rem)
+ byte-compile-side-effect-and-error-free-ops))
+
+;;; This piece of shit is because of the way DEFVAR_BOOL() variables work.
+;;; Consider the code
+;;;
+;;; (defun foo (flag)
+;;; (let ((old-pop-ups pop-up-windows)
+;;; (pop-up-windows flag))
+;;; (cond ((not (eq pop-up-windows old-pop-ups))
+;;; (setq old-pop-ups pop-up-windows)
+;;; ...))))
+;;;
+;;; Uncompiled, old-pop-ups will always be set to nil or t, even if FLAG is
+;;; something else. But if we optimize
+;;;
+;;; varref flag
+;;; varbind pop-up-windows
+;;; varref pop-up-windows
+;;; not
+;;; to
+;;; varref flag
+;;; dup
+;;; varbind pop-up-windows
+;;; not
+;;;
+;;; we break the program, because it will appear that pop-up-windows and
+;;; old-pop-ups are not EQ when really they are. So we have to know what
+;;; the BOOL variables are, and not perform this optimization on them.
+;;;
+(defconst byte-boolean-vars
+ '(abbrevs-changed abbrev-all-caps inverse-video visible-bell
+ check-protected-fields no-redraw-on-reenter cursor-in-echo-area
+ noninteractive stack-trace-on-error debug-on-error debug-on-quit
+ debug-on-next-call insert-default-directory vms-stmlf-recfm
+ indent-tabs-mode meta-flag load-in-progress defining-kbd-macro
+ completion-auto-help completion-ignore-case enable-recursive-minibuffers
+ print-escape-newlines delete-exited-processes parse-sexp-ignore-comments
+ words-include-escapes pop-up-windows auto-new-screen
+ reset-terminal-on-clear truncate-partial-width-windows
+ mode-line-inverse-video)
+ "DEFVAR_BOOL variables. Giving these any non-nil value sets them to t.
+If this does not enumerate all DEFVAR_BOOL variables, the byte-optimizer
+may generate incorrect code.")
+
+(defun byte-optimize-lapcode (lap &optional for-effect)
+ "Simple peephole optimizer. LAP is both modified and returned."
+ (let (lap0 off0
+ lap1 off1
+ lap2 off2
+ (keep-going 'first-time)
+ (add-depth 0)
+ rest tmp tmp2 tmp3
+ (side-effect-free (if byte-compile-delete-errors
+ byte-compile-side-effect-free-ops
+ byte-compile-side-effect-and-error-free-ops)))
+ (while keep-going
+ (or (eq keep-going 'first-time)
+ (byte-compile-log-lap " ---- next pass"))
+ (setq rest lap
+ keep-going nil)
+ (while rest
+ (setq lap0 (car rest)
+ lap1 (nth 1 rest)
+ lap2 (nth 2 rest))
+
+ ;; You may notice that sequences like "dup varset discard" are
+ ;; optimized but sequences like "dup varset TAG1: discard" are not.
+ ;; You may be tempted to change this; resist that temptation.
+ (cond ;;
+ ;; <side-effect-free> pop --> <deleted>
+ ;; ...including:
+ ;; const-X pop --> <deleted>
+ ;; varref-X pop --> <deleted>
+ ;; dup pop --> <deleted>
+ ;;
+ ((and (eq 'byte-discard (car lap1))
+ (memq (car lap0) side-effect-free))
+ (setq keep-going t)
+ (setq tmp (aref byte-stack+-info (symbol-value (car lap0))))
+ (setq rest (cdr rest))
+ (cond ((= tmp 1)
+ (byte-compile-log-lap
+ " %s discard\t-->\t<deleted>" lap0)
+ (setq lap (delq lap0 (delq lap1 lap))))
+ ((= tmp 0)
+ (byte-compile-log-lap
+ " %s discard\t-->\t<deleted> discard" lap0)
+ (setq lap (delq lap0 lap)))
+ ((= tmp -1)
+ (byte-compile-log-lap
+ " %s discard\t-->\tdiscard discard" lap0)
+ (setcar lap0 'byte-discard)
+ (setcdr lap0 0))
+ ((error "Optimizer error: too much on the stack"))))
+ ;;
+ ;; goto*-X X: --> X:
+ ;;
+ ((and (memq (car lap0) byte-goto-ops)
+ (eq (cdr lap0) lap1))
+ (cond ((eq (car lap0) 'byte-goto)
+ (setq lap (delq lap0 lap))
+ (setq tmp "<deleted>"))
+ ((memq (car lap0) byte-goto-always-pop-ops)
+ (setcar lap0 (setq tmp 'byte-discard))
+ (setcdr lap0 0))
+ ((error "Depth conflict at tag %d" (nth 2 lap0))))
+ (and (memq byte-optimize-log '(t byte))
+ (byte-compile-log " (goto %s) %s:\t-->\t%s %s:"
+ (nth 1 lap1) (nth 1 lap1)
+ tmp (nth 1 lap1)))
+ (setq keep-going t))
+ ;;
+ ;; varset-X varref-X --> dup varset-X
+ ;; varbind-X varref-X --> dup varbind-X
+ ;; const/dup varset-X varref-X --> const/dup varset-X const/dup
+ ;; const/dup varbind-X varref-X --> const/dup varbind-X const/dup
+ ;; The latter two can enable other optimizations.
+ ;;
+ ((and (eq 'byte-varref (car lap2))
+ (eq (cdr lap1) (cdr lap2))
+ (memq (car lap1) '(byte-varset byte-varbind)))
+ (if (and (setq tmp (memq (car (cdr lap2)) byte-boolean-vars))
+ (not (eq (car lap0) 'byte-constant)))
+ nil
+ (setq keep-going t)
+ (if (memq (car lap0) '(byte-constant byte-dup))
+ (progn
+ (setq tmp (if (or (not tmp)
+ (memq (car (cdr lap0)) '(nil t)))
+ (cdr lap0)
+ (byte-compile-get-constant t)))
+ (byte-compile-log-lap " %s %s %s\t-->\t%s %s %s"
+ lap0 lap1 lap2 lap0 lap1
+ (cons (car lap0) tmp))
+ (setcar lap2 (car lap0))
+ (setcdr lap2 tmp))
+ (byte-compile-log-lap " %s %s\t-->\tdup %s" lap1 lap2 lap1)
+ (setcar lap2 (car lap1))
+ (setcar lap1 'byte-dup)
+ (setcdr lap1 0)
+ ;; The stack depth gets locally increased, so we will
+ ;; increase maxdepth in case depth = maxdepth here.
+ ;; This can cause the third argument to byte-code to
+ ;; be larger than necessary.
+ (setq add-depth 1))))
+ ;;
+ ;; dup varset-X discard --> varset-X
+ ;; dup varbind-X discard --> varbind-X
+ ;; (the varbind variant can emerge from other optimizations)
+ ;;
+ ((and (eq 'byte-dup (car lap0))
+ (eq 'byte-discard (car lap2))
+ (memq (car lap1) '(byte-varset byte-varbind)))
+ (byte-compile-log-lap " dup %s discard\t-->\t%s" lap1 lap1)
+ (setq keep-going t
+ rest (cdr rest))
+ (setq lap (delq lap0 (delq lap2 lap))))
+ ;;
+ ;; not goto-X-if-nil --> goto-X-if-non-nil
+ ;; not goto-X-if-non-nil --> goto-X-if-nil
+ ;;
+ ;; it is wrong to do the same thing for the -else-pop variants.
+ ;;
+ ((and (eq 'byte-not (car lap0))
+ (or (eq 'byte-goto-if-nil (car lap1))
+ (eq 'byte-goto-if-not-nil (car lap1))))
+ (byte-compile-log-lap " not %s\t-->\t%s"
+ lap1
+ (cons
+ (if (eq (car lap1) 'byte-goto-if-nil)
+ 'byte-goto-if-not-nil
+ 'byte-goto-if-nil)
+ (cdr lap1)))
+ (setcar lap1 (if (eq (car lap1) 'byte-goto-if-nil)
+ 'byte-goto-if-not-nil
+ 'byte-goto-if-nil))
+ (setq lap (delq lap0 lap))
+ (setq keep-going t))
+ ;;
+ ;; goto-X-if-nil goto-Y X: --> goto-Y-if-non-nil X:
+ ;; goto-X-if-non-nil goto-Y X: --> goto-Y-if-nil X:
+ ;;
+ ;; it is wrong to do the same thing for the -else-pop variants.
+ ;;
+ ((and (or (eq 'byte-goto-if-nil (car lap0))
+ (eq 'byte-goto-if-not-nil (car lap0))) ; gotoX
+ (eq 'byte-goto (car lap1)) ; gotoY
+ (eq (cdr lap0) lap2)) ; TAG X
+ (let ((inverse (if (eq 'byte-goto-if-nil (car lap0))
+ 'byte-goto-if-not-nil 'byte-goto-if-nil)))
+ (byte-compile-log-lap " %s %s %s:\t-->\t%s %s:"
+ lap0 lap1 lap2
+ (cons inverse (cdr lap1)) lap2)
+ (setq lap (delq lap0 lap))
+ (setcar lap1 inverse)
+ (setq keep-going t)))
+ ;;
+ ;; const goto-if-* --> whatever
+ ;;
+ ((and (eq 'byte-constant (car lap0))
+ (memq (car lap1) byte-conditional-ops))
+ (cond ((if (or (eq (car lap1) 'byte-goto-if-nil)
+ (eq (car lap1) 'byte-goto-if-nil-else-pop))
+ (car (cdr lap0))
+ (not (car (cdr lap0))))
+ (byte-compile-log-lap " %s %s\t-->\t<deleted>"
+ lap0 lap1)
+ (setq rest (cdr rest)
+ lap (delq lap0 (delq lap1 lap))))
+ (t
+ (if (memq (car lap1) byte-goto-always-pop-ops)
+ (progn
+ (byte-compile-log-lap " %s %s\t-->\t%s"
+ lap0 lap1 (cons 'byte-goto (cdr lap1)))
+ (setq lap (delq lap0 lap)))
+ (byte-compile-log-lap " %s %s\t-->\t%s" lap0 lap1
+ (cons 'byte-goto (cdr lap1))))
+ (setcar lap1 'byte-goto)))
+ (setq keep-going t))
+ ;;
+ ;; varref-X varref-X --> varref-X dup
+ ;; varref-X [dup ...] varref-X --> varref-X [dup ...] dup
+ ;; We don't optimize the const-X variations on this here,
+ ;; because that would inhibit some goto optimizations; we
+ ;; optimize the const-X case after all other optimizations.
+ ;;
+ ((and (eq 'byte-varref (car lap0))
+ (progn
+ (setq tmp (cdr rest))
+ (while (eq (car (car tmp)) 'byte-dup)
+ (setq tmp (cdr tmp)))
+ t)
+ (eq (cdr lap0) (cdr (car tmp)))
+ (eq 'byte-varref (car (car tmp))))
+ (if (memq byte-optimize-log '(t byte))
+ (let ((str ""))
+ (setq tmp2 (cdr rest))
+ (while (not (eq tmp tmp2))
+ (setq tmp2 (cdr tmp2)
+ str (concat str " dup")))
+ (byte-compile-log-lap " %s%s %s\t-->\t%s%s dup"
+ lap0 str lap0 lap0 str)))
+ (setq keep-going t)
+ (setcar (car tmp) 'byte-dup)
+ (setcdr (car tmp) 0)
+ (setq rest tmp))
+ ;;
+ ;; TAG1: TAG2: --> TAG1: <deleted>
+ ;; (and other references to TAG2 are replaced with TAG1)
+ ;;
+ ((and (eq (car lap0) 'TAG)
+ (eq (car lap1) 'TAG))
+ (and (memq byte-optimize-log '(t byte))
+ (byte-compile-log " adjascent tags %d and %d merged"
+ (nth 1 lap1) (nth 1 lap0)))
+ (setq tmp3 lap)
+ (while (setq tmp2 (rassq lap0 tmp3))
+ (setcdr tmp2 lap1)
+ (setq tmp3 (cdr (memq tmp2 tmp3))))
+ (setq lap (delq lap0 lap)
+ keep-going t))
+ ;;
+ ;; unused-TAG: --> <deleted>
+ ;;
+ ((and (eq 'TAG (car lap0))
+ (not (rassq lap0 lap)))
+ (and (memq byte-optimize-log '(t byte))
+ (byte-compile-log " unused tag %d removed" (nth 1 lap0)))
+ (setq lap (delq lap0 lap)
+ keep-going t))
+ ;;
+ ;; goto ... --> goto <delete until TAG or end>
+ ;; return ... --> return <delete until TAG or end>
+ ;;
+ ((and (memq (car lap0) '(byte-goto byte-return))
+ (not (memq (car lap1) '(TAG nil))))
+ (setq tmp rest)
+ (let ((i 0)
+ (opt-p (memq byte-optimize-log '(t lap)))
+ str deleted)
+ (while (and (setq tmp (cdr tmp))
+ (not (eq 'TAG (car (car tmp)))))
+ (if opt-p (setq deleted (cons (car tmp) deleted)
+ str (concat str " %s")
+ i (1+ i))))
+ (if opt-p
+ (let ((tagstr
+ (if (eq 'TAG (car (car tmp)))
+ (format "%d:" (cdr (car tmp)))
+ (or (car tmp) ""))))
+ (if (< i 6)
+ (apply 'byte-compile-log-lap-1
+ (concat " %s" str
+ " %s\t-->\t%s <deleted> %s")
+ lap0
+ (nconc (nreverse deleted)
+ (list tagstr lap0 tagstr)))
+ (byte-compile-log-lap
+ " %s <%d unreachable op%s> %s\t-->\t%s <deleted> %s"
+ lap0 i (if (= i 1) "" "s")
+ tagstr lap0 tagstr))))
+ (rplacd rest tmp))
+ (setq keep-going t))
+ ;;
+ ;; <safe-op> unbind --> unbind <safe-op>
+ ;; (this may enable other optimizations.)
+ ;;
+ ((and (eq 'byte-unbind (car lap1))
+ (memq (car lap0) byte-after-unbind-ops))
+ (byte-compile-log-lap " %s %s\t-->\t%s %s" lap0 lap1 lap1 lap0)
+ (setcar rest lap1)
+ (setcar (cdr rest) lap0)
+ (setq keep-going t))
+ ;;
+ ;; varbind-X unbind-N --> discard unbind-(N-1)
+ ;; save-excursion unbind-N --> unbind-(N-1)
+ ;; save-restriction unbind-N --> unbind-(N-1)
+ ;;
+ ((and (eq 'byte-unbind (car lap1))
+ (memq (car lap0) '(byte-varbind byte-save-excursion
+ byte-save-restriction))
+ (< 0 (cdr lap1)))
+ (if (zerop (setcdr lap1 (1- (cdr lap1))))
+ (delq lap1 rest))
+ (if (eq (car lap0) 'byte-varbind)
+ (setcar rest (cons 'byte-discard 0))
+ (setq lap (delq lap0 lap)))
+ (byte-compile-log-lap " %s %s\t-->\t%s %s"
+ lap0 (cons (car lap1) (1+ (cdr lap1)))
+ (if (eq (car lap0) 'byte-varbind)
+ (car rest)
+ (car (cdr rest)))
+ (if (and (/= 0 (cdr lap1))
+ (eq (car lap0) 'byte-varbind))
+ (car (cdr rest))
+ ""))
+ (setq keep-going t))
+ ;;
+ ;; goto*-X ... X: goto-Y --> goto*-Y
+ ;; goto-X ... X: return --> return
+ ;;
+ ((and (memq (car lap0) byte-goto-ops)
+ (memq (car (setq tmp (nth 1 (memq (cdr lap0) lap))))
+ '(byte-goto byte-return)))
+ (cond ((and (not (eq tmp lap0))
+ (or (eq (car lap0) 'byte-goto)
+ (eq (car tmp) 'byte-goto)))
+ (byte-compile-log-lap " %s [%s]\t-->\t%s"
+ (car lap0) tmp tmp)
+ (if (eq (car tmp) 'byte-return)
+ (setcar lap0 'byte-return))
+ (setcdr lap0 (cdr tmp))
+ (setq keep-going t))))
+ ;;
+ ;; goto-*-else-pop X ... X: goto-if-* --> whatever
+ ;; goto-*-else-pop X ... X: discard --> whatever
+ ;;
+ ((and (memq (car lap0) '(byte-goto-if-nil-else-pop
+ byte-goto-if-not-nil-else-pop))
+ (memq (car (car (setq tmp (cdr (memq (cdr lap0) lap)))))
+ (eval-when-compile
+ (cons 'byte-discard byte-conditional-ops)))
+ (not (eq lap0 (car tmp))))
+ (setq tmp2 (car tmp))
+ (setq tmp3 (assq (car lap0) '((byte-goto-if-nil-else-pop
+ byte-goto-if-nil)
+ (byte-goto-if-not-nil-else-pop
+ byte-goto-if-not-nil))))
+ (if (memq (car tmp2) tmp3)
+ (progn (setcar lap0 (car tmp2))
+ (setcdr lap0 (cdr tmp2))
+ (byte-compile-log-lap " %s-else-pop [%s]\t-->\t%s"
+ (car lap0) tmp2 lap0))
+ ;; Get rid of the -else-pop's and jump one step further.
+ (or (eq 'TAG (car (nth 1 tmp)))
+ (setcdr tmp (cons (byte-compile-make-tag)
+ (cdr tmp))))
+ (byte-compile-log-lap " %s [%s]\t-->\t%s <skip>"
+ (car lap0) tmp2 (nth 1 tmp3))
+ (setcar lap0 (nth 1 tmp3))
+ (setcdr lap0 (nth 1 tmp)))
+ (setq keep-going t))
+ ;;
+ ;; const goto-X ... X: goto-if-* --> whatever
+ ;; const goto-X ... X: discard --> whatever
+ ;;
+ ((and (eq (car lap0) 'byte-constant)
+ (eq (car lap1) 'byte-goto)
+ (memq (car (car (setq tmp (cdr (memq (cdr lap1) lap)))))
+ (eval-when-compile
+ (cons 'byte-discard byte-conditional-ops)))
+ (not (eq lap1 (car tmp))))
+ (setq tmp2 (car tmp))
+ (cond ((memq (car tmp2)
+ (if (null (car (cdr lap0)))
+ '(byte-goto-if-nil byte-goto-if-nil-else-pop)
+ '(byte-goto-if-not-nil
+ byte-goto-if-not-nil-else-pop)))
+ (byte-compile-log-lap " %s goto [%s]\t-->\t%s %s"
+ lap0 tmp2 lap0 tmp2)
+ (setcar lap1 (car tmp2))
+ (setcdr lap1 (cdr tmp2))
+ ;; Let next step fix the (const,goto-if*) sequence.
+ (setq rest (cons nil rest)))
+ (t
+ ;; Jump one step further
+ (byte-compile-log-lap
+ " %s goto [%s]\t-->\t<deleted> goto <skip>"
+ lap0 tmp2)
+ (or (eq 'TAG (car (nth 1 tmp)))
+ (setcdr tmp (cons (byte-compile-make-tag)
+ (cdr tmp))))
+ (setcdr lap1 (car (cdr tmp)))
+ (setq lap (delq lap0 lap))))
+ (setq keep-going t))
+ ;;
+ ;; X: varref-Y ... varset-Y goto-X -->
+ ;; X: varref-Y Z: ... dup varset-Y goto-Z
+ ;; (varset-X goto-BACK, BACK: varref-X --> copy the varref down.)
+ ;; (This is so usual for while loops that it is worth handling).
+ ;;
+ ((and (eq (car lap1) 'byte-varset)
+ (eq (car lap2) 'byte-goto)
+ (not (memq (cdr lap2) rest)) ;Backwards jump
+ (eq (car (car (setq tmp (cdr (memq (cdr lap2) lap)))))
+ 'byte-varref)
+ (eq (cdr (car tmp)) (cdr lap1))
+ (not (memq (car (cdr lap1)) byte-boolean-vars)))
+ ;;(byte-compile-log-lap " Pulled %s to end of loop" (car tmp))
+ (let ((newtag (byte-compile-make-tag)))
+ (byte-compile-log-lap
+ " %s: %s ... %s %s\t-->\t%s: %s %s: ... %s %s %s"
+ (nth 1 (cdr lap2)) (car tmp)
+ lap1 lap2
+ (nth 1 (cdr lap2)) (car tmp)
+ (nth 1 newtag) 'byte-dup lap1
+ (cons 'byte-goto newtag)
+ )
+ (setcdr rest (cons (cons 'byte-dup 0) (cdr rest)))
+ (setcdr tmp (cons (setcdr lap2 newtag) (cdr tmp))))
+ (setq add-depth 1)
+ (setq keep-going t))
+ ;;
+ ;; goto-X Y: ... X: goto-if*-Y --> goto-if-not-*-X+1 Y:
+ ;; (This can pull the loop test to the end of the loop)
+ ;;
+ ((and (eq (car lap0) 'byte-goto)
+ (eq (car lap1) 'TAG)
+ (eq lap1
+ (cdr (car (setq tmp (cdr (memq (cdr lap0) lap))))))
+ (memq (car (car tmp))
+ '(byte-goto byte-goto-if-nil byte-goto-if-not-nil
+ byte-goto-if-nil-else-pop)))
+;; (byte-compile-log-lap " %s %s, %s %s --> moved conditional"
+;; lap0 lap1 (cdr lap0) (car tmp))
+ (let ((newtag (byte-compile-make-tag)))
+ (byte-compile-log-lap
+ "%s %s: ... %s: %s\t-->\t%s ... %s:"
+ lap0 (nth 1 lap1) (nth 1 (cdr lap0)) (car tmp)
+ (cons (cdr (assq (car (car tmp))
+ '((byte-goto-if-nil . byte-goto-if-not-nil)
+ (byte-goto-if-not-nil . byte-goto-if-nil)
+ (byte-goto-if-nil-else-pop .
+ byte-goto-if-not-nil-else-pop)
+ (byte-goto-if-not-nil-else-pop .
+ byte-goto-if-nil-else-pop))))
+ newtag)
+
+ (nth 1 newtag)
+ )
+ (setcdr tmp (cons (setcdr lap0 newtag) (cdr tmp)))
+ (if (eq (car (car tmp)) 'byte-goto-if-nil-else-pop)
+ ;; We can handle this case but not the -if-not-nil case,
+ ;; because we won't know which non-nil constant to push.
+ (setcdr rest (cons (cons 'byte-constant
+ (byte-compile-get-constant nil))
+ (cdr rest))))
+ (setcar lap0 (nth 1 (memq (car (car tmp))
+ '(byte-goto-if-nil-else-pop
+ byte-goto-if-not-nil
+ byte-goto-if-nil
+ byte-goto-if-not-nil
+ byte-goto byte-goto))))
+ )
+ (setq keep-going t))
+ )
+ (setq rest (cdr rest)))
+ )
+ ;; Cleanup stage:
+ ;; Rebuild byte-compile-constants / byte-compile-variables.
+ ;; Simple optimizations that would inhibit other optimizations if they
+ ;; were done in the optimizing loop, and optimizations which there is no
+ ;; need to do more than once.
+ (setq byte-compile-constants nil
+ byte-compile-variables nil)
+ (setq rest lap)
+ (while rest
+ (setq lap0 (car rest)
+ lap1 (nth 1 rest))
+ (if (memq (car lap0) byte-constref-ops)
+ (if (eq (cdr lap0) 'byte-constant)
+ (or (memq (cdr lap0) byte-compile-variables)
+ (setq byte-compile-variables (cons (cdr lap0)
+ byte-compile-variables)))
+ (or (memq (cdr lap0) byte-compile-constants)
+ (setq byte-compile-constants (cons (cdr lap0)
+ byte-compile-constants)))))
+ (cond (;;
+ ;; const-C varset-X const-C --> const-C dup varset-X
+ ;; const-C varbind-X const-C --> const-C dup varbind-X
+ ;;
+ (and (eq (car lap0) 'byte-constant)
+ (eq (car (nth 2 rest)) 'byte-constant)
+ (eq (cdr lap0) (car (nth 2 rest)))
+ (memq (car lap1) '(byte-varbind byte-varset)))
+ (byte-compile-log-lap " %s %s %s\t-->\t%s dup %s"
+ lap0 lap1 lap0 lap0 lap1)
+ (setcar (cdr (cdr rest)) (cons (car lap1) (cdr lap1)))
+ (setcar (cdr rest) (cons 'byte-dup 0))
+ (setq add-depth 1))
+ ;;
+ ;; const-X [dup/const-X ...] --> const-X [dup ...] dup
+ ;; varref-X [dup/varref-X ...] --> varref-X [dup ...] dup
+ ;;
+ ((memq (car lap0) '(byte-constant byte-varref))
+ (setq tmp rest
+ tmp2 nil)
+ (while (progn
+ (while (eq 'byte-dup (car (car (setq tmp (cdr tmp))))))
+ (and (eq (cdr lap0) (cdr (car tmp)))
+ (eq (car lap0) (car (car tmp)))))
+ (setcar tmp (cons 'byte-dup 0))
+ (setq tmp2 t))
+ (if tmp2
+ (byte-compile-log-lap
+ " %s [dup/%s]... %s\t-->\t%s dup..." lap0 lap0 lap0)))
+ ;;
+ ;; unbind-N unbind-M --> unbind-(N+M)
+ ;;
+ ((and (eq 'byte-unbind (car lap0))
+ (eq 'byte-unbind (car lap1)))
+ (byte-compile-log-lap " %s %s\t-->\t%s" lap0 lap1
+ (cons 'byte-unbind
+ (+ (cdr lap0) (cdr lap1))))
+ (setq keep-going t)
+ (setq lap (delq lap0 lap))
+ (setcdr lap1 (+ (cdr lap1) (cdr lap0))))
+ )
+ (setq rest (cdr rest)))
+ (setq byte-compile-maxdepth (+ byte-compile-maxdepth add-depth)))
+ lap)
+
+(provide 'byte-optimize)
+
+
+;; To avoid "lisp nesting exceeds max-lisp-eval-depth" when this file compiles
+;; itself, compile some of its most used recursive functions (at load time).
+;;
+(eval-when-compile
+ (or (compiled-function-p (symbol-function 'byte-optimize-form))
+ (assq 'byte-code (symbol-function 'byte-optimize-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-optimize-form
+ byte-optimize-body
+ byte-optimize-predicate
+ byte-optimize-binary-predicate
+ ;; Inserted some more than necessary, to speed it up.
+ byte-optimize-form-code-walker
+ byte-optimize-lapcode))))
+ nil)
diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el
new file mode 100644
index 00000000000..1b30194690e
--- /dev/null
+++ b/lisp/emacs-lisp/bytecomp.el
@@ -0,0 +1,3000 @@
+;;; -*- Mode: Emacs-Lisp -*-
+;;; Compilation of Lisp code into byte code.
+;;; Copyright (C) 1985, 1986, 1987 Free Software Foundation, Inc.
+
+;; By Jamie Zawinski <jwz@lucid.com> and Hallvard Furuseth <hbf@ulrik.uio.no>.
+
+(defconst byte-compile-version "2.04; 5-feb-92.")
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 1, or (at your option)
+;; any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs; see the file COPYING. If not, write to
+;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
+
+;;; ========================================================================
+;;; Entry points:
+;;; byte-recompile-directory, byte-compile-file,
+;;; byte-compile-and-load-file byte-compile-buffer, batch-byte-compile,
+;;; byte-compile, byte-compile-sexp, elisp-compile-defun,
+;;; byte-compile-report-call-tree
+
+;;; This version of the elisp byte compiler has the following improvements:
+;;; + optimization of compiled code:
+;;; - removal of unreachable code;
+;;; - removal of calls to side-effectless functions whose return-value
+;;; is unused;
+;;; - compile-time evaluation of safe constant forms, such as (consp nil)
+;;; and (ash 1 6);
+;;; - open-coding of literal lambdas;
+;;; - peephole optimization of emitted code;
+;;; - trivial functions are left uncompiled for speed.
+;;; + support for inline functions;
+;;; + compile-time evaluation of arbitrary expressions;
+;;; + compile-time warning messages for:
+;;; - functions being redefined with incompatible arglists;
+;;; - functions being redefined as macros, or vice-versa;
+;;; - functions or macros defined multiple times in the same file;
+;;; - functions being called with the incorrect number of arguments;
+;;; - functions being called which are not defined globally, in the
+;;; file, or as autoloads;
+;;; - assignment and reference of undeclared free variables;
+;;; - various syntax errors;
+;;; + correct compilation of nested defuns, defmacros, defvars and defsubsts;
+;;; + correct compilation of top-level uses of macros;
+;;; + the ability to generate a histogram of functions called.
+
+;;; User customization variables:
+;;;
+;;; byte-compile-verbose Whether to report the function currently being
+;;; compiled in the minibuffer;
+;;; byte-optimize Whether to do optimizations; this may be
+;;; t, nil, 'source, or 'byte;
+;;; byte-optimize-log Whether to report (in excruciating detail)
+;;; exactly which optimizations have been made.
+;;; This may be t, nil, 'source, or 'byte;
+;;; byte-compile-error-on-warn Whether to stop compilation when a warning is
+;;; produced;
+;;; byte-compile-delete-errors Whether the optimizer may delete calls or
+;;; variable references that are side-effect-free
+;;; except that they may return an error.
+;;; byte-compile-generate-call-tree Whether to generate a histogram of
+;;; function calls. This can be useful for
+;;; finding unused functions, as well as simple
+;;; performance metering.
+;;; byte-compile-warnings List of warnings to issue, or t. May contain
+;;; 'free-vars (references to variables not in the
+;;; current lexical scope)
+;;; 'unresolved (calls to unknown functions)
+;;; 'callargs (lambda calls with args that don't
+;;; match the lambda's definition)
+;;; 'redefine (function cell redefined from
+;;; a macro to a lambda or vice versa,
+;;; or redefined to take other args)
+;;; This defaults to nil in -batch mode, which is
+;;; slightly faster.
+;;; byte-compile-emacs18-compatibility Whether the compiler should
+;;; generate .elc files which can be loaded into
+;;; generic emacs 18's which don't have the file
+;;; bytecomp-runtime.el loaded as well;
+;;; byte-compile-generate-emacs19-bytecodes Whether to generate bytecodes
+;;; which exist only in emacs19. This is a more
+;;; extreme step than setting emacs18-compatibility
+;;; to nil, because there is no elisp you can load
+;;; into an emacs18 to make files compiled this
+;;; way work.
+;;; byte-compile-single-version Normally the byte-compiler will consult the
+;;; above two variables at runtime, but if this
+;;; variable is true when the compiler itself is
+;;; compiled, then the runtime checks will not be
+;;; made, and compilation will be slightly faster.
+;;; elisp-source-extention-re Regexp for the extention of elisp source-files;
+;;; see also the function byte-compile-dest-file.
+;;; byte-compile-overwrite-file If nil, delete old .elc files before saving.
+;;;
+;;; Most of the above parameters can also be set on a file-by-file basis; see
+;;; the documentation of the `byte-compiler-options' macro.
+
+;;; New Features:
+;;;
+;;; o The form `defsubst' is just like `defun', except that the function
+;;; generated will be open-coded in compiled code which uses it. This
+;;; means that no function call will be generated, it will simply be
+;;; spliced in. Elisp functions calls are very slow, so this can be a
+;;; big win.
+;;;
+;;; You can generally accomplish the same thing with `defmacro', but in
+;;; that case, the defined procedure can't be used as an argument to
+;;; mapcar, etc.
+;;;
+;;; o You can make a given function be inline even if it has already been
+;;; defined with `defun' by using the `proclaim-inline' form like so:
+;;; (proclaim-inline my-function)
+;;; This is, in fact, exactly what `defsubst' does. To make a function no
+;;; longer be inline, you must use `proclaim-notinline'. Beware that if
+;;; you define a function with `defsubst' and later redefine it with
+;;; `defun', it will still be open-coded until you use proclaim-notinline.
+;;;
+;;; o You can also open-code one particular call to a function without
+;;; open-coding all calls. Use the 'inline' form to do this, like so:
+;;;
+;;; (inline (foo 1 2 3)) ;; `foo' will be open-coded
+;;; or...
+;;; (inline ;; `foo' and `baz' will be
+;;; (foo 1 2 3 (bar 5)) ;; open-coded, but `bar' will not.
+;;; (baz 0))
+;;;
+;;; o It is possible to open-code a function in the same file it is defined
+;;; in without having to load that file before compiling it. the
+;;; byte-compiler has been modified to remember function definitions in
+;;; the compilation environment in the same way that it remembers macro
+;;; definitions.
+;;;
+;;; o Forms like ((lambda ...) ...) are open-coded.
+;;;
+;;; o The form `eval-when-compile' is like progn, except that the body
+;;; is evaluated at compile-time. When it appears at top-level, this
+;;; is analagous to the Common Lisp idiom (eval-when (compile) ...).
+;;; When it does not appear at top-level, it is similar to the
+;;; Common Lisp #. reader macro (but not in interpreted code.)
+;;;
+;;; o The form `eval-and-compile' is similar to eval-when-compile, but
+;;; the whole form is evalled both at compile-time and at run-time.
+;;;
+;;; o The command Meta-X byte-compile-and-load-file does what you'd think.
+;;;
+;;; o The command elisp-compile-defun is analogous to eval-defun.
+;;;
+;;; o If you run byte-compile-file on a filename which is visited in a
+;;; buffer, and that buffer is modified, you are asked whether you want
+;;; to save the buffer before compiling.
+
+(or (fboundp 'defsubst)
+ ;; This really ought to be loaded already!
+ (load-library "bytecomp-runtime"))
+
+(eval-when-compile
+ (defvar byte-compile-single-version nil
+ "If this is true, the choice of emacs version (v18 or v19) byte-codes will
+be hard-coded into bytecomp when it compiles itself. If the compiler itself
+is compiled with optimization, this causes a speedup.")
+
+ (cond (byte-compile-single-version
+ (defmacro byte-compile-single-version () t)
+ (defmacro byte-compile-version-cond (cond) (list 'quote (eval cond))))
+ (t
+ (defmacro byte-compile-single-version () nil)
+ (defmacro byte-compile-version-cond (cond) cond)))
+ )
+
+;;; The crud you see scattered through this file of the form
+;;; (or (and (boundp 'epoch::version) epoch::version)
+;;; (string-lessp emacs-version "19"))
+;;; is because the Epoch folks couldn't be bothered to follow the
+;;; normal emacs version numbering convention.
+
+(if (byte-compile-version-cond
+ (or (and (boundp 'epoch::version) epoch::version)
+ (string-lessp emacs-version "19")))
+ (progn
+ ;; emacs-18 compatibility.
+ (defvar baud-rate (baud-rate)) ;Define baud-rate if it's undefined
+
+ (if (byte-compile-single-version)
+ (defmacro compiled-function-p (x) "Emacs 18 doesn't have these." nil)
+ (defun compiled-function-p (x) "Emacs 18 doesn't have these." nil))
+
+ (or (and (fboundp 'member)
+ ;; avoid using someone else's possibly bogus definition of this.
+ (subrp (symbol-function 'member)))
+ (defun member (elt list)
+ "like memq, but uses equal instead of eq. In v19, this is a subr."
+ (while (and list (not (equal elt (car list))))
+ (setq list (cdr list)))
+ list))
+ ))
+
+
+(defvar elisp-source-extention-re (if (eq system-type 'vax-vms)
+ "\\.EL\\(;[0-9]+\\)?$"
+ "\\.el$")
+ "*Regexp which matches the extention of elisp source-files.
+You may want to redefine defun byte-compile-dest-file to match this.")
+
+(or (fboundp 'byte-compile-dest-file)
+ ;; The user may want to redefine this along with elisp-source-extention-re,
+ ;; so only define it if it is undefined.
+ (defun byte-compile-dest-file (filename)
+ "Converts an emacs-lisp source-filename to a compiled-filename."
+ (setq filename (file-name-sans-versions filename))
+ (cond ((eq system-type 'vax-vms)
+ (concat (substring filename 0 (string-match ";" filename)) "c"))
+ ((string-match elisp-source-extention-re filename)
+ (concat (substring filename 0 (match-beginning 0)) ".elc"))
+ (t (concat filename "c")))))
+
+;; This can be the 'byte-compile property of any symbol.
+(autoload 'byte-compile-inline-expand "byte-optimize")
+
+;; This is the entrypoint to the lapcode optimizer pass1.
+(autoload 'byte-optimize-form "byte-optimize")
+;; This is the entrypoint to the lapcode optimizer pass2.
+(autoload 'byte-optimize-lapcode "byte-optimize")
+(autoload 'byte-compile-unfold-lambda "byte-optimize")
+
+(defvar byte-compile-verbose
+ (and (not noninteractive) (> baud-rate search-slow-speed))
+ "*Non-nil means print messages describing progress of byte-compiler.")
+
+(defvar byte-compile-emacs18-compatibility
+ (or (and (boundp 'epoch::version) epoch::version)
+ (string-lessp emacs-version "19"))
+ "*If this is true, then the byte compiler will generate .elc files which will
+work in generic version 18 emacses without having bytecomp-runtime.el loaded.
+If this is false, the generated code will be more efficient in emacs 19, and
+will be loadable in emacs 18 only if bytecomp-runtime.el is loaded.
+See also byte-compile-generate-emacs19-bytecodes.")
+
+(defvar byte-compile-generate-emacs19-bytecodes
+ (not (or (and (boundp 'epoch::version) epoch::version)
+ (string-lessp emacs-version "19")))
+ "*If this is true, then the byte-compiler will generate bytecode which
+makes use of byte-ops which are present only in emacs19. Code generated
+this way can never be run in emacs18, and may even cause it to crash.")
+
+(defvar byte-optimize t
+ "*If nil, no compile-optimizations will be done.
+Compilation will be faster, generated code will be slower and larger.
+This may be nil, t, 'byte, or 'source. If it is 'byte, then only byte-level
+optimizations will be done; if it is 'source, then only source-level
+optimizations will be done.")
+
+(defvar byte-compile-delete-errors t
+ "*If non-nil, the optimizer may delete forms that may signal an error
+(variable references and side-effect-free functions such as CAR).")
+
+(defvar 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.")
+
+(defvar byte-compile-error-on-warn nil
+ "*If true, the byte-compiler will report warnings with `error' instead
+of `message.'")
+
+(defconst byte-compile-warning-types '(redefine callargs free-vars unresolved))
+(defvar byte-compile-warnings (not noninteractive)
+ "*List of warnings that the byte-compiler should issue (t for all).
+See doc of macro byte-compiler-options.")
+
+(defvar byte-compile-generate-call-tree nil
+ "*If this is true, then the compiler will collect statistics on what
+functions were called and from where. This will be displayed after the
+compilation completes. If it is non-nil, but not t, you will be asked
+for whether to display this.
+
+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.")
+
+(defconst 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.")
+
+(defvar byte-compile-call-tree-sort 'name
+ "*If non nil, the call tree is sorted.
+The values 'name, 'callers, 'calls, 'calls+callers means to sort on
+the those fields.")
+
+(defvar byte-compile-overwrite-file t
+ "If nil, old .elc files are deleted before the new is saved, and .elc
+files will have the same modes as the corresponding .el file. Otherwise,
+existing .elc files will simply be overwritten, and the existing modes
+will not be changed. If this variable is nil, then an .elc file which
+is a symbolic link will be turned into a normal file, instead of the file
+which the link points to being overwritten.")
+
+(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-free-references)
+(defvar byte-compile-free-assignments)
+
+(defconst byte-compile-initial-macro-environment
+ '((byte-compiler-options . (lambda (&rest forms)
+ (apply 'byte-compiler-options-handler forms)))
+ (eval-when-compile . (lambda (&rest body)
+ (list 'quote (eval (byte-compile-top-level
+ (cons 'progn body))))))
+ (eval-and-compile . (lambda (&rest body)
+ (eval (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 (MACRONAME . DEFINITION) macros defined in the file which is being
+compiled. It is (MACRONAME . nil) when a macro is redefined as a function.")
+
+(defvar byte-compile-function-environment nil
+ "Alist of (FUNCTIONNAME . DEFINITION) functions defined in the file which
+is being compiled (this is so we can inline them if necessary). It is
+(FUNCTIONNAME . nil) when a function is redefined as a macro.")
+
+(defvar byte-compile-unresolved-functions nil
+ "Alist of undefined functions to which calls have been compiled (used for
+warnings when the function is later defined with incorrect args).")
+
+(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.")
+
+
+;;; The byte codes; this information is duplicated in bytecomp.c
+
+(defconst byte-code-vector nil
+ "An array containing byte-code names indexed by byte-code values.")
+
+(defconst byte-stack+-info nil
+ "An array with the stack adjustment for each byte-code.")
+
+(defmacro byte-defop (opcode stack-adjust opname &optional docstring)
+ ;; This is a speed-hack for building the byte-code-vector at compile-time.
+ ;; We fill in the vector at macroexpand-time, and then after the last call
+ ;; to byte-defop, we write the vector out as a constant instead of writing
+ ;; out a bunch of calls to aset.
+ ;; Actually, we don't fill in the vector itself, because that could make
+ ;; it problematic to compile big changes to this compiler; we store the
+ ;; values on its plist, and remove them later in -extrude.
+ (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))
+ ;; emacs-18 has no REMPROP.
+ (put 'byte-code-vector 'tmp-compile-time-value nil)
+ (put 'byte-stack+-info 'tmp-compile-time-value nil)))
+
+
+;; unused: 0-7
+
+;; These opcodes are special in that they pack their argument into the
+;; opcode word.
+;;
+(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")
+;; codes 41-47 are consumed by the preceeding opcodes
+
+;; unused: 48-55
+
+(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) ; this was commented out
+(byte-defop 76 -1 byte-set)
+(byte-defop 77 -1 byte-fset) ; this was commented out
+(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) ; v19 only
+(byte-defop 96 1 byte-point)
+(byte-defop 97 1 byte-mark-OBSOLETE) ; no longer generated as of v18
+(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) ; no longer generated as of v18
+(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 1 byte-read-char-OBSOLETE)
+(byte-defop 115 0 byte-set-mark-OBSOLETE)
+(byte-defop 116 1 byte-interactive-p)
+
+;; These ops are new to v19
+(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)
+
+;; unused: 128
+
+;; These store their argument in the next two bytes
+(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
+ "for condition-case. Takes, on stack, the variable to bind,
+an expression for the body, and a list of clauses")
+
+(byte-defop 144 0 byte-temp-output-buffer-setup
+ "for entry to with-output-to-temp-buffer.
+Takes, on stack, the buffer name.
+Binds standard-output and does some other things.
+Returns with temp buffer on the stack in place of buffer name")
+
+(byte-defop 145 -1 byte-temp-output-buffer-show
+ "for exit from with-output-to-temp-buffer.
+Expects the temp buffer on the stack underneath value to return.
+Pops them both, then pushes the value back on.
+Unbinds standard-output and makes the temp buffer visible")
+
+;; these ops are new to v19
+(byte-defop 146 0 byte-unbind-all "to unbind back to the beginning of
+this frame. Not used yet, but wil be needed for tail-recursion elimination.")
+
+;; these ops are new to v19
+(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)
+
+;; unused: 169
+
+;; New to v19. These store their arg in the next byte.
+(byte-defop 170 0 byte-rel-goto)
+(byte-defop 171 -1 byte-rel-goto-if-nil)
+(byte-defop 172 -1 byte-rel-goto-if-not-nil)
+(byte-defop 173 -1 byte-rel-goto-if-nil-else-pop)
+(byte-defop 174 -1 byte-rel-goto-if-not-nil-else-pop)
+
+(byte-defop 175 nil byte-listN)
+(byte-defop 176 nil byte-concatN)
+(byte-defop 177 nil byte-insertN)
+
+;; unused: 178-191
+
+(byte-defop 192 1 byte-constant "for reference to a constant")
+;; codes 193-255 are consumed by byte-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)
+ "those byte-codes whose offset is a pc.")
+
+(defconst byte-goto-always-pop-ops '(byte-goto-if-nil byte-goto-if-not-nil))
+
+(defconst byte-rel-goto-ops '(byte-rel-goto
+ byte-rel-goto-if-nil byte-rel-goto-if-not-nil
+ byte-rel-goto-if-nil-else-pop
+ byte-rel-goto-if-not-nil-else-pop)
+ "byte-codes for relative jumps.")
+
+(byte-extrude-byte-code-vectors)
+
+;;; lapcode generator
+;;;
+;;; the byte-compiler now does source -> lapcode -> bytecode instead of
+;;; source -> bytecode, because it's a lot easier to make optimizations
+;;; on lapcode than on bytecode.
+;;;
+;;; Elements of the lapcode list are of the form (<instruction> . <parameter>)
+;;; where instruction is a symbol naming a byte-code instruction,
+;;; and parameter is an argument to that instruction, if any.
+;;;
+;;; The instruction can be the pseudo-op TAG, which means that this position
+;;; in the instruction stream is a target of a goto. (car PARAMETER) will be
+;;; the PC for this location, and the whole instruction "(TAG pc)" will be the
+;;; parameter for some goto op.
+;;;
+;;; If the operation is varbind, varref, varset or push-constant, then the
+;;; parameter is (variable/constant . index_in_constant_vector).
+;;;
+;;; First, the source code is macroexpanded and optimized in various ways.
+;;; Then the resultant code is compiled into lapcode. Another set of
+;;; optimizations are then run over the lapcode. Then the variables and
+;;; constants referenced by the lapcode are collected and placed in the
+;;; constants-vector. (This happens now so that variables referenced by dead
+;;; code don't consume space.) And finally, the lapcode is transformed into
+;;; compacted byte-code.
+;;;
+;;; A distinction is made between variables and constants because the variable-
+;;; referencing instructions are more sensitive to the variables being near the
+;;; front of the constants-vector than the constant-referencing instructions.
+;;; Also, this lets us notice references to free variables.
+
+(defun byte-compile-lapcode (lap)
+ "Turns lapcode into bytecode. The lapcode is destroyed."
+ ;; Lapcode modifications: changes the ID of a tag to be the tag's PC.
+ (let ((pc 0) ; Program counter
+ op off ; Operation & offset
+ (bytes '()) ; Put the output bytes here
+ (patchlist nil) ; List of tags and goto's to patch
+ rest rel tmp)
+ (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)
+ ;; Variable or constant reference
+ (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)))
+ ;;(if (not (= pc (length bytes)))
+ ;; (error "compiler error: pc mismatch - %s %s" pc (length bytes)))
+ (cond ((byte-compile-version-cond byte-compile-generate-emacs19-bytecodes)
+ ;; Make relative jumps
+ (setq patchlist (nreverse patchlist))
+ (while (progn
+ (setq off 0) ; PC change because of deleted bytes
+ (setq rest patchlist)
+ (while rest
+ (setq tmp (car rest))
+ (and (consp (car tmp)) ; Jump
+ (prog1 (null (nth 1 tmp)) ; Absolute jump
+ (setq tmp (car tmp)))
+ (progn
+ (setq rel (- (car (cdr tmp)) (car tmp)))
+ (and (<= -129 rel) (< rel 128)))
+ (progn
+ ;; Convert to relative jump.
+ (setcdr (car rest) (cdr (cdr (car rest))))
+ (setcar (cdr (car rest))
+ (+ (car (cdr (car rest)))
+ (- byte-rel-goto byte-goto)))
+ (setq off (1- off))))
+ (setcar tmp (+ (car tmp) off)) ; Adjust PC
+ (setq rest (cdr rest)))
+ ;; If optimizing, repeat until no change.
+ (and byte-optimize
+ (not (zerop off)))))))
+ ;; Patch PC into jumps
+ (let (bytes)
+ (while patchlist
+ (setq bytes (car patchlist))
+ (cond ((atom (car bytes))) ; Tag
+ ((nth 1 bytes) ; Relative jump
+ (setcar bytes (+ (- (car (cdr (car bytes))) (car (car bytes)))
+ 128)))
+ (t ; Absolute jump
+ (setq pc (car (cdr (car bytes)))) ; Pick PC from tag
+ (setcar (cdr bytes) (logand pc 255))
+ (setcar bytes (lsh pc -8))))
+ (setq patchlist (cdr patchlist))))
+ (concat (nreverse bytes))))
+
+
+;;; byte compiler messages
+
+(defconst byte-compile-current-form nil)
+(defconst byte-compile-current-file nil)
+
+(defmacro byte-compile-log (format-string &rest args)
+ (list 'and
+ 'byte-optimize
+ '(memq byte-optimize-log '(t source))
+ (list 'let '((print-escape-newlines t)
+ (print-level 4)
+ (print-length 4))
+ (list 'byte-compile-log-1
+ (cons 'format
+ (cons format-string
+ (mapcar
+ '(lambda (x)
+ (if (symbolp x) (list 'prin1-to-string x) x))
+ args)))))))
+
+(defconst byte-compile-last-warned-form nil)
+
+(defun byte-compile-log-1 (string)
+ (cond (noninteractive
+ (if (or byte-compile-current-file
+ (and byte-compile-last-warned-form
+ (not (eq byte-compile-current-form
+ byte-compile-last-warned-form))))
+ (message (format "While compiling %s%s:"
+ (or byte-compile-current-form "toplevel forms")
+ (if byte-compile-current-file
+ (if (stringp byte-compile-current-file)
+ (concat " in file " byte-compile-current-file)
+ (concat " in buffer "
+ (buffer-name byte-compile-current-file)))
+ ""))))
+ (message " %s" string))
+ (t
+ (save-excursion
+ (set-buffer (get-buffer-create "*Compile-Log*"))
+ (goto-char (point-max))
+ (cond ((or byte-compile-current-file
+ (and byte-compile-last-warned-form
+ (not (eq byte-compile-current-form
+ byte-compile-last-warned-form))))
+ (if byte-compile-current-file
+ (insert "\n\^L\n" (current-time-string) "\n"))
+ (insert "While compiling "
+ (if byte-compile-current-form
+ (format "%s" byte-compile-current-form)
+ "toplevel forms"))
+ (if byte-compile-current-file
+ (if (stringp byte-compile-current-file)
+ (insert " in file " byte-compile-current-file)
+ (insert " in buffer "
+ (buffer-name byte-compile-current-file))))
+ (insert ":\n")))
+ (insert " " string "\n"))))
+ (setq byte-compile-current-file nil
+ byte-compile-last-warned-form byte-compile-current-form))
+
+(defun byte-compile-warn (format &rest args)
+ (setq format (apply 'format format args))
+ (if byte-compile-error-on-warn
+ (error "%s" format) ; byte-compile-file catches and logs it
+ (byte-compile-log-1 (concat "** " format))
+ (or noninteractive ; already written on stdout.
+ (message "Warning: %s" format))))
+
+;;; Used by make-obsolete.
+(defun byte-compile-obsolete (form)
+ (let ((new (get (car form) 'byte-obsolete-info)))
+ (byte-compile-warn "%s is an obsolete function; %s" (car form)
+ (if (stringp (car new))
+ (car new)
+ (format "use %s instead." (car new))))
+ (funcall (or (cdr new) 'byte-compile-normal-call) form)))
+
+;; Compiler options
+
+(defvar byte-compiler-legal-options
+ '((optimize byte-optimize (t nil source byte) val)
+ (file-format byte-compile-emacs18-compatibility (emacs18 emacs19)
+ (eq val 'emacs18))
+ (new-bytecodes byte-compile-generate-emacs19-bytecodes (t nil) val)
+ (delete-errors byte-compile-delete-errors (t nil) val)
+ (verbose byte-compile-verbose (t nil) val)
+ (warnings byte-compile-warnings ((callargs redefine free-vars unresolved))
+ val)))
+
+;; Inhibit v18/v19 selectors if the version is hardcoded.
+;; #### This should print a warning if the user tries to change something
+;; than can't be changed because the running compiler doesn't support it.
+(cond
+ ((byte-compile-single-version)
+ (setcar (cdr (cdr (assq 'new-bytecodes byte-compiler-legal-options)))
+ (list (byte-compile-version-cond
+ byte-compile-generate-emacs19-bytecodes)))
+ (setcar (cdr (cdr (assq 'file-format byte-compiler-legal-options)))
+ (if (byte-compile-version-cond byte-compile-emacs18-compatibility)
+ '(emacs18) '(emacs19)))))
+
+(defun byte-compiler-options-handler (&rest args)
+ (let (key val desc choices)
+ (while args
+ (if (or (atom (car args)) (nthcdr 2 (car args)) (null (cdr (car args))))
+ (error "malformed byte-compiler-option %s" (car args)))
+ (setq key (car (car args))
+ val (car (cdr (car args)))
+ desc (assq key byte-compiler-legal-options))
+ (or desc
+ (error "unknown byte-compiler option %s" key))
+ (setq choices (nth 2 desc))
+ (if (consp (car choices))
+ (let (this
+ (handler 'cons)
+ (ret (and (memq (car val) '(+ -))
+ (copy-sequence (if (eq t (symbol-value (nth 1 desc)))
+ choices
+ (symbol-value (nth 1 desc)))))))
+ (setq choices (car choices))
+ (while val
+ (setq this (car val))
+ (cond ((memq this choices)
+ (setq ret (funcall handler this ret)))
+ ((eq this '+) (setq handler 'cons))
+ ((eq this '-) (setq handler 'delq))
+ ((error "%s only accepts %s." key choices)))
+ (setq val (cdr val)))
+ (set (nth 1 desc) ret))
+ (or (memq val choices)
+ (error "%s must be one of %s." key choices))
+ (set (nth 1 desc) (eval (nth 3 desc))))
+ (setq args (cdr args)))
+ nil))
+
+;;; sanity-checking arglists
+
+(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)
+ (compiled-function-p (symbol-function fn)))))
+ (setq fn (symbol-function fn)))
+ (if (and (not macro-p) (compiled-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)) ; requires more args now
+ (and (null (cdr old)) ; tooks rest-args, doesn't any more
+ (cdr new))
+ (and (cdr new) (cdr old) ; can't take as many args now
+ (< (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)
+ "warn if the form is calling a function with the wrong number of arguments."
+ (let* ((def (or (byte-compile-fdefinition (car form) nil)
+ (byte-compile-fdefinition (car form) t)))
+ (sig (and def (byte-compile-arglist-signature
+ (if (eq 'lambda (car-safe def))
+ (nth 1 def)
+ (aref def 0)))))
+ (ncall (length (cdr form))))
+ (if sig
+ (if (or (< ncall (car sig))
+ (and (cdr sig) (> ncall (cdr sig))))
+ (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)))
+ (or (fboundp (car form)) ; might be a subr or autoload.
+ (eq (car form) byte-compile-current-form) ; ## this doesn't work with recursion.
+ ;; It's a currently-undefined function. Remember number of args in call.
+ (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))))
+ (setq byte-compile-unresolved-functions
+ (cons (list (car form) n)
+ byte-compile-unresolved-functions))))))))
+
+(defun byte-compile-arglist-warn (form macrop)
+ "warn if the function or macro is being redefined with a different
+number of arguments."
+ (let ((old (byte-compile-fdefinition (nth 1 form) macrop)))
+ (if old
+ (let ((sig1 (byte-compile-arglist-signature
+ (if (eq 'lambda (car-safe old))
+ (nth 1 old)
+ (aref old 0))))
+ (sig2 (byte-compile-arglist-signature (nth 2 form))))
+ (or (byte-compile-arglist-signatures-congruent-p sig1 sig2)
+ (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))))
+ ;; This is the first definition. See if previous calls are compatible.
+ (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)))
+ (if (or (< min (car sig))
+ (and (cdr sig) (> max (cdr sig))))
+ (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)))))
+ )))
+
+(defun byte-compile-warn-about-unresolved-functions ()
+ "If we have compiled any calls to functions which are not known to be
+defined, issue a warning enumerating them. You can disable this by including
+'unresolved in variable byte-compile-warnings."
+ (if (memq 'unresolved byte-compile-warnings)
+ (let ((byte-compile-current-form "the end of the data"))
+ (if (cdr byte-compile-unresolved-functions)
+ (let* ((str "The following functions are not known to be defined: ")
+ (L (length str))
+ (rest (reverse byte-compile-unresolved-functions))
+ s)
+ (while rest
+ (setq s (symbol-name (car (car rest)))
+ L (+ L (length s) 2)
+ rest (cdr rest))
+ (if (< L (1- fill-column))
+ (setq str (concat str " " s (and rest ",")))
+ (setq str (concat str "\n " s (and rest ","))
+ L (+ (length s) 4))))
+ (byte-compile-warn "%s" str))
+ (if byte-compile-unresolved-functions
+ (byte-compile-warn "the function %s is not known to be defined."
+ (car (car byte-compile-unresolved-functions)))))))
+ nil)
+
+
+(defmacro byte-compile-constp (form)
+ ;; Returns non-nil if FORM is a constant.
+ (` (cond ((consp (, form)) (eq (car (, form)) 'quote))
+ ((not (symbolp (, form))))
+ ((memq (, form) '(nil t))))))
+
+(defmacro byte-compile-close-variables (&rest body)
+ (cons 'let
+ (cons '(;;
+ ;; Close over these variables to encapsulate the
+ ;; compilation state
+ ;;
+ (byte-compile-macro-environment
+ ;; Copy it because the compiler may patch into the
+ ;; macroenvironment.
+ (copy-alist byte-compile-initial-macro-environment))
+ (byte-compile-function-environment nil)
+ (byte-compile-bound-variables nil)
+ (byte-compile-free-references nil)
+ (byte-compile-free-assignments nil)
+ ;;
+ ;; Close over these variables so that `byte-compiler-options'
+ ;; can change them on a per-file basis.
+ ;;
+ (byte-compile-verbose byte-compile-verbose)
+ (byte-optimize byte-optimize)
+ (byte-compile-generate-emacs19-bytecodes
+ byte-compile-generate-emacs19-bytecodes)
+ (byte-compile-warnings (if (eq byte-compile-warnings t)
+ byte-compile-warning-types
+ byte-compile-warnings))
+ )
+ body)))
+
+(defvar byte-compile-warnings-point-max)
+(defmacro displaying-byte-compile-warnings (&rest body)
+ (list 'let
+ '((byte-compile-warnings-point-max
+ (if (boundp 'byte-compile-warnings-point-max)
+ byte-compile-warnings-point-max
+ (save-excursion
+ (set-buffer (get-buffer-create "*Compile-Log*"))
+ (point-max)))))
+ (list 'unwind-protect (cons 'progn body)
+ '(save-excursion
+ ;; If there were compilation warnings, display them.
+ (set-buffer "*Compile-Log*")
+ (if (= byte-compile-warnings-point-max (point-max))
+ nil
+ (select-window
+ (prog1 (selected-window)
+ (select-window (display-buffer (current-buffer)))
+ (goto-char byte-compile-warnings-point-max)
+ (recenter 1))))))))
+
+
+(defun byte-recompile-directory (directory &optional arg)
+ "Recompile every `.el' file in DIRECTORY that needs recompilation.
+This is if a `.elc' file exists but is older than the `.el' file.
+
+If the `.elc' file does not exist, normally the `.el' file is *not* compiled.
+But a prefix argument (optional second arg) means ask user,
+for each such `.el' file, whether to compile it."
+ (interactive "DByte recompile directory: \nP")
+ (save-some-buffers)
+ (set-buffer-modified-p (buffer-modified-p)) ;Update the mode line.
+ (setq directory (expand-file-name directory))
+ (let ((files (directory-files directory nil elisp-source-extention-re))
+ (count 0)
+ source dest)
+ (while files
+ (if (and (not (auto-save-file-name-p (car files)))
+ (setq source (expand-file-name (car files) directory))
+ (setq dest (byte-compile-dest-file source))
+ (if (file-exists-p dest)
+ (file-newer-than-file-p source dest)
+ (and arg (y-or-n-p (concat "Compile " source "? ")))))
+ (progn (byte-compile-file source)
+ (setq count (1+ count))))
+ (setq files (cdr files)))
+ (message "Done (Total of %d file%s compiled)"
+ count (if (= count 1) "" "s"))))
+
+(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 made by appending `c' to the end of FILENAME.
+With prefix arg (noninteractively: 2nd arg), load the file after compiling."
+;; (interactive "fByte compile file: \nP")
+ (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 (if (byte-compile-version-cond
+ (or (and (boundp 'epoch::version) epoch::version)
+ (string-lessp emacs-version "19")))
+ (read-file-name (if current-prefix-arg
+ "Byte compile and load file: "
+ "Byte compile file: ")
+ file-dir file-name nil)
+ (read-file-name (if current-prefix-arg
+ "Byte compile and load file: "
+ "Byte compile file: ")
+ file-dir nil nil file-name))
+ current-prefix-arg)))
+ ;; Expand now so we get the current buffer's defaults
+ (setq filename (expand-file-name filename))
+
+ ;; If we're compiling a file that's in a buffer and is modified, offer
+ ;; to save it first.
+ (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)))))
+
+ (if byte-compile-verbose
+ (message "Compiling %s..." filename))
+ (let ((byte-compile-current-file (file-name-nondirectory filename))
+ target-file)
+ (save-excursion
+ (set-buffer (get-buffer-create " *Compiler Input*"))
+ (erase-buffer)
+ (insert-file-contents filename)
+ ;; Run hooks including the uncompression hook.
+ ;; If they change the file name, then change it for the output also.
+ (let ((buffer-file-name filename))
+ (set-auto-mode)
+ (setq filename buffer-file-name))
+ (kill-buffer (prog1 (current-buffer)
+ (set-buffer (byte-compile-from-buffer (current-buffer)))))
+ (goto-char (point-max))
+ (insert "\n") ; aaah, unix.
+ (let ((vms-stmlf-recfm t))
+ (setq target-file (byte-compile-dest-file filename))
+ (or byte-compile-overwrite-file
+ (condition-case ()
+ (delete-file target-file)
+ (error nil)))
+ (if (file-writable-p target-file)
+ (let ((kanji-flag nil)) ; for nemacs, from Nakagawa Takayuki
+ (write-region 1 (point-max) target-file))
+ ;; This is just to give a better error message than write-region
+ (signal 'file-error (list "Opening output file"
+ (if (file-exists-p target-file)
+ "cannot overwrite file"
+ "directory not writable or nonexistent")
+ target-file)))
+ (or byte-compile-overwrite-file
+ (condition-case ()
+ (set-file-modes target-file (file-modes filename))
+ (error nil))))
+ (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
+ (byte-compile-report-call-tree filename)))
+ (if load
+ (load target-file)))
+ t)
+
+(defun byte-compile-and-load-file (&optional filename)
+ "Compile a file of Lisp code named FILENAME into a file of byte code,
+and then load it. The output file's name is made by appending \"c\" to
+the end of FILENAME."
+ (interactive)
+ (if filename ; I don't get it, (interactive-p) doesn't always work
+ (byte-compile-file filename t)
+ (let ((current-prefix-arg '(4)))
+ (call-interactively 'byte-compile-file))))
+
+
+(defun byte-compile-buffer (&optional buffer)
+ "Byte-compile and evaluate contents of BUFFER (default: the current buffer)."
+ (interactive "bByte compile buffer: ")
+ (setq buffer (if buffer (get-buffer buffer) (current-buffer)))
+ (message "Compiling %s..." (buffer-name buffer))
+ (let* ((filename (or (buffer-file-name buffer)
+ (concat "#<buffer " (buffer-name buffer) ">")))
+ (byte-compile-current-file buffer))
+ (byte-compile-from-buffer buffer t))
+ (message "Compiling %s...done" (buffer-name buffer))
+ t)
+
+;;; compiling a single function
+(defun elisp-compile-defun (&optional arg)
+ "Compile and evaluate the current top-level form.
+Print the result in the minibuffer.
+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-last-warned-form 'nothing)
+ (value (eval (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 eval)
+ ;; buffer --> output-buffer, or buffer --> eval form, return nil
+ (let (outbuffer)
+ (let (;; Prevent truncation of flonums and lists as we read and print them
+ (float-output-format "%20e")
+ (case-fold-search nil)
+ (print-length nil)
+ ;; Simulate entry to byte-compile-top-level
+ (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)
+ ;; #### This is bound in b-c-close-variables.
+ ;;(byte-compile-warnings (if (eq byte-compile-warnings t)
+ ;; byte-compile-warning-types
+ ;; byte-compile-warnings))
+ )
+ (byte-compile-close-variables
+ (save-excursion
+ (setq outbuffer
+ (set-buffer (get-buffer-create " *Compiler Output*")))
+ (erase-buffer)
+;; (emacs-lisp-mode)
+ (setq case-fold-search nil))
+ (displaying-byte-compile-warnings
+ (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)))
+ (byte-compile-file-form (read inbuffer)))
+ ;; Compile pending forms at end of file.
+ (byte-compile-flush-pending)
+ (and (not eval) (byte-compile-insert-header))
+ (byte-compile-warn-about-unresolved-functions)
+ ;; always do this? When calling multiple files, it would be useful
+ ;; to delay this warning until all have been compiled.
+ (setq byte-compile-unresolved-functions nil)))
+ (save-excursion
+ (set-buffer outbuffer)
+ (goto-char (point-min)))))
+ (if (not eval)
+ outbuffer
+ (while (condition-case nil
+ (progn (setq form (read outbuffer))
+ t)
+ (end-of-file nil))
+ (eval form))
+ (kill-buffer outbuffer)
+ nil)))
+
+(defun byte-compile-insert-header ()
+ (save-excursion
+ (set-buffer outbuffer)
+ (goto-char 1)
+ (insert ";;; compiled by " (user-login-name) "@" (system-name) " on "
+ (current-time-string) "\n;;; from file " filename "\n")
+ (insert ";;; emacs version " emacs-version ".\n")
+ (insert ";;; bytecomp version " byte-compile-version "\n;;; "
+ (cond
+ ((eq byte-optimize 'source) "source-level optimization only")
+ ((eq byte-optimize 'byte) "byte-level optimization only")
+ (byte-optimize "optimization is on")
+ (t "optimization is off"))
+ (if (byte-compile-version-cond byte-compile-emacs18-compatibility)
+ "; compiled with emacs18 compatibility.\n"
+ ".\n"))
+ (if (byte-compile-version-cond byte-compile-generate-emacs19-bytecodes)
+ (insert ";;; this file uses opcodes which do not exist in Emacs18.\n"
+ ;; Have to check if emacs-version is bound so that this works
+ ;; in files loaded early in loadup.el.
+ "\n(if (and (boundp 'emacs-version)\n"
+ "\t (or (and (boundp 'epoch::version) epoch::version)\n"
+ "\t (string-lessp emacs-version \"19\")))\n"
+ " (error \"This file was compiled for Emacs19.\"))\n"
+ ))
+ ))
+
+
+(defun byte-compile-output-file-form (form)
+ ;; writes the given form to the output buffer, being careful of docstrings
+ ;; in defun, defmacro, defvar, defconst and autoload because make-docfile is
+ ;; so amazingly stupid.
+ ;; fset's are output directly by byte-compile-file-form-defmumble; it does
+ ;; not pay to first build the fset in defmumble and then parse it here.
+ (if (and (memq (car-safe form) '(defun defmacro defvar defconst autoload))
+ (stringp (nth 3 form)))
+ (byte-compile-output-docform '("\n(" 3 ")") form)
+ (let ((print-escape-newlines t)
+ (print-readably t))
+ (princ "\n" outbuffer)
+ (prin1 form outbuffer)
+ nil)))
+
+(defun byte-compile-output-docform (info form)
+ ;; Print a form with a doc string. INFO is (prefix doc-index postfix).
+ (set-buffer
+ (prog1 (current-buffer)
+ (set-buffer outbuffer)
+ (insert (car info))
+ (let ((docl (nthcdr (nth 1 info) form))
+ (print-escape-newlines t)
+ (print-readably t))
+ (prin1 (car form) outbuffer)
+ (while (setq form (cdr form))
+ (insert " ")
+ (if (eq form docl)
+ (let ((print-escape-newlines nil))
+ (goto-char (prog1 (1+ (point))
+ (prin1 (car form) outbuffer)))
+ (insert "\\\n")
+ (goto-char (point-max)))
+ (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))
+ ;; To avoid consing up monstrously large forms at load time, we split
+ ;; the output regularly.
+ (and (eq (car-safe form) 'fset) (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)
+ (mapcar '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) ; close over this for warnings.
+ 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)))))
+
+;; Functions and variables with doc strings must be output separately,
+;; so make-docfile can recognise them. Most other things can be output
+;; as byte-code.
+
+(put 'defsubst 'byte-hunk-handler 'byte-compile-file-form-defsubst)
+(defun byte-compile-file-form-defsubst (form)
+ (cond ((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))
+ ;; Return nil so the form is not output twice.
+ 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)) ;Constants only
+ (eval (nth 5 form)) ;Macro
+ (eval form)) ;Define the autoload.
+ (if (stringp (nth 3 form))
+ form
+ ;; No doc string, so we can compile this as a normal 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))
+ ;; Since there is no doc string, we can compile this as a normal form,
+ ;; and not do a file-boundary.
+ (byte-compile-keep-pending form)
+ (if (memq 'free-vars byte-compile-warnings)
+ (setq byte-compile-bound-variables
+ (cons (nth 1 form) byte-compile-bound-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 'require 'byte-hunk-handler 'byte-compile-file-form-eval-boundary)
+(defun byte-compile-file-form-eval-boundary (form)
+ (eval form)
+ (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)
+ (mapcar 'byte-compile-file-form (cdr form))
+ ;; Return nil so the forms are not output twice.
+ nil)
+
+;; This handler is not necessary, but it makes the output from dont-compile
+;; and similar macros cleaner.
+(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))
+
+ ;; When a function or macro is defined, add it to the call tree so that
+ ;; we can tell when functions are not used.
+ (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) ; for warnings
+ (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)
+ ;; don't warn when compiling the stubs in bytecomp-runtime...
+ (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
+ (if (and (memq 'redefine byte-compile-warnings)
+ ;; hack: don't warn when compiling the magic internal
+ ;; byte-compiler macros in bytecomp-runtime.el...
+ (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)))
+ (if (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")))
+ ;; shadow existing definition
+ (set this-kind
+ (cons (cons name nil) (symbol-value this-kind))))
+ )
+ (let ((body (nthcdr 3 form)))
+ (if (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-warn "Probable `\"' without `\\' in doc string of %s"
+ (nth 1 form))))
+ (let* ((new-one (byte-compile-lambda (cons 'lambda (nthcdr 2 form))))
+ (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))))
+ (if (not (stringp (nth 3 form)))
+ ;; No doc string to make-docfile; insert form in normal code.
+ (byte-compile-keep-pending
+ (list 'fset (list 'quote name)
+ (cond ((not macrop)
+ code)
+ ((eq 'make-byte-code (car-safe code))
+ (list 'cons ''macro code))
+ ((list 'quote (if macrop
+ (cons 'macro new-one)
+ new-one)))))
+ 'byte-compile-two-args)
+ ;; Output the form by hand, that's much simpler than having
+ ;; b-c-output-file-form analyze the fset.
+ (byte-compile-flush-pending)
+ (princ "\n(fset '" outbuffer)
+ (prin1 name outbuffer)
+ (byte-compile-output-docform
+ (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))
+ (princ ")" outbuffer)
+ nil)))))
+
+
+(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)
+ (fset 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))))
+
+;; Given a function made by byte-compile-lambda, make a form which produces it.
+(defun byte-compile-byte-code-maker (fun)
+ (cond
+ ((byte-compile-version-cond byte-compile-emacs18-compatibility)
+ ;; Return (quote (lambda ...)).
+ (list 'quote (byte-compile-byte-code-unmake fun)))
+ ;; ## atom is faster than compiled-func-p.
+ ((atom fun) ; compiled function.
+ ;; generate-emacs19-bytecodes must be on, otherwise byte-compile-lambda
+ ;; would have produced a lambda.
+ fun)
+ ;; b-c-lambda didn't produce a compiled-function, so it's either a trivial
+ ;; function, or this is emacs18, or generate-emacs19-bytecodes is off.
+ ((let (tmp)
+ (if (and (setq tmp (assq 'byte-code (cdr-safe (cdr fun))))
+ (null (cdr (memq tmp fun))))
+ ;; Generate a make-byte-code call.
+ (let* ((interactive (assq 'interactive (cdr (cdr fun)))))
+ (nconc (list 'make-byte-code
+ (list 'quote (nth 1 fun)) ;arglist
+ (nth 1 tmp) ;bytes
+ (nth 2 tmp) ;consts
+ (nth 3 tmp)) ;depth
+ (cond ((stringp (nth 2 fun))
+ (list (nth 2 fun))) ;doc
+ (interactive
+ (list nil)))
+ (cond (interactive
+ (list (if (or (null (nth 1 interactive))
+ (stringp (nth 1 interactive)))
+ (nth 1 interactive)
+ ;; Interactive spec is a list or a variable
+ ;; (if it is correct).
+ (list 'quote (nth 1 interactive))))))))
+ ;; a non-compiled function (probably trivial)
+ (list 'quote fun))))))
+
+;; Turn a function into an ordinary lambda. Needed for v18 files.
+(defun byte-compile-byte-code-unmake (function)
+ (if (consp function)
+ function;;It already is a lambda.
+ (setq function (append function nil)) ; turn it into a list
+ (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))))))
+
+
+;; Byte-compile a lambda-expression and return a valid function.
+;; The value is usually a compiled function but may be the original
+;; lambda-expression.
+(defun byte-compile-lambda (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)
+ (setq body (cdr body)))))
+ (int (assq 'interactive body)))
+ (cond (int
+ ;; Skip (interactive) if it is in front (the most usual location).
+ (if (eq int (car body))
+ (setq body (cdr body)))
+ (cond ((cdr int)
+ (if (cdr (cdr int))
+ (byte-compile-warn "malformed interactive spec: %s"
+ (prin1-to-string int)))
+ (setq int (list 'interactive (byte-compile-top-level
+ (nth 1 int))))))))
+ (let ((compiled (byte-compile-top-level (cons 'progn body) nil 'lambda)))
+ (if (and (eq 'byte-code (car-safe compiled))
+ (byte-compile-version-cond
+ byte-compile-generate-emacs19-bytecodes))
+ (apply 'make-byte-code
+ (append (list arglist)
+ ;; byte-string, constants-vector, stack depth
+ (cdr compiled)
+ ;; optionally, the doc string.
+ (if (or doc int)
+ (list doc))
+ ;; optionally, the interactive spec.
+ (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 ()
+ ;; Builds the constants-vector from the current variables and constants.
+ ;; This modifies the constants from (const . nil) to (const . offset).
+ ;; To keep the byte-codes to look up the vector as short as possible:
+ ;; First 6 elements are vars, as there are one-byte varref codes for those.
+ ;; Next up to byte-constant-limit are constants, still with one-byte codes.
+ ;; Next variables again, to get 2-byte codes for variable lookup.
+ ;; The rest of the constants and variables need 3-byte byte-codes.
+ (let* ((i -1)
+ (rest (nreverse byte-compile-variables)) ; nreverse because the first
+ (other (nreverse byte-compile-constants)) ; vars often are used most.
+ ret tmp
+ (limits '(5 ; Use the 1-byte varref codes,
+ 63 ; 1-constlim ; 1-byte byte-constant codes,
+ 255 ; 2-byte varref codes,
+ 65535)) ; 3-byte codes for the rest.
+ 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)))))
+
+;; Given an expression FORM, compile it and return an equivalent byte-code
+;; expression (a call to the function byte-code).
+(defun byte-compile-top-level (form &optional for-effect output-type)
+ ;; OUTPUT-TYPE advises about how form is expected to be used:
+ ;; 'eval or nil -> a single form,
+ ;; 'progn or t -> a list of forms,
+ ;; 'lambda -> body of a lambda,
+ ;; 'file -> used at file-level.
+ (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
+ ;; The stack is empty. Push a value to be returned from (byte-code ..).
+ (if (eq (car (car byte-compile-output)) 'byte-discard)
+ (setq byte-compile-output (cdr byte-compile-output))
+ (byte-compile-push-constant
+ ;; Push any constant - preferably one which already is used, and
+ ;; a number or symbol - ie not some big sequence. The return value
+ ;; isn't returned, but it would be a shame if some textually large
+ ;; constant was not optimized away because we chose to return it.
+ (and (not (assq nil byte-compile-constants)) ; Nil is often there.
+ (let ((tmp (reverse byte-compile-constants)))
+ (while (and tmp (not (or (symbolp (car (car tmp)))
+ (numberp (car (car tmp))))))
+ (setq tmp (cdr tmp)))
+ (car (car 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)))
+
+ ;; Decompile trivial functions:
+ ;; only constants and variables, or a single funcall except in lambdas.
+ ;; Except for Lisp_Compiled objects, forms like (foo "hi")
+ ;; are still quicker than (byte-code "..." [foo "hi"] 2).
+ ;; Note that even (quote foo) must be parsed just as any subr by the
+ ;; interpreter, so quote should be compiled into byte-code in some contexts.
+ ;; What to leave uncompiled:
+ ;; lambda -> a single atom.
+ ;; eval -> atom, quote or (function atom atom atom)
+ ;; progn -> as <<same-as-eval>> or (progn <<same-as-eval>> atom)
+ ;; file -> as progn, but takes both quotes and atoms, and longer forms.
+ (let (rest
+ (maycall (not (eq output-type 'lambda))) ; t if we may make a funcall.
+ tmp body)
+ (cond
+ ;; #### This should be split out into byte-compile-nontrivial-function-p.
+ ((or (nthcdr (if (eq output-type 'file) 50 8) byte-compile-output)
+ (assq 'TAG byte-compile-output) ; Not necessary, but speeds up a bit.
+ (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 (memq tmp '(nil t))))))
+ (if maycall
+ (setq body (cons (list 'quote tmp) body)))
+ (setq body (cons tmp body))))
+ ((and maycall
+ ;; Allow a funcall if at most one atom follows it.
+ (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) ; Only allow one real function call.
+ (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)
+ (and (consp (car body)) (eq output-type 'lambda)))
+ (let ((byte-compile-vector (byte-compile-constants-vector)))
+ (list 'byte-code (byte-compile-lapcode byte-compile-output)
+ byte-compile-vector byte-compile-maxdepth)))
+ ;; it's a trivial function
+ ((cdr body) (cons 'progn (nreverse body)))
+ ((car body)))))
+
+;; Given BODY, compile it and return a new 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))))
+
+;; This is the recursive entry point for compiling each subform of an
+;; expression.
+;; If for-effect is non-nil, byte-compile-form will output a byte-discard
+;; before terminating (ie no value will be left on the stack).
+;; A byte-compile handler may, when for-effect is non-nil, choose output code
+;; which does not leave a value on the stack, and then set for-effect to nil
+;; (to prevent byte-compile-form from outputting the byte-discard).
+;; If a handler wants to call another handler, it should do so via
+;; byte-compile-form, or take extreme care to handle for-effect correctly.
+;; (Use byte-compile-form-do-effect to reset the for-effect flag too.)
+;;
+(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)) (memq form '(nil t)))
+ (byte-compile-constant form))
+ ((and for-effect byte-compile-delete-errors)
+ (setq for-effect nil))
+ (t (byte-compile-variable-ref 'byte-varref form))))
+ ((symbolp (car form))
+ (let* ((fn (car form))
+ (handler (get fn 'byte-compile)))
+ (if (and handler
+ (or (byte-compile-version-cond
+ byte-compile-generate-emacs19-bytecodes)
+ (not (get (get fn 'byte-opcode) 'emacs19-opcode))))
+ (funcall handler form)
+ (if (memq 'callargs byte-compile-warnings)
+ (byte-compile-callargs-warn form))
+ (byte-compile-normal-call form))))
+ ((and (or (compiled-function-p (car form))
+ (eq (car-safe (car form)) 'lambda))
+ ;; if the form comes out the same way it went in, that's
+ ;; because it was malformed, and we couldn't unfold it.
+ (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))
+ (mapcar 'byte-compile-form (cdr form)) ; wasteful, but faster.
+ (byte-compile-out 'byte-call (length (cdr form))))
+
+(defun byte-compile-variable-ref (base-op var)
+ (if (or (not (symbolp var)) (memq var '(nil t)))
+ (byte-compile-warn (if (eq base-op 'byte-varbind)
+ "Attempt to let-bind %s %s"
+ "Variable reference to %s %s")
+ (if (symbolp var) "constant" "nonvariable")
+ (prin1-to-string var))
+ (if (memq 'free-vars byte-compile-warnings)
+ (if (eq base-op 'byte-varbind)
+ (setq byte-compile-bound-variables
+ (cons 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)
+ (setq byte-compile-free-assignments
+ (cons var byte-compile-free-assignments))))
+ (or (memq var byte-compile-free-references)
+ (progn
+ (byte-compile-warn "reference to free variable %s" var)
+ (setq byte-compile-free-references
+ (cons var byte-compile-free-references)))))))))
+ (let ((tmp (assq var byte-compile-variables)))
+ (or tmp
+ (setq tmp (list var)
+ byte-compile-variables (cons tmp byte-compile-variables)))
+ (byte-compile-out base-op tmp)))
+
+(defmacro byte-compile-get-constant (const)
+ (` (or (if (stringp (, const))
+ (assoc (, const) byte-compile-constants)
+ (assq (, const) byte-compile-constants))
+ (car (setq byte-compile-constants
+ (cons (list (, const)) byte-compile-constants))))))
+
+;; Use this when the value of a form is a constant. This obeys for-effect.
+(defun byte-compile-constant (const)
+ (if for-effect
+ (setq for-effect nil)
+ (byte-compile-out 'byte-constant (byte-compile-get-constant const))))
+
+;; Use this for a constant that is not the value of its containing form.
+;; This ignores for-effect.
+(defun byte-compile-push-constant (const)
+ (let ((for-effect nil))
+ (inline (byte-compile-constant const))))
+
+
+;; Compile those primitive ordinary functions
+;; which have special byte codes just for speed.
+
+(defmacro byte-defop-compiler (function &optional compile-handler)
+ ;; add a compiler-form for FUNCTION.
+ ;; If function is a symbol, then the variable "byte-SYMBOL" must name
+ ;; the opcode to be used. If function is a list, the first element
+ ;; is the function and the second element is the bytecode-symbol.
+ ;; COMPILE-HANDLER is the function to use to compile this byte-op, or
+ ;; may be the abbreviations 0, 1, 2, 3, 0-1, or 1-2.
+ ;; If it is nil, then the handler is "byte-compile-SYMBOL."
+ (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)
+ ;; Just like byte-defop-compiler, but defines an opcode that will only
+ ;; be used when byte-compile-generate-emacs19-bytecodes is true.
+ (if (and (byte-compile-single-version)
+ (not byte-compile-generate-emacs19-bytecodes))
+ 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 (dot byte-point) 0)
+(byte-defop-compiler (dot-max byte-point-max) 0)
+(byte-defop-compiler (dot-min byte-point-min) 0)
+(byte-defop-compiler point 0)
+;;(byte-defop-compiler mark 0) ;; obsolete
+(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 read-char 0) ;; obsolete
+(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 1)
+(byte-defop-compiler set-buffer 1)
+;;(byte-defop-compiler set-mark 1) ;; obsolete
+(byte-defop-compiler19 forward-word 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 (eql byte-eq) 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-compiler (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-compiler (string-equal byte-string=) 2)
+(byte-defop-compiler (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-compiler (rplaca byte-setcar) 2)
+(byte-defop-compiler (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-compiler (mod byte-rem) 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-compiler19 move-to-column 1)
+(byte-defop-compiler-1 interactive byte-compile-noop)
+
+
+(defun byte-compile-subr-wrong-args (form n)
+ (byte-compile-warn "%s called with %d arg%s, but requires %s"
+ (car form) (length (cdr form))
+ (if (= 1 (length (cdr form))) "" "s") n)
+ ;; get run-time wrong-number-of-args error.
+ (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))) ;; Push the argument
+ (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))) ;; Push the arguments
+ (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))) ;; Push the arguments
+ (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))
+
+
+;; Compile a function that accepts one or more args and is right-associative.
+(defun byte-compile-associative (form)
+ (if (cdr form)
+ (let ((opcode (get (car form) 'byte-opcode)))
+ ;; To compile all the args first may enable some optimizaions.
+ (mapcar 'byte-compile-form (setq form (cdr form)))
+ (while (setq form (cdr form))
+ (byte-compile-out opcode 0)))
+ (byte-compile-constant (eval form))))
+
+
+;; more complicated compiler macros
+
+(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)
+(byte-defop-compiler-1 beginning-of-line)
+
+(defun byte-compile-list (form)
+ (let ((count (length (cdr form))))
+ (cond ((= count 0)
+ (byte-compile-constant nil))
+ ((< count 5)
+ (mapcar 'byte-compile-form (cdr form))
+ (byte-compile-out
+ (aref [byte-list1 byte-list2 byte-list3 byte-list4] (1- count)) 0))
+ ((and (< count 256) (byte-compile-version-cond
+ byte-compile-generate-emacs19-bytecodes))
+ (mapcar '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))
+ (mapcar 'byte-compile-form (cdr form))
+ (byte-compile-out
+ (aref [byte-concat2 byte-concat3 byte-concat4] (- count 2))
+ 0))
+ ;; Concat of one arg is not a no-op if arg is not a string.
+ ((= count 0)
+ (byte-compile-form ""))
+ ((and (< count 256) (byte-compile-version-cond
+ byte-compile-generate-emacs19-bytecodes))
+ (mapcar '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)
+ ;; nconc of one arg is a noop, even if that arg isn't a list.
+ (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)
+ ;; warn about forms like (fset 'foo '(lambda () ...))
+ ;; (where the lambda expression is non-trivial...)
+ (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)
+ ;; (mapcar '(lambda (x) ..) ..) ==> (mapcar (function (lambda (x) ..)) ..)
+ ;; for cases where it's guarenteed that first arg will be used as a lambda.
+ (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))))
+
+;; (function foo) must compile like 'foo, not like (symbol-function 'foo).
+;; Otherwise it will be incompatible with the interpreter,
+;; and (funcall (function foo)) will lose with autoloads.
+
+(defun byte-compile-function-form (form)
+ (byte-compile-constant
+ (cond ((symbolp (nth 1 form))
+ (nth 1 form))
+ ;; If we're not allowed to use #[] syntax, then output a form like
+ ;; '(lambda (..) (byte-code ..)) instead of a call to make-byte-code.
+ ;; In this situation, calling make-byte-code at run-time will usually
+ ;; be less efficient than processing a call to byte-code.
+ ((byte-compile-version-cond byte-compile-emacs18-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)
+ ;; no opcode for 2-arg case.
+ (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 (byte-compile-version-cond
+ byte-compile-generate-emacs19-bytecodes)
+ (<= (length form) 256))
+ (mapcar '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))
+ ;; We can split it; there is no function call after inserting 1st arg.
+ (t
+ (while (setq form (cdr form))
+ (byte-compile-form (car form))
+ (byte-compile-out 'byte-insert 0)
+ (if (cdr form)
+ (byte-compile-discard))))))
+
+(defun byte-compile-beginning-of-line (form)
+ (if (not (byte-compile-constp (nth 1 form)))
+ (byte-compile-normal-call form)
+ (byte-compile-form
+ (list 'forward-line
+ (if (integerp (setq form (or (eval (nth 1 form)) 1)))
+ (1- form)
+ (byte-compile-warn "Non-numeric arg to beginning-of-line: %s"
+ form)
+ (list '1- (list 'quote form))))
+ t)
+ (byte-compile-constant nil)))
+
+
+(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))))
+ ;; (setq), with no arguments.
+ (byte-compile-form nil for-effect))
+ (setq for-effect nil)))
+
+(defun byte-compile-setq-default (form)
+ (byte-compile-form
+ (cons 'set-default (cons (list 'quote (nth 1 form))
+ (nthcdr 2 form)))))
+
+(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))))
+
+
+;;; control structures
+
+(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))
+
+(proclaim-inline byte-compile-body-do-effect)
+(defun byte-compile-body-do-effect (body)
+ (byte-compile-body body for-effect)
+ (setq for-effect nil))
+
+(proclaim-inline byte-compile-form-do-effect)
+(defun 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 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))))
+
+(defun byte-compile-if (form)
+ (byte-compile-form (car (cdr form)))
+ (if (null (nthcdr 3 form))
+ ;; No else-forms
+ (let ((donetag (byte-compile-make-tag)))
+ (byte-compile-goto-if nil for-effect donetag)
+ (byte-compile-form (nth 2 form) for-effect)
+ (byte-compile-out-tag donetag))
+ (let ((donetag (byte-compile-make-tag)) (elsetag (byte-compile-make-tag)))
+ (byte-compile-goto 'byte-goto-if-nil elsetag)
+ (byte-compile-form (nth 2 form) for-effect)
+ (byte-compile-goto 'byte-goto donetag)
+ (byte-compile-out-tag elsetag)
+ (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)))))
+ ;; Unconditional clause
+ (setq clause (cons t clause)
+ clauses nil))
+ ((cdr clauses)
+ (byte-compile-form (car clause))
+ (if (null (cdr clause))
+ ;; First clause is a singleton.
+ (byte-compile-goto-if t for-effect donetag)
+ (setq nexttag (byte-compile-make-tag))
+ (byte-compile-goto 'byte-goto-if-nil nexttag)
+ (byte-compile-body (cdr clause) for-effect)
+ (byte-compile-goto 'byte-goto donetag)
+ (byte-compile-out-tag nexttag)))))
+ ;; Last clause
+ (and (cdr clause) (not (eq (car clause) t))
+ (progn (byte-compile-form (car clause))
+ (byte-compile-goto-if nil for-effect donetag)
+ (setq clause (cdr clause))))
+ (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)
+ (while (cdr args)
+ (byte-compile-form (car args))
+ (byte-compile-goto-if nil for-effect failtag)
+ (setq args (cdr args)))
+ (byte-compile-form-do-effect (car args))
+ (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)
+ (while (cdr args)
+ (byte-compile-form (car args))
+ (byte-compile-goto-if t for-effect wintag)
+ (setq args (cdr args)))
+ (byte-compile-form-do-effect (car args))
+ (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)
+ (mapcar 'byte-compile-form (cdr form))
+ (byte-compile-out 'byte-call (length (cdr (cdr form)))))
+
+
+(defun byte-compile-let (form)
+ ;; First compute the binding values in the old scope.
+ (let ((varlist (car (cdr form))))
+ (while varlist
+ (if (consp (car varlist))
+ (byte-compile-form (car (cdr (car varlist))))
+ (byte-compile-push-constant nil))
+ (setq varlist (cdr varlist))))
+ (let ((byte-compile-bound-variables byte-compile-bound-variables) ;new scope
+ (varlist (reverse (car (cdr form)))))
+ (while varlist
+ (byte-compile-variable-ref 'byte-varbind (if (consp (car varlist))
+ (car (car varlist))
+ (car varlist)))
+ (setq varlist (cdr varlist)))
+ (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) ;new scope
+ (varlist (copy-sequence (car (cdr form)))))
+ (while varlist
+ (if (atom (car varlist))
+ (byte-compile-push-constant nil)
+ (byte-compile-form (car (cdr (car varlist))))
+ (setcar varlist (car (car varlist))))
+ (byte-compile-variable-ref 'byte-varbind (car varlist))
+ (setq varlist (cdr varlist)))
+ (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)))
+
+;; Even when optimization is off, /= is optimized to (not (= ...)).
+(defun byte-compile-negation-optimizer (form)
+ ;; an optimizer for forms where <form1> is less efficient than (not <form2>)
+ (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))))
+
+;;; other tricky macro-like special-forms
+
+(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-restriction)
+(byte-defop-compiler-1 save-window-excursion)
+(byte-defop-compiler-1 with-output-to-temp-buffer)
+
+(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-condition-case (form)
+ (let* ((var (nth 1 form))
+ (byte-compile-bound-variables
+ (if var (cons var byte-compile-bound-variables)
+ byte-compile-bound-variables)))
+ (or (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)))
+ (setq compiled-clauses
+ (cons (cons (car clause)
+ (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-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))
+
+
+;;; top-level forms elsewhere
+
+(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)
+ ;; This is not used for file-level defuns with doc strings.
+ (byte-compile-two-args ; Use this to avoid byte-compile-fset's warning.
+ (list 'fset (list 'quote (nth 1 form))
+ (byte-compile-byte-code-maker
+ (byte-compile-lambda (cons 'lambda (cdr (cdr form)))))))
+ (byte-compile-discard)
+ (byte-compile-constant (nth 1 form)))
+
+(defun byte-compile-defmacro (form)
+ ;; This is not used for file-level defmacros with doc strings.
+ (byte-compile-body-do-effect
+ (list (list 'fset (list 'quote (nth 1 form))
+ (let ((code (byte-compile-byte-code-maker
+ (byte-compile-lambda
+ (cons 'lambda (cdr (cdr form)))))))
+ (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)
+ ;; This is not used for file-level defvar/consts with doc strings.
+ (let ((var (nth 1 form))
+ (value (nth 2 form))
+ (string (nth 3 form)))
+ (if (memq 'free-vars byte-compile-warnings)
+ (setq byte-compile-bound-variables
+ (cons var byte-compile-bound-variables)))
+ (byte-compile-body-do-effect
+ (list (if (cdr (cdr form))
+ (if (eq (car form) 'defconst)
+ (list 'setq var value)
+ (list 'or (list 'boundp (list 'quote var))
+ (list 'setq var value))))
+ (if string
+ (list 'put (list 'quote var) ''variable-documentation string))
+ (list 'quote var)))))
+
+(defun byte-compile-autoload (form)
+ (and (byte-compile-constp (nth 1 form))
+ (byte-compile-constp (nth 5 form))
+ (eval (nth 5 form)) ; macro-p
+ (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))
+
+;; Lambda's in valid places are handled as special cases by various code.
+;; The ones that remain are errors.
+(defun byte-compile-lambda-form (form)
+ (error "`lambda' used as function name is invalid"))
+
+
+;;; tags
+
+;; Note: Most operations will strip off the 'TAG, but it speeds up
+;; optimization to have the 'TAG as a part of the tag.
+;; Tags will be (TAG . (tag-number . stack-depth)).
+(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
+ ;; ## remove this someday
+ (and byte-compile-depth
+ (not (= (cdr (cdr tag)) byte-compile-depth))
+ (error "bytecomp 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)
+ (setq byte-compile-output (cons (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)
+ (setq byte-compile-output (cons (cons opcode offset) byte-compile-output))
+ (cond ((eq opcode 'byte-call)
+ (setq byte-compile-depth (- byte-compile-depth offset)))
+ ((eq opcode 'byte-return)
+ ;; This is actually an unnecessary case, because there should be
+ ;; no more opcodes behind 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))))
+ ;;(if (< byte-compile-depth 0) (error "compiler error: stack underflow"))
+ )
+
+
+;;; call tree stuff
+
+(defun byte-compile-annotate-call-tree (form)
+ (let (entry)
+ ;; annotate the current call
+ (if (setq entry (assq (car form) byte-compile-call-tree))
+ (or (memq byte-compile-current-form (nth 1 entry)) ;callers
+ (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)))
+ ;; annotate the current function
+ (if (setq entry (assq byte-compile-current-form byte-compile-call-tree))
+ (or (memq (car form) (nth 2 entry)) ;called
+ (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 byte-compile-report-call-tree (&optional filename)
+ "Display a buffer describing which functions have been called, what functions
+called them, and what functions they call. This buffer will list all functions
+whose definitions have been compiled since this emacs session was started, as
+well as all functions called by those functions.
+
+The call tree only lists functions called, not macros or inline functions
+expanded. 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."
+ (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>";; shouldn't insert nil then, actually -sk
+ " <not defined>"))
+ ((subrp (setq f (symbol-function f)))
+ " <subr>")
+ ((symbolp f)
+ (format " ==> %s" f))
+ ((compiled-function-p f)
+ "<compiled function>")
+ ((not (consp f))
+ "<malformed function>")
+ ((eq 'macro (car f))
+ (if (or (compiled-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)"
+ ;; Does the optimizer eliminate common subexpressions?-sk
+ (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)))))
+ (if calls
+ (progn
+ (insert " calls:\n")
+ (setq p (point))
+ (insert " " (mapconcat 'symbol-name calls ", "))
+ (let ((fill-prefix " "))
+ (fill-region-as-paragraph p (point)))))
+ (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))))
+ (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.")
+ ))
+
+
+;;; by crl@newton.purdue.edu
+;;; Only works noninteractively.
+(defun batch-byte-compile ()
+ "Runs `byte-compile-file' on the files remaining on the command line.
+Must be used only with -batch, and kills emacs on completion.
+Each file will be processed even if an error occurred previously.
+For example, invoke \"emacs -batch -f batch-byte-compile $emacs/ ~/*.el\""
+ ;; command-line-args-left is what is left of the command line (from startup.el)
+ (defvar command-line-args-left) ;Avoid 'free variable' warning
+ (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)
+ (while files
+ (if (and (string-match elisp-source-extention-re (car files))
+ (not (auto-save-file-name-p (car files)))
+ (setq source (expand-file-name (car files)
+ (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)))
+ (setq files (cdr files))))
+ (if (null (batch-byte-compile-file (car command-line-args-left)))
+ (setq error t)))
+ (setq command-line-args-left (cdr command-line-args-left)))
+ (message "Done")
+ (kill-emacs (if error 1 0))))
+
+(defun batch-byte-compile-file (file)
+ (condition-case err
+ (progn (byte-compile-file file) t)
+ (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)))
+
+
+(make-obsolete 'mod '%)
+(make-obsolete 'dot 'point)
+(make-obsolete 'dot-max 'point-max)
+(make-obsolete 'dot-min 'point-min)
+(make-obsolete 'dot-marker 'point-marker)
+
+(cond ((not (or (and (boundp 'epoch::version) epoch::version)
+ (string-lessp emacs-version "19")))
+ (make-obsolete 'buffer-flush-undo 'buffer-disable-undo)
+ (make-obsolete 'baud-rate "use the baud-rate variable instead")
+ ))
+
+(provide 'byte-compile)
+
+
+;;; report metering (see the hacks in bytecode.c)
+
+(if (boundp 'byte-code-meter)
+ (defun byte-compile-report-ops ()
+ (defvar byte-code-meter)
+ (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 ;(not (zerop n))
+ (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)))))))
+
+
+;; To avoid "lisp nesting exceeds max-lisp-eval-depth" when bytecomp compiles
+;; itself, compile some of its most used recursive functions (at load time).
+;;
+(eval-when-compile
+ (or (compiled-function-p (symbol-function 'byte-compile-form))
+ (assq 'byte-code (symbol-function 'byte-compile-form))
+ (let ((byte-optimize nil) ; do it fast
+ (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
+ ;; Inserted some more than necessary, to speed it up.
+ byte-compile-top-level
+ byte-compile-out-toplevel
+ byte-compile-constant
+ byte-compile-variable-ref))))
+ nil)
diff --git a/lisp/emacs-lisp/disass.el b/lisp/emacs-lisp/disass.el
new file mode 100644
index 00000000000..52ee8d61c3f
--- /dev/null
+++ b/lisp/emacs-lisp/disass.el
@@ -0,0 +1,224 @@
+;;; Disassembler for compiled Emacs Lisp code
+;;; Copyright (C) 1986 Free Software Foundation, Inc.
+;;; Original version by Doug Cutting (doug@csli.stanford.edu)
+;;; Substantially modified by Jamie Zawinski <jwz@lucid.com> for
+;;; the new lapcode-based byte compiler.
+;;; Last modified 22-oct-91.
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 1, or (at your option)
+;; any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs; see the file COPYING. If not, write to
+;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
+
+
+;;; The variable byte-code-vector is defined by the new bytecomp.el.
+;;; The function byte-decompile-lapcode is defined in byte-optimize.el.
+(require 'byte-optimize)
+
+(defvar disassemble-column-1-indent 5 "*")
+(defvar disassemble-column-2-indent 10 "*")
+
+(defvar disassemble-recursive-indent 3 "*")
+
+(defun disassemble (object &optional buffer indent interactive-p)
+ "Print disassembled code for OBJECT in (optional) BUFFER.
+OBJECT can be a symbol defined as a function, or a function itself
+\(a lambda expression or a compiled-function object).
+If OBJECT is not already compiled, we compile it, but do not
+redefine OBJECT if it is a symbol."
+ (interactive (list (intern (completing-read "Disassemble function: "
+ obarray 'fboundp t))
+ nil 0 t))
+ (if (eq (car-safe object) 'byte-code)
+ (setq object (list 'lambda () object)))
+ (or indent (setq indent 0)) ;Default indent to zero
+ (save-excursion
+ (if (or interactive-p (null buffer))
+ (with-output-to-temp-buffer "*Disassemble*"
+ (set-buffer "*Disassemble*")
+ (disassemble-internal object indent (not interactive-p)))
+ (set-buffer buffer)
+ (disassemble-internal object indent nil)))
+ nil)
+
+
+(defun disassemble-internal (obj indent interactive-p)
+ (let ((macro 'nil)
+ (name 'nil)
+ (doc 'nil)
+ args)
+ (while (symbolp obj)
+ (setq name obj
+ obj (symbol-function obj)))
+ (if (subrp obj)
+ (error "Can't disassemble #<subr %s>" name))
+ (if (eq (car-safe obj) 'macro) ;handle macros
+ (setq macro t
+ obj (cdr obj)))
+ (if (and (listp obj) (not (eq (car obj) 'lambda)))
+ (error "not a function"))
+ (if (consp obj)
+ (if (assq 'byte-code obj)
+ nil
+ (if interactive-p (message (if name
+ "Compiling %s's definition..."
+ "Compiling definition...")
+ name))
+ (setq obj (byte-compile obj))
+ (if interactive-p (message "Done compiling. Disassembling..."))))
+ (cond ((consp obj)
+ (setq obj (cdr obj)) ;throw lambda away
+ (setq args (car obj)) ;save arg list
+ (setq obj (cdr obj)))
+ (t
+ (setq args (aref obj 0))))
+ (if (zerop indent) ; not a nested function
+ (progn
+ (indent-to indent)
+ (insert (format "byte code%s%s%s:\n"
+ (if (or macro name) " for" "")
+ (if macro " macro" "")
+ (if name (format " %s" name) "")))))
+ (let ((doc (if (consp obj)
+ (and (stringp (car obj)) (car obj))
+ (and (> (length obj) 4) (aref obj 4)))))
+ (if (and doc (stringp doc))
+ (progn (and (consp obj) (setq obj (cdr obj)))
+ (indent-to indent)
+ (princ " doc: " (current-buffer))
+ (if (string-match "\n" doc)
+ (setq doc (concat (substring doc 0 (match-beginning 0))
+ " ...")))
+ (insert doc "\n"))))
+ (indent-to indent)
+ (insert " args: ")
+ (prin1 args (current-buffer))
+ (insert "\n")
+ (let ((interactive (cond ((consp obj)
+ (assq 'interactive obj))
+ ((> (length obj) 5)
+ (list 'interactive (aref obj 5))))))
+ (if interactive
+ (progn
+ (setq interactive (nth 1 interactive))
+ (if (eq (car-safe (car-safe obj)) 'interactive)
+ (setq obj (cdr obj)))
+ (indent-to indent)
+ (insert " interactive: ")
+ (if (eq (car-safe interactive) 'byte-code)
+ (progn
+ (insert "\n")
+ (disassemble-1 interactive
+ (+ indent disassemble-recursive-indent)))
+ (let ((print-escape-newlines t))
+ (prin1 interactive (current-buffer))))
+ (insert "\n"))))
+ (cond ((and (consp obj) (assq 'byte-code obj))
+ (disassemble-1 (assq 'byte-code obj) indent))
+ ((compiled-function-p obj)
+ (disassemble-1 obj indent))
+ (t
+ (insert "Uncompiled body: ")
+ (let ((print-escape-newlines t))
+ (prin1 (if (cdr obj) (cons 'progn obj) (car obj))
+ (current-buffer))))))
+ (if interactive-p
+ (message "")))
+
+
+(defun disassemble-1 (obj indent)
+ "Prints the byte-code call OBJ in the current buffer.
+OBJ should be a call to BYTE-CODE generated by the byte compiler."
+ (let (bytes constvec)
+ (if (consp obj)
+ (setq bytes (car (cdr obj)) ;the byte code
+ constvec (car (cdr (cdr obj)))) ;constant vector
+ (setq bytes (aref obj 1)
+ constvec (aref obj 2)))
+ (let ((lap (byte-decompile-bytecode bytes constvec))
+ op arg opname)
+ (let ((tagno 0)
+ tmp
+ (lap lap))
+ (while (setq tmp (assq 'TAG lap))
+ (setcar (cdr tmp) (setq tagno (1+ tagno)))
+ (setq lap (cdr (memq tmp lap)))))
+ (while lap
+ (setq op (car (car lap))
+ arg (cdr (car lap)))
+ (indent-to indent)
+ (if (eq 'TAG op)
+ (insert (int-to-string (car arg)) ":")
+
+ (indent-to (+ indent disassemble-column-1-indent))
+ (if (and op
+ (string-match "^byte-" (setq opname (symbol-name op))))
+ (setq opname (substring opname 5))
+ (setq opname "<not-an-opcode>"))
+ (if (eq op 'byte-constant2)
+ (insert " #### shouldn't have seen constant2 here!\n "))
+ (insert opname)
+ (indent-to (+ indent disassemble-column-1-indent
+ disassemble-column-2-indent
+ -1))
+ (insert " ")
+ (cond ((memq op byte-goto-ops)
+ (insert (int-to-string (nth 1 arg))))
+ ((memq op '(byte-call byte-unbind
+ byte-listN byte-concatN byte-insertN))
+ (insert (int-to-string arg)))
+ ((memq op '(byte-varref byte-varset byte-varbind))
+ (prin1 (car arg) (current-buffer)))
+ ((memq op '(byte-constant byte-constant2))
+ ;; it's a constant
+ (setq arg (car arg))
+ ;; but if the value of the constant is compiled code, then
+ ;; recursively disassemble it.
+ (cond ((or (compiled-function-p arg)
+ (and (eq (car-safe arg) 'lambda)
+ (assq 'byte-code arg))
+ (and (eq (car-safe arg) 'macro)
+ (or (compiled-function-p (cdr arg))
+ (and (eq (car-safe (cdr arg)) 'lambda)
+ (assq 'byte-code (cdr arg))))))
+ (cond ((compiled-function-p arg)
+ (insert "<compiled-function>\n"))
+ ((eq (car-safe arg) 'lambda)
+ (insert "<compiled lambda>"))
+ (t (insert "<compiled macro>\n")))
+ (disassemble-internal
+ arg
+ (+ indent disassemble-recursive-indent 1)
+ nil))
+ ((eq (car-safe arg) 'byte-code)
+ (insert "<byte code>\n")
+ (disassemble-1 ;recurse on byte-code object
+ arg
+ (+ indent disassemble-recursive-indent)))
+ ((eq (car-safe (car-safe arg)) 'byte-code)
+ (insert "(<byte code>...)\n")
+ (mapcar ;recurse on list of byte-code objects
+ '(lambda (obj)
+ (disassemble-1
+ obj
+ (+ indent disassemble-recursive-indent)))
+ arg))
+ (t
+ ;; really just a constant
+ (let ((print-escape-newlines t))
+ (prin1 arg (current-buffer))))))
+ )
+ (insert "\n"))
+ (setq lap (cdr lap)))))
+ nil)
generated by cgit v1.2.3 (git 2.39.1) at 2025-05-19 00:42:20 +0000