drw@BOURBAKI.MIT.EDU (01/05/90)
I've worked out some improvements to the byte compiler. It has two
improvements over the existing (18.54) version:
1) It handles defun's that are not at the top level of an expression.
Thus
(if (not (fboundp 'foo))
(defun foo ...))
and
(global-set-key "xxx" (function (lambda ...)))
will have the bodies byte-compiled. The present compiler does not
byte compile the bodies.
2) defun, defmacro, defconst, and defvar special forms that are not at
the top level of an expression are byte-compiled into correct (but
inefficient) code. The present compiler compiles these forms as if
they were function calls, and the code fails at runtime.
This code also includes the code I sent in earlier that allows forms
like
((lambda (x) ...) (...))
to compile correctly.
Since the new compiler compiles more bodies, code that has compiled
before may fail to compile because it contains macros that cannot be
successfully expanded at byte-compile time. I have added the macros
byte-compile-protect and defmacro-protect to allow the user to protect
code from macro expansion at byte-compile time, at the cost of
interpretation at run time.
I have compiled all the .el's shipped with Gnu Emacs 18.54 and
compared the results with the .elc's that our installation now has.
The differences I have found are:
. bibtex.el uses the defmenu macro, so it should have a
"(require 'sun-mouse)" at the top.
. doctor.el has a spurious trailing "4" on line 759.
. The definition of the macro defcursor in sun-cursors.el should use
defmacro-protect. Better, the definition should be changed to:
(defmacro defcursor (name x y string)
(` (progn
(if (not (memq '(, name) sc::cursors))
(setq sc::cursors (cons '(, name) sc::cursors)))
(defconst (, name) '(, (list 'vector x y string))))))
so that the insertion into the list sc::cursors is done at the time
that the defconst of the name is done, not at the time that the
defcursor macro is expanded.
. cl.el is not compilable with the 18.54 byte compiler, due to using the
"do" macro before defining it. (Where the cl.elc in 18.54 comes from,
I have no idea.)
Once these revisions are made, the new bytecomp produces the same
.elc's as the old, except that certain macros which expand to defun's
now have the generated code compiled.
----------------------------------------------------------------------
(require 'byte-compile "bytecomp")
;; (byte-comp-protect form) becomes (eval 'form)
(defmacro byte-comp-protect (form)
"The macro call `(byte-comp-protect FORM)' will execute FORM at run
time, but will protect it from being examined at byte-compile time.
This is useful if FORM contains macros which must be expanded at run time."
(` (eval (quote (, form)))))
;; A clever piece of code to control exactly when everything is evaluated,
;; if I do say so myself.
(defmacro defmacro-protect (name arg-list &rest body)
"Takes the same arguments and has the same effect as defmacro, but
guarantees that the body of the macro will not be executed when the code
is byte-compiled, but rather will be executed at runtime.
Of course, the resulting code is not very efficient. Any macro that needs to
be defined with defmacro-protect should be rewritten."
(let (doc-string)
(if (stringp (car body))
(progn (setq doc-string (list (car body)))
(setq body (cdr body))))
(` (defmacro
(, name)
(, arg-list)
(,@ doc-string)
(` (eval
(let (, (mapcar (function
(lambda (x) (` ((, x) (quote ((, ',) (, x)))))))
(delq '&rest
(delq '&optional
(copy-sequence arg-list)))))
(,@ body))))))))
(defun byte-compile-form (form)
(setq form (macroexpand form byte-compile-macro-environment))
(cond ((eq form 'nil)
(byte-compile-constant form))
((eq form 't)
(byte-compile-constant form))
((symbolp form)
(byte-compile-variable-ref 'byte-varref form))
((not (consp form))
(byte-compile-constant form))
((eq (car-safe (car form)) 'lambda)
(byte-compile-form
(` (funcall (quote (, (byte-compile-lambda (car form))))
(,@ (cdr form))))))
((not (symbolp (car form)))
(signal 'invalid-function (list (car form))))
(t
(let ((handler (get (car form) 'byte-compile)))
(if handler
(funcall handler form)
(byte-compile-normal-call form)))))
(setq byte-compile-maxdepth
(max byte-compile-maxdepth
(setq byte-compile-depth (1+ byte-compile-depth)))))
(defun byte-compile-file-form (form)
(setq form (macroexpand form byte-compile-macro-environment))
(cond ((not (listp form))
form)
((memq (car form) '(defun defmacro))
(let* ((name (car (cdr form)))
(tem (assq name byte-compile-macro-environment)))
(if (eq (car form) 'defun)
(progn
(message "Compiling %s (%s)..." filename (nth 1 form))
(cond (tem (setcdr tem nil))
((and (fboundp name)
(eq (car-safe (symbol-function name)) 'macro))
;; shadow existing macro definition
(setq byte-compile-macro-environment
(cons (cons name nil)
byte-compile-macro-environment))))
(prog1 (byte-compile-interpreted-form form)
(if (not noninteractive)
(message "Compiling %s..." filename))))
;; defmacro
(if tem
(setcdr tem (cons 'lambda (cdr (cdr form))))
(setq byte-compile-macro-environment
(cons (cons name (cons 'lambda (cdr (cdr form))))
byte-compile-macro-environment)))
(byte-compile-interpreted-form form))))
((eq (car form) 'require)
(eval form)
form)
(t (byte-compile-interpreted-form form))))
(defun byte-compile-interpreted-form (form)
"Process a FORM, looking for things that can be usefully byte-compiled."
(if (not (listp form))
form
(let ((f (car form)))
(cond
((eq f 'quote) form)
((eq f 'function)
(cond ((symbolp (car (cdr form)))
(` (symbol-function (quote (, (car (cdr form)))))))
(t
(list f (byte-compile-lambda (car (cdr form)))))))
((memq f '(defun defmacro))
(cons f (byte-compile-lambda (cdr form))))
((eq f 'lambda)
(byte-compile-lambda form))
(t (mapcar 'byte-compile-interpreted-form form))))))
;; Lambda's in valid places are handled as special cases by various code.
;; The ones that remain are errors.
(put 'lambda 'byte-compile 'byte-compile-lambda-form)
(defun byte-compile-lambda-form (form)
(error "Lambda used in incorrect place in byte-compiled code"))
;; (defun fff (xxx) body) =>
;; (eval (quote (defun fff (xxx) byte-compiled-body)))
(put 'defun 'byte-compile 'byte-compile-defun-form)
(defun byte-compile-defun-form (form)
(byte-compile-form
(` (eval (quote (defun (,@ (byte-compile-lambda (cdr form)))))))))
;; (defmacro fff (xxx) body) =>
;; (eval (quote (defmacro fff (xxx) byte-compiled-body)))
(put 'defmacro 'byte-compile 'byte-compile-defmacro-form)
(defun byte-compile-defmacro-form (form)
(byte-compile-form
(` (eval (quote (defmacro (,@ (byte-compile-lambda (cdr form)))))))))
;; (defconst xxx yyy ddd) =>
;; (eval (list 'defconst 'xxx yyy ddd))
(put 'defconst 'byte-compile 'byte-compile-defconst-form)
(defun byte-compile-defconst-form (form)
(byte-compile-form
(` (eval (list 'defconst '(, (car (cdr form))) (,@ (cdr (cdr form))))))))
;; (defvar xxx yyy ddd) =>
;; (eval (list 'defvar 'xxx yyy ddd))
(put 'defvar 'byte-compile 'byte-compile-defvar-form)
(defun byte-compile-defvar-form (form)
(byte-compile-form
(` (eval (list 'defvar '(, (car (cdr form))) (,@ (cdr (cdr form))))))))
----------------------------------------------------------------------
Dale Worley drw@math.mit.eduhallvard@IFI.UIO.NO (Hallvard B Furuseth) (02/08/90)
Here is a bytecomp.el which attempts to byte-compile all the forms in
a file. Adjacent forms in the file are collected into a single progn,
breaking at (defXXX ...), (autoload/require ...), and NIL. Thus,
things like lists of (define-key XXX-mode-map ...)'s are compressed
consiredably. Very simple defuns etc are not compiled; each form is
examined during pass 1 to decide if it is complex enough to bother
compiling.
I have grabbed a lot of drw@BOURBAKI.MIT.EDU (Dale Worley)'s article
<9001050155.AA04895@hermite.mit.edu> of 5 Jan 1990:
Compile defun/defmacro/defconst/defvar forms that are not at the top
level of an expression, correctly. And do compile the bodies of
such defun's.
Allow forms like ((lambda (x) ...) ...).
The macros defmacro-protect and byte-comp-protect.
Hallvard Furuseth
hallvard@ifi.uio.no
Most transformations of the forms (which modify the forms to be
compiled), have been moved to pass 1 (byte-prepare-form), including
such things as byte-compiling the body of a catch, and handling some
special cases such as setq without arguments.
************** THIS PROGRAM MAY CONTAIN ONE SERIOUS BUG: **************
I have used the program for a while, and it seems to work. But I
have made one undocumented assumption about emacs-lisp:
When the old bytecomp calls byte-compile-top-level and outputs
(byte-code ...) , I may output any form. When it outputs
((byte-code ...)), I may output any list of forms.
I hope someone knowing elisp internals will check this. See the
calls to byte-compile-top-level and byte-compile-top-level-forms.
I had to handle one special case: (lambda () CONST STRING) reduced
to (lambda () STRING), making a new doc string. Also, sufficiently
stupid calls to interactive, such as (interactive (progn STRING)),
will reduce to (interactive STRING) with a different meaning. But
this will not change the behavior of any correct program.
***********************************************************************
There is one detail which should be easy to improve for someone
knowing elisp internals:
I compute the variable byte-compile-gain during pass 1, to see if
the form is worth compiling. But I don't know the cost of eval'ing
the compiled forms versus the originals, I just use some numbers
which seem OK. Look above (defmacro byte-compile-gain ...). Gains
may also be entered inside the byte-prepare-... functions.
I have corrected a bug from the old bytecomp: (function SYMBOL) should
not compile '(symbol-function ...), because the function may be
(re)defined afterwards. If that was a feature and not a bug, replace
byte-prepare-function with this:
(defun byte-prepare-function (form)
(byte-prepare-form
(if (symbolp (setq form (car (cdr form))))
(list 'symbol-function (list 'quote form))
(list 'quote (byte-compile-fundef form)))))
I put compiled versions of macros in byte-compile-macro-environment.
When that is wrong, the .elc file will contain an incorrect defmacro
anyway.
Macros are expanded during pass 1 (byte-prepare-form), so I removed
macroexpand from byte-compile-form, it seemed unnecessary. Except if
the user has redefined special subr's such as progn, but then we are
in trouble anyway.
Comments to Dale Worley's article:
defmacro-protect and byte-comp-protect must be defined outside
bytecomp.el, if they are to be used in (uncompiled) .el files.
The byte-compile-defvar/defconst-form functions are wrong, they
should simply compile (` (eval '(, FORM))). Otherwise, compiled
and uncompiled code behave differently.
It seems to be unnecessary to compile ((lambda () ...)) into
(funcall ...). I just treat it as a normal function call.
Dale Worley lists some necessary changes to emacs/lisp/*.el, because
more macros are expanded than with the old bytecomp:
> . bibtex.el uses the defmenu macro, so it should have a
> "(require 'sun-mouse)" at the top.
>
> . doctor.el has a spurious trailing "4" on line 759.
>
> . The definition of the macro defcursor in sun-cursors.el should use
> defmacro-protect. Better, the definition should be changed to:
>
> (defmacro defcursor (name x y string)
> (` (progn
> (if (not (memq '(, name) sc::cursors))
> (setq sc::cursors (cons '(, name) sc::cursors)))
> (defconst (, name) '(, (list 'vector x y string))))))
>
> so that the insertion into the list sc::cursors is done at the time
> that the defconst of the name is done, not at the time that the
> defcursor macro is expanded.
>
> . cl.el is not compilable with the 18.54 byte compiler, due to using the
> "do" macro before defining it. (Where the cl.elc in 18.54 comes from,
> I have no idea.)
;; The definistions on this page be defined outside bytecomp,
;; otherwise uncompiled files using them can not be loaded.
;; Replaced drw's macro BYTE-COMP-PROTECT with a function (which the
;; byte-compiler recognizes) because that is quicker when loading
;; uncompiled files.
;; by Dale Worley (drw@math.mit.edu)
;; A clever piece of code to control exactly when everything is evaluated,
;; if I do say so myself.
(defmacro defmacro-protect (name arg-list &rest body)
"Takes the same arguments and has the same effect as defmacro, but
guarantees that the body of the macro will not be executed when the code
is byte-compiled, but rather will be executed at runtime.
Of course, the resulting code is not very efficient. Any macro that needs to
be defined with defmacro-protect should be rewritten."
(let (doc-string)
(if (stringp (car body))
(progn (setq doc-string (list (car body)))
(setq body (cdr body))))
(` (defmacro
(, name)
(, arg-list)
(,@ doc-string)
(` (eval
(let (, (mapcar (function
(lambda (x) (` ((, x) (quote ((, ',) (, x)))))))
(delq '&rest
(delq '&optional
(copy-sequence arg-list)))))
(,@ body))))))))
;; This function returns FORM, which will not be examined at byte-compile time.
;; This is useful if FORM contains macros which must be expanded at run time.
(fset 'byte-comp-protect (symbol-function 'identity))
;; This is equivalent to progn, but it is evaluated at compile-time.
(fset 'progn-expand (symbol-function 'progn))
(put 'progn-expand 'lisp-indent-hook 0)
;; Quote a form.
;; Equivalent to the quote function in the interpreter,
;; but causes the compiler to compile the argument as a form.
(fset 'quote-form (symbol-function 'quote))
;; Compilation of Lisp code into byte code.
;; Copyright (C) 1985, 1986, 1987 Free Software Foundation, Inc.
;; This file is part of GNU Emacs.
;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY. No author or distributor
;; accepts responsibility to anyone for the consequences of using it
;; or for whether it serves any particular purpose or works at all,
;; unless he says so in writing. Refer to the GNU Emacs General Public
;; License for full details.
;; Everyone is granted permission to copy, modify and redistribute
;; GNU Emacs, but only under the conditions described in the
;; GNU Emacs General Public License. A copy of this license is
;; supposed to have been given to you along with GNU Emacs so you
;; can know your rights and responsibilities. It should be in a
;; file named COPYING. Among other things, the copyright notice
;; and this notice must be preserved on all copies.
(provide 'byte-compile)
(defvar byte-compile-constnum -1
"Transfer vector index of last constant allocated.")
(defvar byte-compile-constants nil
"Alist describing contents to put in transfer vector.
Each element is (CONTENTS . INDEX)")
(defvar byte-compile-macro-environment nil
"Alist of (MACRONAME . DEFINITION) macros defined in the file
which is being compiled.")
(defvar byte-compile-pc 0
"Index in byte string to store next opcode at.")
(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.")
(defconst byte-varref 8
"Byte code opcode for variable reference.")
(defconst byte-varset 16
"Byte code opcode for setting a variable.")
(defconst byte-varbind 24
"Byte code opcode for binding a variable.")
(defconst byte-call 32
"Byte code opcode for calling a function.")
(defconst byte-unbind 40
"Byte code opcode for unbinding special bindings.")
(defconst byte-constant 192
"Byte code opcode for reference to a constant.")
(defconst byte-constant-limit 64
"Maximum index usable in byte-constant opcode.")
(defconst byte-constant2 129
"Byte code opcode for reference to a constant with vector index >= 0100.")
(defconst byte-goto 130
"Byte code opcode for unconditional jump")
(defconst byte-goto-if-nil 131
"Byte code opcode for pop value and jump if it's nil.")
(defconst byte-goto-if-not-nil 132
"Byte code opcode for pop value and jump if it's not nil.")
(defconst byte-goto-if-nil-else-pop 133
"Byte code opcode for examine top-of-stack, jump and don't pop it if it's nil,
otherwise pop it.")
(defconst byte-goto-if-not-nil-else-pop 134
"Byte code opcode for examine top-of-stack, jump and don't pop it if it's not nil,
otherwise pop it.")
(defconst byte-return 135
"Byte code opcode for pop value and return it from byte code interpreter.")
(defconst byte-discard 136
"Byte code opcode to discard one value from stack.")
(defconst byte-dup 137
"Byte code opcode to duplicate the top of the stack.")
(defconst byte-save-excursion 138
"Byte code opcode to make a binding to record the buffer, point and mark.")
(defconst byte-save-window-excursion 139
"Byte code opcode to make a binding to record entire window configuration.")
(defconst byte-save-restriction 140
"Byte code opcode to make a binding to record the current buffer clipping restrictions.")
(defconst byte-catch 141
"Byte code opcode for catch. Takes, on stack, the tag and an expression for the body.")
(defconst byte-unwind-protect 142
"Byte code opcode for unwind-protect. Takes, on stack, an expression for the body
and an expression for the unwind-action.")
(defconst byte-condition-case 143
"Byte code opcode for condition-case. Takes, on stack, the variable to bind,
an expression for the body, and a list of clauses.")
(defconst byte-temp-output-buffer-setup 144
"Byte code opcode 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.")
(defconst byte-temp-output-buffer-show 145
"Byte code opcode 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.")
(defconst byte-nth 56)
(defconst byte-symbolp 57)
(defconst byte-consp 58)
(defconst byte-stringp 59)
(defconst byte-listp 60)
(defconst byte-eq 61)
(defconst byte-memq 62)
(defconst byte-not 63)
(defconst byte-car 64)
(defconst byte-cdr 65)
(defconst byte-cons 66)
(defconst byte-list1 67)
(defconst byte-list2 68)
(defconst byte-list3 69)
(defconst byte-list4 70)
(defconst byte-length 71)
(defconst byte-aref 72)
(defconst byte-aset 73)
(defconst byte-symbol-value 74)
(defconst byte-symbol-function 75)
(defconst byte-set 76)
(defconst byte-fset 77)
(defconst byte-get 78)
(defconst byte-substring 79)
(defconst byte-concat2 80)
(defconst byte-concat3 81)
(defconst byte-concat4 82)
(defconst byte-sub1 83)
(defconst byte-add1 84)
(defconst byte-eqlsign 85)
(defconst byte-gtr 86)
(defconst byte-lss 87)
(defconst byte-leq 88)
(defconst byte-geq 89)
(defconst byte-diff 90)
(defconst byte-negate 91)
(defconst byte-plus 92)
(defconst byte-max 93)
(defconst byte-min 94)
(defconst byte-point 96)
;(defconst byte-mark 97) no longer generated -- lisp code shouldn't call this very frequently
(defconst byte-goto-char 98)
(defconst byte-insert 99)
(defconst byte-point-max 100)
(defconst byte-point-min 101)
(defconst byte-char-after 102)
(defconst byte-following-char 103)
(defconst byte-preceding-char 104)
(defconst byte-current-column 105)
(defconst byte-indent-to 106)
;(defconst byte-scan-buffer 107) no longer generated
(defconst byte-eolp 108)
(defconst byte-eobp 109)
(defconst byte-bolp 110)
(defconst byte-bobp 111)
(defconst byte-current-buffer 112)
(defconst byte-set-buffer 113)
(defconst byte-read-char 114)
;(defconst byte-set-mark 115) ;obsolete
(defconst byte-interactive-p 116)
(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, offer to compile the .el file
only if a prefix argument has been specified."
(interactive "DByte recompile directory: \nP")
(save-some-buffers)
(setq directory (expand-file-name directory))
(let ((files (directory-files directory nil "\\.el\\'"))
(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 (concat (file-name-sans-versions source) "c"))
(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)
"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."
(interactive "fByte compile file: ")
;; Expand now so we get the current buffer's defaults
(setq filename (expand-file-name filename))
(message "Compiling %s..." filename)
(let ((inbuffer (get-buffer-create " *Compiler Input*"))
(outbuffer (get-buffer-create " *Compiler Output*"))
(byte-compile-macro-environment nil)
(case-fold-search nil)
(continue t) sexp list)
(save-excursion
(set-buffer inbuffer)
(erase-buffer)
(insert-file-contents filename)
(goto-char 1)
(set-buffer outbuffer)
(emacs-lisp-mode)
(erase-buffer)
(while continue ; Collect adjacent forms
(setq sexp nil)
(if (and (setq continue
(save-excursion
(set-buffer inbuffer)
(while (progn (skip-chars-forward " \t\n\^l")
(looking-at ";"))
(forward-line 1))
(not (eobp))))
(setq sexp (read inbuffer)) ; Split at NIL
(not (memq (car-safe sexp) ; Split at defining functions
'(defun defmacro defvar defconst defmacro-protect
autoload require))))
(setq list (cons sexp list))
(if list
(progn (setq list (byte-compile-top-level-forms (nreverse list)))
(let ((standard-output outbuffer))
(mapcar 'print (delq nil list)))
(setq list nil)))
(if sexp (print (byte-compile-file-form sexp) outbuffer))))
(set-buffer outbuffer)
(goto-char 1)
;; In each defun or autoload, if there is a doc string,
;; put a backslash-newline at the front of it.
(while (search-forward "\n(" nil t)
(cond ((looking-at "defun \\|autoload ")
(forward-sexp 3)
(skip-chars-forward " ")
(if (looking-at "\"")
(progn (forward-char 1)
(insert "\\\n"))))))
(goto-char 1)
;; In each defconst or defvar, if there is a doc string
;; and it starts on the same line as the form begins
;; (i.e. if there is no newline in a string in the initial value)
;; then put in backslash-newline at the start of the doc string.
(while (search-forward "\n(" nil t)
(if (looking-at "defvar \\|defconst ")
(let ((this-line (1- (point))))
;;Go to end of initial value expression
(if (condition-case ()
(progn (forward-sexp 3) t)
(error nil))
(progn
(skip-chars-forward " ")
(and (eq this-line
(save-excursion (beginning-of-line) (point)))
(looking-at "\"")
(progn (forward-char 1)
(insert "\\\n"))))))))
(let ((vms-stmlf-recfm t))
(write-region 1 (point-max)
(concat (file-name-sans-versions filename) "c")))
(kill-buffer (current-buffer))
(kill-buffer inbuffer)))
t)
(defun byte-compile-file-form (form)
(cond ((not (consp form))
form)
((memq (car form) '(defun defmacro defmacro-protect))
(let* ((name (car (cdr form)))
(tem (assq name byte-compile-macro-environment)))
(if (eq (car form) 'defun)
(progn
(message "Compiling %s (%s)..." filename (nth 1 form))
(cond (tem (setcdr tem nil))
((and (fboundp name)
(eq (car-safe (symbol-function name)) 'macro))
;; shadow existing macro definition
(setq byte-compile-macro-environment
(cons (cons name nil)
byte-compile-macro-environment))))
(prog1 (byte-compile-top-level form)
(if (not noninteractive)
(message "Compiling %s..." filename))))
;; defmacro
(prog1 (setq form (byte-compile-top-level form))
(if tem
(setcdr tem (cons 'lambda (cdr (cdr form))))
(setq byte-compile-macro-environment
(cons (cons name (cons 'lambda (cdr (cdr form))))
byte-compile-macro-environment)))))))
((eq (car form) 'require)
(eval form)
form)
(t (byte-compile-top-level form))))
;; Expected 'gain' from byte-compiling various forms.
;; Initially, the gain (from byte-compiling an empty form) is negative.
;; Note that byte-compile-top-leve-forms (used f.ex to compile defuns)
;; subtracts (get 'progn byte-compile-gain) from the initial gain, because
;; it removes the extra 'progn after calling byte-compile-top-level.
;; THE VALUES ARE RATHER ARBITRARILY CHOSEN, I DON'T KNOW WHAT THEY SHOULD BE.
;; Initial gain (from byte-compiling an empty form):
(defconst byte-compile-filelevel-gain -50) ; At outer level.
(defconst byte-compile-toplevel-gain -30) ; Elsewhere (inside defuns etc)
;; Gains from compiling various forms:
(defconst byte-compile-atom-gain 2) ; Atoms
(defconst byte-compile-spec-call-gain 11) ; Calling functions with special
; handlers for 2nd compiler pass
(defconst byte-compile-subr-call-gain 8) ; Calling subr's (without handlers)
(defconst byte-compile-lambda-call-gain 10) ; Calling lambda's
;; Gains for specific functions:
(mapcar (function (lambda (x)
(mapcar (function (lambda (f)
(put f 'byte-compile-gain (car x))))
(cdr x))))
'(( 0 byte-comp-protect) ; (byte-comp-protect FM) -> (eval 'FM)
;; All UNEVALLED subr's except function,interactive,setq-default
( 13 prog1 prog2 progn quote)
( 14 let let* and cond if or setq while)
( 10 catch condition-case save-excursion save-restriction
save-window-excursion unwind-protect with-output-to-temp-buffer)
( -9 defconst defmacro defun defvar))) ; -> (eval '(defxxx ...))
(defmacro byte-compile-gain (func &rest args)
(` (setq byte-compile-gain ((, func) byte-compile-gain (,@ args)))))
(defvar byte-compile-initial-gain byte-compile-filelevel-gain)
(defvar byte-compile-gain 0)
(defvar byte-compile-thisgain 0)
(defun byte-compile (funname)
"Byte-compile the definition of function FUNNAME (a symbol)."
(if (fboundp funname)
(fset funname (byte-compile-fundef (symbol-function funname)))))
(defun byte-compile-fundef (form)
;; Byte-compile the function definition FORM.
(cond ((symbolp form) form)
((eq (car-safe form) 'lambda) (byte-compile-lambda form))
((eq (car-safe form) 'macro) (cons 'macro
(byte-compile-fundef (cdr form))))
((subrp form) form)
(t (signal 'invalid-function (list (car form))))))
(defun byte-compile-lambda (fun)
(let* ((bodyptr (cdr fun))
(int (assq 'interactive (cdr bodyptr)))
newbody)
;; Skip doc string.
(if (stringp (car (cdr bodyptr)))
(setq bodyptr (cdr bodyptr)))
(setq newbody (byte-compile-top-level-forms (cdr bodyptr)))
(if int
(setq newbody (cons (if (or (stringp (car (cdr int)))
(null (car (cdr int))))
int
(list 'interactive
(byte-compile-top-level (car (cdr int)))))
newbody)))
(if (eq bodyptr (cdr fun))
(and (null (cdr newbody)) (stringp (car newbody))
(setq newbody (cons nil newbody)))
(setq newbody (cons (nth 2 fun) newbody)))
(cons (car fun) (cons (car (cdr fun)) newbody))))
(defun byte-compile-top-level-forms (forms)
(let* ((byte-compile-initial-gain (- byte-compile-initial-gain
(get 'progn 'byte-compile-gain)))
(form (byte-compile-top-level (cons 'progn forms))))
(if (eq (car-safe form) 'progn)
(cdr form)
(list form))))
(defun byte-compile-just-one-form (forms)
(if (cdr forms)
(cons 'progn forms)
(car forms)))
(defun byte-compile-top-level (form)
(let* ((byte-compile-gain byte-compile-initial-gain)
(byte-compile-initial-gain byte-compile-toplevel-gain)
(all-vars nil))
(setq form (byte-prepare-form form))
(if (<= byte-compile-gain 0)
form
(let ((byte-compile-constants nil)
(byte-compile-constnum nil)
(byte-compile-pc 0)
(byte-compile-depth 0)
(byte-compile-maxdepth 0)
(byte-compile-output nil)
(byte-compile-string nil)
(byte-compile-vector nil))
(let ((vars (nreverse all-vars)) (i -1))
(while vars
(setq i (1+ i))
(setq byte-compile-constants (cons (cons (car vars) i)
byte-compile-constants))
(setq vars (cdr vars)))
(setq byte-compile-constnum i))
(byte-compile-form form)
(byte-compile-out 'byte-return 0)
(setq byte-compile-vector (make-vector (1+ byte-compile-constnum)
nil))
(while byte-compile-constants
(aset byte-compile-vector (cdr (car byte-compile-constants))
(car (car byte-compile-constants)))
(setq byte-compile-constants (cdr byte-compile-constants)))
(setq byte-compile-string (make-string byte-compile-pc 0))
(while byte-compile-output
(aset byte-compile-string (car (car byte-compile-output))
(cdr (car byte-compile-output)))
(setq byte-compile-output (cdr byte-compile-output)))
(list 'byte-code byte-compile-string
byte-compile-vector byte-compile-maxdepth)))))
;; Walk FORM, expanding macros, and transforming FORM into a form which
;; byte-compile-form can process. This includes byte-compiling f.ex the
;; clauses of condition-case and the bodies of defuns/defmacros, and
;; handling special cases such as setq without arguments. All forms pass
;; through byte-prepare-form before byte-compile-form. byte-compile-form
;; may modify its argument only if byte-prepare-form would not modify the
;; result.
;; Return the derived form. This is a copy; FORM itself is not altered.
;; Also make sure all variables it uses are in ALL-VARS, and add estimated
;; gain from byte-compiling the result, to BYTE-COMPILE-GAIN.
;; ALL-VARS is ordered with the variables encountered earliest at the end.
(defun byte-prepare-form (form)
(cond ((not (consp form))
(byte-compile-gain + byte-compile-atom-gain)
(and (symbolp form)
(not (memq form all-vars))
(setq all-vars (cons form all-vars)))
form)
((not (eq form (setq form (macroexpand
form byte-compile-macro-environment))))
(byte-prepare-form form))
(t
(let ((tmp (car form)))
(cond ((consp tmp)
(if (eq (car tmp) 'macro)
;; ((macro ...) arg...)
(byte-prepare-form
(macroexpand (cons 'byte-compile-tmpmac (cdr form))
(cons (cons 'byte-compile-tmpmac (cdr tmp))
byte-compile-macro-environment)))
;; Should be ((lambda () ...) arg...)
(byte-compile-gain + byte-compile-lambda-call-gain)
(cons (byte-compile-fundef tmp)
(mapcar 'byte-prepare-form (cdr form)))))
(t
(setq byte-compile-thisgain
(cond ((get tmp 'byte-compile-gain))
((get tmp 'byte-compile)
byte-compile-spec-call-gain)
((and (fboundp tmp)
(subrp (symbol-function tmp)))
byte-compile-subr-call-gain)
(t
byte-compile-lambda-call-gain)))
(byte-compile-gain + byte-compile-thisgain)
(if (setq tmp (get tmp 'byte-prepare))
(funcall tmp form)
(byte-prepare-normal-call form))))))))
(defun byte-prepare-normal-call (form)
(cons (car form)
(mapcar 'byte-prepare-form (cdr form))))
;; This is the recursive entry point for compiling each subform of an expression.
;; Note that handler functions SHOULD NOT increment byte-compile-depth
;; for the values they are returning! That is done on return here.
;; Handlers should make sure that the depth on exit is the same as
;; it was when the handler was called.
(defun byte-compile-form (form)
(cond ((eq form 'nil)
(byte-compile-constant form))
((eq form 't)
(byte-compile-constant form))
((symbolp form)
(byte-compile-variable-ref 'byte-varref form))
((not (consp form))
(byte-compile-constant form))
(t
(let ((handler (and (symbolp (car form))
(get (car form) 'byte-compile))))
(if handler
(funcall handler form)
(byte-compile-normal-call form)))))
(setq byte-compile-maxdepth
(max byte-compile-maxdepth
(setq byte-compile-depth (1+ byte-compile-depth)))))
(defun byte-compile-normal-call (form)
(byte-compile-push-constant (car form))
(let ((copy (cdr form)))
(while copy (byte-compile-form (car copy)) (setq copy (cdr copy))))
(byte-compile-out 'byte-call (length (cdr form)))
(setq byte-compile-depth (- byte-compile-depth (length (cdr form)))))
(defun byte-compile-variable-ref (base-op var)
(let ((data (assq var byte-compile-constants)))
(if data
(byte-compile-out base-op (cdr data))
(error (format "Variable %s seen on pass 2 of byte compiler but not pass 1"
(prin1-to-string var))))))
;; Use this when the value of a form is a constant,
;; because byte-compile-depth will be incremented accordingly
;; on return to byte-compile-form, so it should not be done by the handler.
(defun byte-compile-constant (const)
(let ((data (if (stringp const)
(assoc const byte-compile-constants)
(assq const byte-compile-constants))))
(if data
(byte-compile-out-const (cdr data))
(setq byte-compile-constants
(cons (cons const (setq byte-compile-constnum (1+ byte-compile-constnum)))
byte-compile-constants))
(byte-compile-out-const byte-compile-constnum))))
;; Use this for a constant that is not the value of its containing form.
;; Note that the calling function must explicitly decrement byte-compile-depth
;; (or perhaps call byte-compile-discard to do so)
;; for the word pushed by this function.
(defun byte-compile-push-constant (const)
(byte-compile-constant const)
(setq byte-compile-maxdepth
(max byte-compile-maxdepth
(setq byte-compile-depth (1+ byte-compile-depth)))))
;; Compile those primitive ordinary functions
;; which have special byte codes just for speed.
(put 'point 'byte-compile 'byte-compile-no-args)
(put 'point 'byte-opcode 'byte-point)
(put 'dot 'byte-compile 'byte-compile-no-args)
(put 'dot 'byte-opcode 'byte-point)
;(put 'mark 'byte-compile 'byte-compile-no-args)
;(put 'mark 'byte-opcode 'byte-mark)
(put 'point-max 'byte-compile 'byte-compile-no-args)
(put 'point-max 'byte-opcode 'byte-point-max)
(put 'point-min 'byte-compile 'byte-compile-no-args)
(put 'point-min 'byte-opcode 'byte-point-min)
(put 'dot-max 'byte-compile 'byte-compile-no-args)
(put 'dot-max 'byte-opcode 'byte-point-max)
(put 'dot-min 'byte-compile 'byte-compile-no-args)
(put 'dot-min 'byte-opcode 'byte-point-min)
(put 'following-char 'byte-compile 'byte-compile-no-args)
(put 'following-char 'byte-opcode 'byte-following-char)
(put 'preceding-char 'byte-compile 'byte-compile-no-args)
(put 'preceding-char 'byte-opcode 'byte-preceding-char)
(put 'current-column 'byte-compile 'byte-compile-no-args)
(put 'current-column 'byte-opcode 'byte-current-column)
(put 'eolp 'byte-compile 'byte-compile-no-args)
(put 'eolp 'byte-opcode 'byte-eolp)
(put 'eobp 'byte-compile 'byte-compile-no-args)
(put 'eobp 'byte-opcode 'byte-eobp)
(put 'bolp 'byte-compile 'byte-compile-no-args)
(put 'bolp 'byte-opcode 'byte-bolp)
(put 'bobp 'byte-compile 'byte-compile-no-args)
(put 'bobp 'byte-opcode 'byte-bobp)
(put 'current-buffer 'byte-compile 'byte-compile-no-args)
(put 'current-buffer 'byte-opcode 'byte-current-buffer)
(put 'read-char 'byte-compile 'byte-compile-no-args)
(put 'read-char 'byte-opcode 'byte-read-char)
(put 'symbolp 'byte-compile 'byte-compile-one-arg)
(put 'symbolp 'byte-opcode 'byte-symbolp)
(put 'consp 'byte-compile 'byte-compile-one-arg)
(put 'consp 'byte-opcode 'byte-consp)
(put 'stringp 'byte-compile 'byte-compile-one-arg)
(put 'stringp 'byte-opcode 'byte-stringp)
(put 'listp 'byte-compile 'byte-compile-one-arg)
(put 'listp 'byte-opcode 'byte-listp)
(put 'not 'byte-compile 'byte-compile-one-arg)
(put 'not 'byte-opcode 'byte-not)
(put 'null 'byte-compile 'byte-compile-one-arg)
(put 'null 'byte-opcode 'byte-not)
(put 'car 'byte-compile 'byte-compile-one-arg)
(put 'car 'byte-opcode 'byte-car)
(put 'cdr 'byte-compile 'byte-compile-one-arg)
(put 'cdr 'byte-opcode 'byte-cdr)
(put 'length 'byte-compile 'byte-compile-one-arg)
(put 'length 'byte-opcode 'byte-length)
(put 'symbol-value 'byte-compile 'byte-compile-one-arg)
(put 'symbol-value 'byte-opcode 'byte-symbol-value)
(put 'symbol-function 'byte-compile 'byte-compile-one-arg)
(put 'symbol-function 'byte-opcode 'byte-symbol-function)
(put '1+ 'byte-compile 'byte-compile-one-arg)
(put '1+ 'byte-opcode 'byte-add1)
(put '1- 'byte-compile 'byte-compile-one-arg)
(put '1- 'byte-opcode 'byte-sub1)
(put 'goto-char 'byte-compile 'byte-compile-one-arg)
(put 'goto-char 'byte-opcode 'byte-goto-char)
(put 'char-after 'byte-compile 'byte-compile-one-arg)
(put 'char-after 'byte-opcode 'byte-char-after)
(put 'set-buffer 'byte-compile 'byte-compile-one-arg)
(put 'set-buffer 'byte-opcode 'byte-set-buffer)
;set-mark turns out to be too unimportant for its own opcode.
;(put 'set-mark 'byte-compile 'byte-compile-one-arg)
;(put 'set-mark 'byte-opcode 'byte-set-mark)
(put 'eq 'byte-compile 'byte-compile-two-args)
(put 'eq 'byte-opcode 'byte-eq)
(put 'eql 'byte-compile 'byte-compile-two-args)
(put 'eql 'byte-opcode 'byte-eq)
(put 'memq 'byte-compile 'byte-compile-two-args)
(put 'memq 'byte-opcode 'byte-memq)
(put 'cons 'byte-compile 'byte-compile-two-args)
(put 'cons 'byte-opcode 'byte-cons)
(put 'aref 'byte-compile 'byte-compile-two-args)
(put 'aref 'byte-opcode 'byte-aref)
(put 'set 'byte-compile 'byte-compile-two-args)
(put 'set 'byte-opcode 'byte-set)
(put 'fset 'byte-compile 'byte-compile-two-args)
(put 'fset 'byte-opcode 'byte-fset)
(put '= 'byte-compile 'byte-compile-two-args)
(put '= 'byte-opcode 'byte-eqlsign)
(put '< 'byte-compile 'byte-compile-two-args)
(put '< 'byte-opcode 'byte-lss)
(put '> 'byte-compile 'byte-compile-two-args)
(put '> 'byte-opcode 'byte-gtr)
(put '<= 'byte-compile 'byte-compile-two-args)
(put '<= 'byte-opcode 'byte-leq)
(put '>= 'byte-compile 'byte-compile-two-args)
(put '>= 'byte-opcode 'byte-geq)
(put 'get 'byte-compile 'byte-compile-two-args)
(put 'get 'byte-opcode 'byte-get)
(put 'nth 'byte-compile 'byte-compile-two-args)
(put 'nth 'byte-opcode 'byte-nth)
(put 'aset 'byte-compile 'byte-compile-three-args)
(put 'aset 'byte-opcode 'byte-aset)
(defun byte-compile-no-args (form)
(if (/= (length form) 1)
;; get run-time wrong-number-of-args error.
;; Would be nice if there were some way to do
;; compile-time warnings.
(byte-compile-normal-call form)
(byte-compile-out (symbol-value (get (car form) 'byte-opcode)) 0)))
(defun byte-compile-one-arg (form)
(if (/= (length form) 2)
(byte-compile-normal-call form)
(byte-compile-form (car (cdr form))) ;; Push the argument
(setq byte-compile-depth (1- byte-compile-depth))
(byte-compile-out (symbol-value (get (car form) 'byte-opcode)) 0)))
(defun byte-compile-two-args (form)
(if (/= (length form) 3)
(byte-compile-normal-call form)
(byte-compile-form (car (cdr form))) ;; Push the arguments
(byte-compile-form (nth 2 form))
(setq byte-compile-depth (- byte-compile-depth 2))
(byte-compile-out (symbol-value (get (car form) 'byte-opcode)) 0)))
(defun byte-compile-three-args (form)
(if (/= (length form) 4)
(byte-compile-normal-call form)
(byte-compile-form (car (cdr form))) ;; Push the arguments
(byte-compile-form (nth 2 form))
(byte-compile-form (nth 3 form))
(setq byte-compile-depth (- byte-compile-depth 3))
(byte-compile-out (symbol-value (get (car form) 'byte-opcode)) 0)))
(defun byte-prepare-const-if-empty (form)
(if (and (cdr form)
(or (cdr (cdr form))
(not (get (car form) 'byte-prepare-reduce-1arg))))
(byte-prepare-normal-call form)
(byte-compile-gain - byte-compile-thisgain)
(byte-prepare-form (if (cdr form)
(nth 1 form)
(list 'quote (eval form))))))
(put 'substring 'byte-compile 'byte-compile-substring)
(defun byte-compile-substring (form)
(if (or (> (length form) 4)
(< (length form) 2))
(byte-compile-normal-call form)
(byte-compile-form (nth 1 form))
(byte-compile-form (or (nth 2 form) ''nil)) ;Optional arguments
(byte-compile-form (or (nth 3 form) ''nil))
(setq byte-compile-depth (- byte-compile-depth 3))
(byte-compile-out byte-substring 0)))
(put 'interactive-p 'byte-compile 'byte-compile-interactive-p)
(defun byte-compile-interactive-p (form)
(byte-compile-out byte-interactive-p 0))
(put 'list 'byte-prepare 'byte-prepare-const-if-empty)
(put 'list 'byte-compile 'byte-compile-list)
(defun byte-compile-list (form)
(let ((len (length form)))
(if (< len 6)
(let ((args (cdr form)))
(while args
(byte-compile-form (car args))
(setq args (cdr args)))
(setq byte-compile-depth (- byte-compile-depth (1- len)))
(byte-compile-out (symbol-value
(nth (- len 2)
'(byte-list1 byte-list2 byte-list3 byte-list4)))
0))
(byte-compile-normal-call form))))
(put 'concat 'byte-prepare 'byte-prepare-const-if-empty)
(put 'concat 'byte-compile 'byte-compile-concat)
(defun byte-compile-concat (form)
(let ((len (length form)))
(cond ((= len 2)
;; Concat of one arg is not a no-op if arg is not a string.
(byte-compile-normal-call form))
((< len 6)
(let ((args (cdr form)))
(while args
(byte-compile-form (car args))
(setq args (cdr args)))
(setq byte-compile-depth (- byte-compile-depth (1- len)))
(byte-compile-out
(symbol-value (nth (- len 3)
'(byte-concat2 byte-concat3 byte-concat4)))
0)))
(t
(byte-compile-normal-call form)))))
(put '- 'byte-compile 'byte-compile-minus)
(defun byte-compile-minus (form)
(let ((len (length form)))
(cond ((= len 2)
(byte-compile-form (car (cdr form)))
(setq byte-compile-depth (- byte-compile-depth 1))
(byte-compile-out byte-negate 0))
((= len 3)
(byte-compile-form (car (cdr form)))
(byte-compile-form (nth 2 form))
(setq byte-compile-depth (- byte-compile-depth 2))
(byte-compile-out byte-diff 0))
(t (byte-compile-normal-call form)))))
(put '+ 'byte-compile 'byte-compile-maybe-two-args)
(put '+ 'byte-opcode 'byte-plus)
(put 'max 'byte-compile 'byte-compile-maybe-two-args)
(put 'max 'byte-opcode 'byte-max)
(put 'min 'byte-compile 'byte-compile-maybe-two-args)
(put 'min 'byte-opcode 'byte-min)
(defun byte-compile-maybe-two-args (form)
(let ((len (length form)))
(if (= len 3)
(progn
(byte-compile-form (car (cdr form)))
(byte-compile-form (nth 2 form))
(setq byte-compile-depth (- byte-compile-depth 2))
(byte-compile-out (symbol-value (get (car form) 'byte-opcode)) 0))
(byte-compile-normal-call form))))
(put 'function 'byte-prepare 'byte-prepare-function)
(put 'function 'byte-compile-gain 0)
(defun byte-prepare-function (form)
(byte-prepare-form
(list 'quote (byte-compile-fundef (car (cdr form))))))
(put 'indent-to 'byte-compile 'byte-compile-indent-to)
(defun byte-compile-indent-to (form)
(let ((len (length form)))
(if (= len 2)
(progn
(byte-compile-form (car (cdr form)))
(setq byte-compile-depth (- byte-compile-depth 1))
(byte-compile-out byte-indent-to 0))
(byte-compile-normal-call form))))
(put 'insert 'byte-compile 'byte-compile-insert)
(defun byte-compile-insert (form)
(let ((len (length form)))
(if (< len 3)
(let ((args (cdr form)))
(while args
(byte-compile-form (car args))
(setq byte-compile-depth (- byte-compile-depth 1))
(byte-compile-out byte-insert 0)
(setq args (cdr args))))
(byte-compile-normal-call form))))
(put 'setq-default 'byte-compile 'byte-compile-setq-default)
(defun byte-compile-setq-default (form)
(byte-compile-form (cons 'set-default (cons (list 'quote (nth 1 form))
(nthcdr 2 form)))))
(put 'quote 'byte-prepare 'byte-prepare-quote)
(put 'quote 'byte-compile 'byte-compile-quote)
(defun byte-prepare-quote (form)
(let ((val (car (cdr form))))
(if (or (consp val)
(and (symbolp val) (not (memq val '(nil t)))))
form
(byte-compile-gain + (- byte-compile-thisgain) byte-compile-atom-gain)
val)))
(defun byte-compile-quote (form)
(byte-compile-constant (car (cdr form))))
(put 'setq 'byte-prepare 'byte-prepare-const-if-empty)
(put 'setq 'byte-compile 'byte-compile-setq)
(defun byte-compile-setq (form)
(let ((args (cdr form)))
(while args
(byte-compile-form (car (cdr args)))
(if (null (cdr (cdr args)))
(progn
(byte-compile-out 'byte-dup 0)
(setq byte-compile-maxdepth (max byte-compile-maxdepth (1+ byte-compile-depth)))))
(setq byte-compile-depth (1- byte-compile-depth))
(byte-compile-variable-ref 'byte-varset (car args))
(setq args (cdr (cdr args))))))
(defun byte-prepare-flatten (form)
(prog1 (setq form (byte-prepare-normal-call form))
(let (list this)
(while (setq list (cdr form))
(setq this (car list))
(cond ((eq (car-safe this) 'progn)
;; Flatten nested progn's
(byte-compile-gain - (get 'progn 'byte-compile-gain))
(setcdr form (nconc (or (cdr this) '(nil))
(cdr list))))
((and (cdr list)
(if (consp this)
(eq (car this) 'quote)
(or (not (symbolp this)) (memq this '(nil t)))))
;; Skip this no-op: an atom or (quote whatever).
(byte-compile-gain - (if (consp this)
(get 'quote 'byte-compile-gain)
byte-compile-atom-gain))
(setcdr form (cdr list)))
(t;; Next.
(setcar (setq form list) this)))))))
(defun byte-prepare-letX (form)
(let* ((binds (copy-sequence (car (cdr form))))
(body (cdr (cdr form)))
(tail binds) sym val)
(while tail
(if (consp (setq sym (car tail)))
(setq val (car (cdr sym))
sym (car sym))
(setq val nil))
(if (not (memq sym all-vars))
(setq all-vars (cons sym all-vars)))
(setcar tail (if val
(list sym (byte-prepare-form val))
sym))
(setq tail (cdr tail)))
(byte-compile-gain + (* byte-compile-atom-gain (length binds)))
(cons (car form) (byte-prepare-flatten (cons binds body)))))
(put 'let 'byte-prepare 'byte-prepare-letX)
(put 'let 'byte-compile 'byte-compile-let)
(defun byte-compile-let (form)
(let ((varlist (car (cdr form))))
(while varlist
(if (symbolp (car varlist))
(byte-compile-push-constant nil)
(byte-compile-form (car (cdr (car varlist)))))
(setq varlist (cdr varlist))))
(let ((varlist (reverse (car (cdr form)))))
(setq byte-compile-depth (- byte-compile-depth (length varlist)))
(while varlist
(if (symbolp (car varlist))
(byte-compile-variable-ref 'byte-varbind (car varlist))
(byte-compile-variable-ref 'byte-varbind (car (car varlist))))
(setq varlist (cdr varlist))))
(byte-compile-body (cdr (cdr form)))
(byte-compile-out 'byte-unbind (length (car (cdr form)))))
(put 'let* 'byte-prepare 'byte-prepare-letX)
(put 'let* 'byte-compile 'byte-compile-let*)
(defun byte-compile-let* (form)
(let ((varlist (car (cdr form))))
(while varlist
(if (symbolp (car varlist))
(byte-compile-push-constant nil)
(byte-compile-form (car (cdr (car varlist)))))
(setq byte-compile-depth (1- byte-compile-depth))
(if (symbolp (car varlist))
(byte-compile-variable-ref 'byte-varbind (car varlist))
(byte-compile-variable-ref 'byte-varbind (car (car varlist))))
(setq varlist (cdr varlist))))
(byte-compile-body (cdr (cdr form)))
(byte-compile-out 'byte-unbind (length (car (cdr form)))))
(put 'save-excursion 'byte-compile 'byte-compile-save-excursion)
(defun byte-compile-save-excursion (form)
(byte-compile-out 'byte-save-excursion 0)
(byte-compile-body (cdr form))
(byte-compile-out 'byte-unbind 1))
(put 'save-restriction 'byte-compile 'byte-compile-save-restriction)
(defun byte-compile-save-restriction (form)
(byte-compile-out 'byte-save-restriction 0)
(byte-compile-body (cdr form))
(byte-compile-out 'byte-unbind 1))
(put 'with-output-to-temp-buffer 'byte-compile 'byte-compile-with-output-to-temp-buffer)
(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)
(setq byte-compile-depth (1- byte-compile-depth)))
(put 'interactive 'byte-prepare 'byte-prepare-noop)
(put 'interactive 'byte-compile-gain byte-compile-atom-gain)
;; This is safe because byte-compile-lambda has already found 'interactive.
;; I don't call (byte-prepare-form nil), putting nil into all-vars, because
;; it will probably be removed by byte-prepare-flatten anyway.
(defun byte-prepare-noop (form)
nil)
(put 'progn 'byte-prepare 'byte-prepare-progn)
(put 'progn 'byte-compile 'byte-compile-progn)
(defun byte-prepare-progn (form)
(setq form (byte-prepare-flatten form))
(if (cdr (cdr form))
form
(byte-compile-gain - (get 'progn 'byte-compile-gain))
(car (cdr form))))
(defun byte-compile-progn (form)
(byte-compile-body (cdr form)))
(defun byte-compile-body (body)
(if (null body)
(byte-compile-constant nil)
(while body
(byte-compile-form (car body))
(if (cdr body)
(byte-compile-discard)
;; Convention is this will be counted after we return.
(setq byte-compile-depth (1- byte-compile-depth)))
(setq body (cdr body)))))
(put 'prog1 'byte-prepare 'byte-prepare-const-if-empty)
(put 'prog1 'byte-prepare-reduce-1arg t)
(put 'prog1 'byte-compile 'byte-compile-prog1)
(defun byte-compile-prog1 (form)
(byte-compile-form (car (cdr form)))
(byte-compile-body (cdr (cdr form)))
;; This discards the value pushed by ..-body
;; (which is not counted now in byte-compile-depth)
;; and decrements byte-compile-depth for the value
;; pushed by byte-compile-form above, which by convention
;; will be counted in byte-compile-depth after we return.
(byte-compile-discard))
(put 'prog2 'byte-compile 'byte-compile-prog2)
(defun byte-compile-prog2 (form)
(byte-compile-form (car (cdr form)))
(byte-compile-discard)
(byte-compile-form (nth 2 form))
(if (cdr (cdr (cdr form)))
(progn
(byte-compile-body (cdr (cdr (cdr form))))
(byte-compile-discard))))
(defun byte-compile-discard ()
(byte-compile-out 'byte-discard 0)
(setq byte-compile-depth (1- byte-compile-depth)))
(put 'if 'byte-compile 'byte-compile-if)
(defun byte-compile-if (form)
(if (null (nthcdr 3 form))
;; No else-forms
(let ((donetag (byte-compile-make-tag)))
(byte-compile-form (car (cdr form)))
(byte-compile-goto 'byte-goto-if-nil-else-pop donetag)
(setq byte-compile-depth (1- byte-compile-depth))
(byte-compile-form (nth 2 form))
(setq byte-compile-depth (1- byte-compile-depth))
(byte-compile-out-tag donetag))
(let ((donetag (byte-compile-make-tag)) (elsetag (byte-compile-make-tag)))
(byte-compile-form (car (cdr form)))
(byte-compile-goto 'byte-goto-if-nil elsetag)
(setq byte-compile-depth (1- byte-compile-depth))
(byte-compile-form (nth 2 form))
(setq byte-compile-depth (1- byte-compile-depth))
(byte-compile-goto 'byte-goto donetag)
(byte-compile-out-tag elsetag)
(byte-compile-body (cdr (cdr (cdr form))))
(byte-compile-out-tag donetag))))
(put 'cond 'byte-prepare 'byte-prepare-cond)
(put 'cond 'byte-compile 'byte-compile-cond)
(defun byte-prepare-cond (form)
(if (cdr form)
(prog1 (setq form (copy-sequence form))
(while (setq form (cdr form))
(setcar form (byte-prepare-flatten
(cons (byte-prepare-form (car (car form)))
(cdr (car form)))))))
(byte-compile-gain + (- byte-compile-thisgain) byte-compile-atom-gain)
nil))
(defun byte-compile-cond (clauses)
(setq clauses (cdr clauses))
(if (or (eq (car (car clauses)) t)
(eq (car-safe (car (car clauses))) 'quote))
;; Unconditional clause
(byte-compile-body (cdr (car clauses)))
(if (null (cdr clauses))
;; Only one clause
(let ((donetag (byte-compile-make-tag)))
(byte-compile-form (car (car clauses)))
(cond ((cdr (car clauses))
(byte-compile-goto 'byte-goto-if-nil-else-pop donetag)
(setq byte-compile-depth (1- byte-compile-depth))
(byte-compile-body (cdr (car clauses)))
(byte-compile-out-tag donetag))))
(let ((donetag (byte-compile-make-tag))
(elsetag (byte-compile-make-tag)))
(byte-compile-form (car (car clauses)))
(if (null (cdr (car clauses)))
;; First clause is a singleton.
(progn
(byte-compile-goto 'byte-goto-if-not-nil-else-pop donetag)
(setq byte-compile-depth (1- byte-compile-depth)))
(byte-compile-goto 'byte-goto-if-nil elsetag)
(setq byte-compile-depth (1- byte-compile-depth))
(byte-compile-body (cdr (car clauses)))
(byte-compile-goto 'byte-goto donetag)
(byte-compile-out-tag elsetag))
(byte-compile-cond clauses)
(byte-compile-out-tag donetag)))))
(put 'and 'byte-prepare 'byte-prepare-const-if-empty)
(put 'and 'byte-prepare-reduce-1arg t)
(put 'and 'byte-compile 'byte-compile-and)
(defun byte-compile-and (form)
(let ((failtag (byte-compile-make-tag))
(args (cdr form)))
(while args
(byte-compile-form (car args))
(setq byte-compile-depth (1- byte-compile-depth))
(if (null (cdr args))
(byte-compile-out-tag failtag)
(byte-compile-goto 'byte-goto-if-nil-else-pop failtag))
(setq args (cdr args)))))
(put 'or 'byte-prepare 'byte-prepare-const-if-empty)
(put 'or 'byte-prepare-reduce-1arg t)
(put 'or 'byte-compile 'byte-compile-or)
(defun byte-compile-or (form)
(let ((wintag (byte-compile-make-tag))
(args (cdr form)))
(while args
(byte-compile-form (car args))
(setq byte-compile-depth (1- byte-compile-depth))
(if (null (cdr args))
(byte-compile-out-tag wintag)
(byte-compile-goto 'byte-goto-if-not-nil-else-pop wintag))
(setq args (cdr args)))))
(put 'while 'byte-compile 'byte-compile-while)
(defun byte-compile-while (form)
(let ((endtag (byte-compile-make-tag))
(looptag (byte-compile-make-tag))
(args (cdr (cdr form))))
(byte-compile-out-tag looptag)
(byte-compile-form (car (cdr form)))
(byte-compile-goto 'byte-goto-if-nil-else-pop endtag)
(byte-compile-body (cdr (cdr form)))
(byte-compile-discard)
(byte-compile-goto 'byte-goto looptag)
(byte-compile-out-tag endtag)))
;; catch and unwind-protect are almost like condition case, but we
;; treat the first argument normally.
(defun byte-prepare-tagged-toplevel (form)
(cons (car form)
(cons (byte-prepare-form (car (cdr form)))
(byte-compile-top-level-forms (cdr (cdr form))))))
(put 'catch 'byte-prepare 'byte-prepare-tagged-toplevel)
(put 'catch 'byte-compile 'byte-compile-catch)
(defun byte-compile-catch (form)
(byte-compile-form (car (cdr form)))
(byte-compile-push-constant (byte-compile-just-one-form (cdr (cdr form))))
(setq byte-compile-depth (- byte-compile-depth 2))
(byte-compile-out 'byte-catch 0))
(put 'unwind-protect 'byte-prepare 'byte-prepare-tagged-toplevel)
(put 'unwind-protect 'byte-compile 'byte-compile-unwind-protect)
(defun byte-compile-unwind-protect (form)
(byte-compile-push-constant (cdr (cdr form)))
(setq byte-compile-depth (1- byte-compile-depth))
(byte-compile-out 'byte-unwind-protect 0)
(byte-compile-form (car (cdr form)))
(setq byte-compile-depth (1- byte-compile-depth))
(byte-compile-out 'byte-unbind 1))
(put 'save-window-excursion 'byte-prepare 'byte-prepare-save-window-excursion)
(put 'save-window-excursion 'byte-compile 'byte-compile-save-window-excursion)
(defun byte-prepare-save-window-excursion (form)
(cons (car form)
(byte-compile-top-level-forms (cdr form))))
(defun byte-compile-save-window-excursion (form)
(byte-compile-push-constant (cdr form))
(setq byte-compile-depth (1- byte-compile-depth))
(byte-compile-out 'byte-save-window-excursion 0))
(put 'condition-case 'byte-prepare 'byte-prepare-condition-case)
(put 'condition-case 'byte-compile 'byte-compile-condition-case)
(defun byte-prepare-condition-case (form)
;; Because condition-case is compiled by breaking out
;; all its subexpressions and compiling them separately,
;; we regard it here as containing nothing but constants.
(nconc (list (car form)
(car (cdr form))
(byte-compile-top-level (nth 2 form)))
(mapcar (function
(lambda (clause)
(cons (car clause)
(byte-compile-top-level-forms (cdr clause)))))
(nthcdr 3 form))))
(defun byte-compile-condition-case (form)
(byte-compile-push-constant (car (cdr form)))
(byte-compile-push-constant (nth 2 form))
(byte-compile-push-constant (nthcdr 3 form))
(setq byte-compile-depth (- byte-compile-depth 3))
(byte-compile-out 'byte-condition-case 0))
(put 'quote-form 'byte-prepare 'byte-prepare-quote-form)
(put 'quote-form 'byte-compile-gain 0)
(defun byte-prepare-quote-form (form)
(byte-prepare-form
(list 'quote (byte-compile-top-level (car (cdr form))))))
(put 'progn-expand 'byte-prepare 'byte-prepare-progn-expand)
(put 'progn-expand 'byte-compile-gain 0)
(defun byte-prepare-progn-expand (form)
(byte-prepare-form
(list 'quote (eval form))))
;; (byte-comp-protect form) becomes (eval 'form)
(put 'byte-comp-protect 'byte-prepare 'identity)
(put 'byte-comp-protect 'byte-compile 'byte-compile-byte-comp-protect)
(defun byte-compile-byte-comp-protect (form)
(byte-compile-form
(` (eval (quote (,@ (cdr form)))))))
;; Lambda's in valid places are handled as special cases by various code.
;; The ones that remain are errors.
(put 'lambda 'byte-prepare 'byte-prepare-lambda-form)
(defun byte-prepare-lambda-form (form)
(error "Lambda used in incorrect place in byte-compiled code"))
;; (defvar/defconst/defun/defmacro ...) =>
;; (eval '(defvar/defconst/defun/defmacro ...))
(put 'defun 'byte-prepare 'byte-prepare-defunmac)
(put 'defun 'byte-compile 'byte-compile-defX)
(put 'defmacro 'byte-prepare 'byte-prepare-defunmac)
(put 'defmacro 'byte-compile 'byte-compile-defX)
(put 'defconst 'byte-prepare 'identity)
(put 'defconst 'byte-compile 'byte-compile-defX)
(put 'defvar 'byte-prepare 'identity)
(put 'defvar 'byte-compile 'byte-compile-defX)
(defun byte-prepare-defunmac (form)
(cons (car form) (byte-compile-lambda (cdr form))))
(defun byte-compile-defX (form)
(byte-compile-form
(` (eval (quote (, form))))))
(defun byte-compile-make-tag ()
(cons nil nil))
(defun byte-compile-out-tag (tag)
(let ((uses (car tag)))
(setcar tag byte-compile-pc)
(while uses
(byte-compile-store-goto (car uses) byte-compile-pc)
(setq uses (cdr uses)))))
(defun byte-compile-goto (opcode tag)
(byte-compile-out opcode 0)
(if (integerp (car tag))
(byte-compile-store-goto byte-compile-pc (car tag))
(setcar tag (cons byte-compile-pc (car tag))))
(setq byte-compile-pc (+ byte-compile-pc 2)))
(defun byte-compile-store-goto (at-pc to-pc)
(setq byte-compile-output
(cons (cons at-pc (logand to-pc 255))
byte-compile-output))
(setq byte-compile-output
(cons (cons (1+ at-pc) (lsh to-pc -8))
byte-compile-output)))
(defun byte-compile-out (opcode offset)
(setq opcode (eval opcode))
(if (< offset 6)
(byte-compile-out-1 (+ opcode offset))
(if (< offset 256)
(progn
(byte-compile-out-1 (+ opcode 6))
(byte-compile-out-1 offset))
(byte-compile-out-1 (+ opcode 7))
(byte-compile-out-1 (logand offset 255))
(byte-compile-out-1 (lsh offset -8)))))
(defun byte-compile-out-const (offset)
(if (< offset byte-constant-limit)
(byte-compile-out-1 (+ byte-constant offset))
(byte-compile-out-1 byte-constant2)
(byte-compile-out-1 (logand offset 255))
(byte-compile-out-1 (lsh offset -8))))
(defun byte-compile-out-1 (code)
(setq byte-compile-output
(cons (cons byte-compile-pc code)
byte-compile-output))
(setq byte-compile-pc (1+ byte-compile-pc)))
;;; 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)
(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 ".el$" (car files))
(not (auto-save-file-name-p (car files)))
(setq source (expand-file-name (car files)
(car command-line-args-left)))
(setq dest (concat (file-name-sans-versions source) "c"))
(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)))
;; A trick to avoid "Lisp nesting exceeds max-lisp-eval-depth"
;; when using the uncompiled bytecomp.el to compile itself:
(progn-expand
(mapcar 'byte-compile '(byte-prepare-form
byte-prepare-normal-call
byte-compile-form
byte-compile-normal-call))
nil)