home *** CD-ROM | disk | FTP | other *** search
/ Fresh Fish 6 / FreshFish_September1994.bin / bbs / gnu / emacs-18.59-src.lha / GNU / src / amiga / emacs-18.59 / lisp / bytecomp.el < prev    next >
Encoding:
Text File  |  1991-10-24  |  40.2 KB  |  1,166 lines
  1. ;; Compilation of Lisp code into byte code.
  2. ;; Copyright (C) 1985, 1986, 1987 Free Software Foundation, Inc.
  3.  
  4. ;; This file is part of GNU Emacs.
  5.  
  6. ;; GNU Emacs is free software; you can redistribute it and/or modify
  7. ;; it under the terms of the GNU General Public License as published by
  8. ;; the Free Software Foundation; either version 1, or (at your option)
  9. ;; any later version.
  10.  
  11. ;; GNU Emacs is distributed in the hope that it will be useful,
  12. ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  13. ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14. ;; GNU General Public License for more details.
  15.  
  16. ;; You should have received a copy of the GNU General Public License
  17. ;; along with GNU Emacs; see the file COPYING.  If not, write to
  18. ;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
  19.  
  20. (provide 'byte-compile)
  21.  
  22. (defvar byte-compile-constnum -1
  23.   "Transfer vector index of last constant allocated.")
  24. (defvar byte-compile-constants nil
  25.   "Alist describing contents to put in transfer vector.
  26. Each element is (CONTENTS . INDEX)")
  27. (defvar byte-compile-macro-environment nil
  28.   "Alist of (MACRONAME . DEFINITION) macros defined in the file
  29. which is being compiled.")
  30. (defvar byte-compile-pc 0
  31.   "Index in byte string to store next opcode at.")
  32. (defvar byte-compile-output nil
  33.   "Alist describing contents to put in byte code string.
  34. Each element is (INDEX . VALUE)")
  35. (defvar byte-compile-depth 0
  36.   "Current depth of execution stack.")
  37. (defvar byte-compile-maxdepth 0
  38.   "Maximum depth of execution stack.")
  39.  
  40. (defconst byte-varref 8
  41.   "Byte code opcode for variable reference.")
  42. (defconst byte-varset 16
  43.   "Byte code opcode for setting a variable.")
  44. (defconst byte-varbind 24
  45.   "Byte code opcode for binding a variable.")
  46. (defconst byte-call 32
  47.   "Byte code opcode for calling a function.")
  48. (defconst byte-unbind 40
  49.   "Byte code opcode for unbinding special bindings.")
  50.  
  51. (defconst byte-constant 192
  52.   "Byte code opcode for reference to a constant.")
  53. (defconst byte-constant-limit 64
  54.   "Maximum index usable in  byte-constant  opcode.")
  55.  
  56. (defconst byte-constant2 129
  57.   "Byte code opcode for reference to a constant with vector index >= 0100.")
  58.  
  59. (defconst byte-goto 130
  60.   "Byte code opcode for unconditional jump")
  61.  
  62. (defconst byte-goto-if-nil 131
  63.   "Byte code opcode for pop value and jump if it's nil.")
  64.  
  65. (defconst byte-goto-if-not-nil 132
  66.   "Byte code opcode for pop value and jump if it's not nil.")
  67.  
  68. (defconst byte-goto-if-nil-else-pop 133
  69.   "Byte code opcode for examine top-of-stack, jump and don't pop it if it's nil,
  70. otherwise pop it.")
  71.  
  72. (defconst byte-goto-if-not-nil-else-pop 134
  73.   "Byte code opcode for examine top-of-stack, jump and don't pop it if it's not nil,
  74. otherwise pop it.")
  75.  
  76. (defconst byte-return 135
  77.   "Byte code opcode for pop value and return it from byte code interpreter.")
  78.  
  79. (defconst byte-discard 136
  80.   "Byte code opcode to discard one value from stack.")
  81.  
  82. (defconst byte-dup 137
  83.   "Byte code opcode to duplicate the top of the stack.")
  84.  
  85. (defconst byte-save-excursion 138
  86.   "Byte code opcode to make a binding to record the buffer, point and mark.")
  87.  
  88. (defconst byte-save-window-excursion 139
  89.   "Byte code opcode to make a binding to record entire window configuration.")
  90.  
  91. (defconst byte-save-restriction 140
  92.   "Byte code opcode to make a binding to record the current buffer clipping restrictions.")
  93.  
  94. (defconst byte-catch 141
  95.   "Byte code opcode for catch.  Takes, on stack, the tag and an expression for the body.")
  96.  
  97. (defconst byte-unwind-protect 142
  98.   "Byte code opcode for unwind-protect.  Takes, on stack, an expression for the body
  99. and an expression for the unwind-action.")
  100.  
  101. (defconst byte-condition-case 143
  102.   "Byte code opcode for condition-case.  Takes, on stack, the variable to bind,
  103. an expression for the body, and a list of clauses.")
  104.  
  105. (defconst byte-temp-output-buffer-setup 144
  106.   "Byte code opcode for entry to with-output-to-temp-buffer.
  107. Takes, on stack, the buffer name.
  108. Binds standard-output and does some other things.
  109. Returns with temp buffer on the stack in place of buffer name.")
  110.  
  111. (defconst byte-temp-output-buffer-show 145
  112.   "Byte code opcode for exit from with-output-to-temp-buffer.
  113. Expects the temp buffer on the stack underneath value to return.
  114. Pops them both, then pushes the value back on.
  115. Unbinds standard-output and makes the temp buffer visible.")
  116.  
  117. (defconst byte-nth 56)
  118. (defconst byte-symbolp 57)
  119. (defconst byte-consp 58)
  120. (defconst byte-stringp 59)
  121. (defconst byte-listp 60)
  122. (defconst byte-eq 61)
  123. (defconst byte-memq 62)
  124. (defconst byte-not 63)
  125. (defconst byte-car 64)
  126. (defconst byte-cdr 65)
  127. (defconst byte-cons 66)
  128. (defconst byte-list1 67)
  129. (defconst byte-list2 68)
  130. (defconst byte-list3 69)
  131. (defconst byte-list4 70)
  132. (defconst byte-length 71)
  133. (defconst byte-aref 72)
  134. (defconst byte-aset 73)
  135. (defconst byte-symbol-value 74)
  136. (defconst byte-symbol-function 75)
  137. (defconst byte-set 76)
  138. (defconst byte-fset 77)
  139. (defconst byte-get 78)
  140. (defconst byte-substring 79)
  141. (defconst byte-concat2 80)
  142. (defconst byte-concat3 81)
  143. (defconst byte-concat4 82)
  144. (defconst byte-sub1 83)
  145. (defconst byte-add1 84)
  146. (defconst byte-eqlsign 85)
  147. (defconst byte-gtr 86)
  148. (defconst byte-lss 87)
  149. (defconst byte-leq 88)
  150. (defconst byte-geq 89)
  151. (defconst byte-diff 90)
  152. (defconst byte-negate 91)
  153. (defconst byte-plus 92)
  154. (defconst byte-max 93)
  155. (defconst byte-min 94)
  156.  
  157. (defconst byte-point 96)
  158. ;(defconst byte-mark 97) no longer generated -- lisp code shouldn't call this very frequently
  159. (defconst byte-goto-char 98)
  160. (defconst byte-insert 99)
  161. (defconst byte-point-max 100)
  162. (defconst byte-point-min 101)
  163. (defconst byte-char-after 102)
  164. (defconst byte-following-char 103)
  165. (defconst byte-preceding-char 104)
  166. (defconst byte-current-column 105)
  167. (defconst byte-indent-to 106)
  168. ;(defconst byte-scan-buffer 107) no longer generated
  169. (defconst byte-eolp 108)
  170. (defconst byte-eobp 109)
  171. (defconst byte-bolp 110)
  172. (defconst byte-bobp 111)
  173. (defconst byte-current-buffer 112)
  174. (defconst byte-set-buffer 113)
  175. (defconst byte-read-char 114)
  176. ;(defconst byte-set-mark 115)       ;obsolete
  177. (defconst byte-interactive-p 116)
  178.  
  179. (defun byte-recompile-directory (directory &optional arg)
  180.   "Recompile every .el file in DIRECTORY that needs recompilation.
  181. This is if a .elc file exists but is older than the .el file.
  182. If the .elc file does not exist, offer to compile the .el file
  183. only if a prefix argument has been specified." 
  184.   (interactive "DByte recompile directory: \nP")
  185.   (save-some-buffers)
  186.   (setq directory (expand-file-name directory))
  187.   (let ((files (directory-files directory nil "\\.el\\'"))
  188.     (count 0)
  189.     source dest)
  190.     (while files
  191.       (if (and (not (auto-save-file-name-p (car files)))
  192.            (setq source (expand-file-name (car files) directory))
  193.            (setq dest (concat (file-name-sans-versions source) "c"))
  194.            (if (file-exists-p dest)
  195.            (file-newer-than-file-p source dest)
  196.            (and arg (y-or-n-p (concat "Compile " source "? ")))))
  197.       (progn (byte-compile-file source)
  198.          (setq count (1+ count))))
  199.       (setq files (cdr files)))
  200.     (message "Done (Total of %d file%s compiled)"
  201.          count (if (= count 1) "" "s"))))
  202.  
  203. (defun byte-compile-file (filename)
  204.   "Compile a file of Lisp code named FILENAME into a file of byte code.
  205. The output file's name is made by appending \"c\" to the end of FILENAME."
  206.   (interactive "fByte compile file: ")
  207.   ;; Expand now so we get the current buffer's defaults
  208.   (setq filename (expand-file-name filename))
  209.   (message "Compiling %s..." filename)
  210.   (let ((inbuffer (get-buffer-create " *Compiler Input*"))
  211.     (outbuffer (get-buffer-create " *Compiler Output*"))
  212.     (byte-compile-macro-environment nil)
  213.     (case-fold-search nil)
  214.     sexp)
  215.     (save-excursion
  216.       (set-buffer inbuffer)
  217.       (erase-buffer)
  218.       (insert-file-contents filename)
  219.       (goto-char 1)
  220.       (set-buffer outbuffer)
  221.       ;; Avoid running hooks; all we really want is the syntax table.
  222.       (let (emacs-lisp-mode-hook)
  223.     (emacs-lisp-mode))
  224.       (erase-buffer)
  225.       (while (save-excursion
  226.            (set-buffer inbuffer)
  227.            (while (progn (skip-chars-forward " \t\n\^l")
  228.                  (looking-at ";"))
  229.          (forward-line 1))
  230.            (not (eobp)))
  231.     (setq sexp (read inbuffer))
  232.     (print (byte-compile-file-form sexp) outbuffer))
  233.       (set-buffer outbuffer)
  234.       (goto-char 1)
  235.       ;; In each defun or autoload, if there is a doc string,
  236.       ;; put a backslash-newline at the front of it.
  237.       (while (search-forward "\n(" nil t)
  238.     (cond ((looking-at "defun \\|autoload ")
  239.            (forward-sexp 3)
  240.            (skip-chars-forward " ")
  241.            (if (looking-at "\"")
  242.            (progn (forward-char 1)
  243.               (insert "\\\n"))))))
  244.       (goto-char 1)
  245.       ;; In each defconst or defvar, if there is a doc string
  246.       ;; and it starts on the same line as the form begins
  247.       ;; (i.e. if there is no newline in a string in the initial value)
  248.       ;; then put in backslash-newline at the start of the doc string.
  249.       (while (search-forward "\n(" nil t)
  250.     (if (looking-at "defvar \\|defconst ")
  251.         (let ((this-line (1- (point))))
  252.           ;;Go to end of initial value expression
  253.           (if (condition-case ()
  254.               (progn (forward-sexp 3) t)
  255.             (error nil))
  256.           (progn
  257.             (skip-chars-forward " ")
  258.             (and (eq this-line
  259.                  (save-excursion (beginning-of-line) (point)))
  260.              (looking-at "\"")
  261.              (progn (forward-char 1)
  262.                 (insert "\\\n"))))))))
  263.       (let ((vms-stmlf-recfm t))
  264.     (write-region 1 (point-max)
  265.               (concat (file-name-sans-versions filename) "c")))
  266.       (kill-buffer (current-buffer))
  267.       (kill-buffer inbuffer)))
  268.   t)
  269.  
  270.  
  271. (defun byte-compile-file-form (form)
  272.   (cond ((not (listp form))
  273.      form)
  274.     ((memq (car form) '(defun defmacro))
  275.      (let* ((name (car (cdr form)))
  276.         (tem (assq name byte-compile-macro-environment)))
  277.        (if (eq (car form) 'defun)
  278.            (progn
  279.          (message "Compiling %s (%s)..." filename (nth 1 form))
  280.          (cond (tem (setcdr tem nil))
  281.                ((and (fboundp name)
  282.                  (eq (car-safe (symbol-function name)) 'macro))
  283.             ;; shadow existing macro definition
  284.             (setq byte-compile-macro-environment
  285.                   (cons (cons name nil)
  286.                     byte-compile-macro-environment))))
  287.          (prog1 (cons 'defun (byte-compile-lambda (cdr form)))
  288.            (if (not noninteractive)
  289.                (message "Compiling %s..." filename))))
  290.          ;; defmacro
  291.          (if tem
  292.          (setcdr tem (cons 'lambda (cdr (cdr form))))
  293.            (setq byte-compile-macro-environment
  294.              (cons (cons name (cons 'lambda (cdr (cdr form))))
  295.                byte-compile-macro-environment)))
  296.          (cons 'defmacro (byte-compile-lambda (cdr form))))))
  297.     ((eq (car form) 'require)
  298.      (eval form)
  299.      form)
  300.     (t form)))
  301.  
  302. (defun byte-compile (funname)
  303.   "Byte-compile the definition of function FUNNAME (a symbol)."
  304.   (if (and (fboundp funname)
  305.        (eq (car-safe (symbol-function funname)) 'lambda))
  306.       (fset funname (byte-compile-lambda (symbol-function funname)))))
  307.  
  308. (defun byte-compile-lambda (fun)
  309.   (let* ((bodyptr (cdr fun))
  310.      (int (assq 'interactive (cdr bodyptr)))
  311.      newbody)
  312.     ;; Skip doc string.
  313.     (if (and (cdr (cdr bodyptr)) (stringp (car (cdr bodyptr))))
  314.     (setq bodyptr (cdr bodyptr)))
  315.     (setq newbody (list (byte-compile-top-level
  316.               (cons 'progn (cdr bodyptr)))))
  317.     (if int
  318.     (setq newbody (cons (if (or (stringp (car (cdr int)))
  319.                     (null (car (cdr int))))
  320.                 int
  321.                   (list 'interactive
  322.                     (byte-compile-top-level (car (cdr int)))))
  323.                 newbody)))
  324.     (if (not (eq bodyptr (cdr fun)))
  325.     (setq newbody (cons (nth 2 fun) newbody)))
  326.     (cons (car fun) (cons (car (cdr fun)) newbody))))
  327.  
  328. (defun byte-compile-top-level (form)
  329.   (let ((byte-compile-constants nil)
  330.     (byte-compile-constnum nil)
  331.     (byte-compile-pc 0)
  332.     (byte-compile-depth 0)
  333.     (byte-compile-maxdepth 0)
  334.     (byte-compile-output nil)
  335.     (byte-compile-string nil)
  336.     (byte-compile-vector nil))
  337.     (let (vars temp (i -1))
  338.       (setq temp (byte-compile-find-vars form))
  339.       (setq form (car temp))
  340.       (setq vars (nreverse (cdr temp)))
  341.       (while vars
  342.     (setq i (1+ i))
  343.     (setq byte-compile-constants (cons (cons (car vars) i)
  344.                        byte-compile-constants))
  345.     (setq vars (cdr vars)))
  346.       (setq byte-compile-constnum i))
  347.     (byte-compile-form form)
  348.     (byte-compile-out 'byte-return 0)
  349.     (setq byte-compile-vector (make-vector (1+ byte-compile-constnum)
  350.                        nil))
  351.     (while byte-compile-constants
  352.       (aset byte-compile-vector (cdr (car byte-compile-constants))
  353.         (car (car byte-compile-constants)))
  354.       (setq byte-compile-constants (cdr byte-compile-constants)))
  355.     (setq byte-compile-string (make-string byte-compile-pc 0))
  356.     (while byte-compile-output
  357.       (aset byte-compile-string (car (car byte-compile-output))
  358.         (cdr (car byte-compile-output)))
  359.       (setq byte-compile-output (cdr byte-compile-output)))
  360.     (list 'byte-code byte-compile-string
  361.              byte-compile-vector byte-compile-maxdepth)))
  362.  
  363. ;; Expand all macros in FORM and find all variables it uses.
  364. ;; Return a pair (EXPANDEDFORM . VARS)
  365. ;; VARS is ordered with the variables encountered earliest
  366. ;; at the end.
  367. ;; The body and cases of a condition-case, and the body of a catch,
  368. ;; are not scanned; variables used in them are not reported,
  369. ;; and they are not macroexpanded.  This is because they will
  370. ;; be compiled separately when encountered during the main
  371. ;; compilation pass.
  372. (defun byte-compile-find-vars (form)
  373.   (let ((all-vars nil))
  374.     (cons (byte-compile-find-vars-1 form)
  375.       all-vars)))
  376.  
  377. ;; Walk FORM, making sure all variables it uses are in ALL-VARS,
  378. ;; and also expanding macros.
  379. ;; Return the result of expanding all macros in FORM.
  380. ;; This is a copy; FORM itself is not altered.
  381. (defun byte-compile-find-vars-1 (form)
  382.   (cond ((symbolp form)
  383.      (if (not (memq form all-vars))
  384.          (setq all-vars (cons form all-vars)))
  385.      form)
  386.     ((or (not (consp form)) (eq (car form) 'quote))
  387.      form)
  388.     ((memq (car form) '(let let*))
  389.      (let* ((binds (copy-sequence (car (cdr form))))
  390.         (body (cdr (cdr form)))
  391.         (tail binds))
  392.        (while tail
  393.          (if (symbolp (car tail))
  394.          (if (not (memq (car tail) all-vars))
  395.              (setq all-vars (cons (car tail) all-vars)))
  396.            (if (consp (car tail))
  397.            (progn
  398.              (if (not (memq (car (car tail)) all-vars))
  399.              (setq all-vars (cons (car (car tail)) all-vars)))
  400.              (setcar tail
  401.                  (list (car (car tail))
  402.                    (byte-compile-find-vars-1 (car (cdr (car tail)))))))))
  403.          (setq tail (cdr tail)))
  404.        (cons (car form)
  405.          (cons binds
  406.                (mapcar 'byte-compile-find-vars-1 body)))))
  407.     ((or (eq (car form) 'function)
  408.          ;; Because condition-case is compiled by breaking out
  409.          ;; all its subexpressions and compiling them separately,
  410.          ;; we regard it here as containing nothing but constants.
  411.          (eq (car form) 'condition-case))
  412.      form)
  413.     ((eq (car form) 'catch)
  414.      ;; catch is almost like condition case, but we
  415.      ;; treat its first argument normally.
  416.      (cons 'catch
  417.            (cons (byte-compile-find-vars-1 (nth 1 form))
  418.              (nthcdr 2 form))))
  419.     ((eq (car form) 'cond)
  420.      (let* ((clauses (copy-sequence (cdr form)))
  421.         (tail clauses))
  422.        (while tail
  423.          (setcar tail (mapcar 'byte-compile-find-vars-1 (car tail)))
  424.          (setq tail (cdr tail)))
  425.        (cons 'cond clauses)))
  426.     ((not (eq form (setq form (macroexpand form byte-compile-macro-environment))))
  427.      (byte-compile-find-vars-1 form))
  428.     ((symbolp (car form))
  429.      (cons (car form) (mapcar 'byte-compile-find-vars-1 (cdr form))))
  430.     (t (mapcar 'byte-compile-find-vars-1 form))))
  431.  
  432. ;; This is the recursive entry point for compiling each subform of an expression.
  433.  
  434. ;; Note that handler functions SHOULD NOT increment byte-compile-depth
  435. ;; for the values they are returning!  That is done on return here.
  436. ;; Handlers should make sure that the depth on exit is the same as
  437. ;; it was when the handler was called.
  438.  
  439. (defun byte-compile-form (form)
  440.   (setq form (macroexpand form byte-compile-macro-environment))
  441.   (cond ((eq form 'nil)
  442.      (byte-compile-constant form))
  443.     ((eq form 't)
  444.      (byte-compile-constant form))
  445.     ((symbolp form)
  446.      (byte-compile-variable-ref 'byte-varref form))
  447.     ((not (consp form))
  448.      (byte-compile-constant form))
  449.     ((not (symbolp (car form)))
  450.      (if (eq (car-safe (car form)) 'lambda)
  451.          (let ((vars (nth 1 (car form)))
  452.            (vals (cdr form))
  453.            result)
  454.            (while vars
  455.          (setq result (cons (list (car vars) (car vals)) result))
  456.          (setq vars (cdr vars) vals (cdr vals)))
  457.            (byte-compile-form
  458.         (cons 'let (cons (nreverse result) (cdr (cdr (car form)))))))
  459.        (byte-compile-normal-call form)))
  460.     (t
  461.      (let ((handler (get (car form) 'byte-compile)))
  462.        (if handler
  463.            (funcall handler form)
  464.          (byte-compile-normal-call form)))))
  465.   (setq byte-compile-maxdepth
  466.     (max byte-compile-maxdepth
  467.          (setq byte-compile-depth (1+ byte-compile-depth)))))
  468.  
  469. (defun byte-compile-normal-call (form)
  470.   (byte-compile-push-constant (car form))
  471.   (let ((copy (cdr form)))
  472.     (while copy (byte-compile-form (car copy)) (setq copy (cdr copy))))
  473.   (byte-compile-out 'byte-call (length (cdr form)))
  474.   (setq byte-compile-depth (- byte-compile-depth (length (cdr form)))))
  475.  
  476. (defun byte-compile-variable-ref (base-op var)
  477.   (let ((data (assq var byte-compile-constants)))
  478.     (if data
  479.     (byte-compile-out base-op (cdr data))
  480.       (error (format "Variable %s seen on pass 2 of byte compiler but not pass 1"
  481.              (prin1-to-string var))))))
  482.  
  483. ;; Use this when the value of a form is a constant,
  484. ;; because byte-compile-depth will be incremented accordingly
  485. ;; on return to byte-compile-form, so it should not be done by the handler.
  486. (defun byte-compile-constant (const)
  487.   (let ((data (if (stringp const)
  488.           (assoc const byte-compile-constants)
  489.         (assq const byte-compile-constants))))
  490.     (if data
  491.     (byte-compile-out-const (cdr data))
  492.       (setq byte-compile-constants
  493.         (cons (cons const (setq byte-compile-constnum (1+ byte-compile-constnum)))
  494.           byte-compile-constants))
  495.       (byte-compile-out-const byte-compile-constnum))))
  496.  
  497. ;; Use this for a constant that is not the value of its containing form.
  498. ;; Note that the calling function must explicitly decrement byte-compile-depth
  499. ;; (or perhaps call byte-compile-discard to do so)
  500. ;; for the word pushed by this function.
  501. (defun byte-compile-push-constant (const)
  502.   (byte-compile-constant const)
  503.   (setq byte-compile-maxdepth
  504.     (max byte-compile-maxdepth
  505.          (setq byte-compile-depth (1+ byte-compile-depth)))))
  506.  
  507. ;; Compile those primitive ordinary functions
  508. ;; which have special byte codes just for speed.
  509.  
  510. (put 'point 'byte-compile 'byte-compile-no-args)
  511. (put 'point 'byte-opcode 'byte-point)
  512.  
  513. (put 'dot 'byte-compile 'byte-compile-no-args)
  514. (put 'dot 'byte-opcode 'byte-point)
  515.  
  516. ;(put 'mark 'byte-compile 'byte-compile-no-args)
  517. ;(put 'mark 'byte-opcode 'byte-mark)
  518.  
  519. (put 'point-max 'byte-compile 'byte-compile-no-args)
  520. (put 'point-max 'byte-opcode 'byte-point-max)
  521.  
  522. (put 'point-min 'byte-compile 'byte-compile-no-args)
  523. (put 'point-min 'byte-opcode 'byte-point-min)
  524.  
  525. (put 'dot-max 'byte-compile 'byte-compile-no-args)
  526. (put 'dot-max 'byte-opcode 'byte-point-max)
  527.  
  528. (put 'dot-min 'byte-compile 'byte-compile-no-args)
  529. (put 'dot-min 'byte-opcode 'byte-point-min)
  530.  
  531. (put 'following-char 'byte-compile 'byte-compile-no-args)
  532. (put 'following-char 'byte-opcode 'byte-following-char)
  533.  
  534. (put 'preceding-char 'byte-compile 'byte-compile-no-args)
  535. (put 'preceding-char 'byte-opcode 'byte-preceding-char)
  536.  
  537. (put 'current-column 'byte-compile 'byte-compile-no-args)
  538. (put 'current-column 'byte-opcode 'byte-current-column)
  539.  
  540. (put 'eolp 'byte-compile 'byte-compile-no-args)
  541. (put 'eolp 'byte-opcode 'byte-eolp)
  542.  
  543. (put 'eobp 'byte-compile 'byte-compile-no-args)
  544. (put 'eobp 'byte-opcode 'byte-eobp)
  545.  
  546. (put 'bolp 'byte-compile 'byte-compile-no-args)
  547. (put 'bolp 'byte-opcode 'byte-bolp)
  548.  
  549. (put 'bobp 'byte-compile 'byte-compile-no-args)
  550. (put 'bobp 'byte-opcode 'byte-bobp)
  551.  
  552. (put 'current-buffer 'byte-compile 'byte-compile-no-args)
  553. (put 'current-buffer 'byte-opcode 'byte-current-buffer)
  554.  
  555. (put 'read-char 'byte-compile 'byte-compile-no-args)
  556. (put 'read-char 'byte-opcode 'byte-read-char)
  557.  
  558.  
  559. (put 'symbolp 'byte-compile 'byte-compile-one-arg)
  560. (put 'symbolp 'byte-opcode 'byte-symbolp)
  561.  
  562. (put 'consp 'byte-compile 'byte-compile-one-arg)
  563. (put 'consp 'byte-opcode 'byte-consp)
  564.  
  565. (put 'stringp 'byte-compile 'byte-compile-one-arg)
  566. (put 'stringp 'byte-opcode 'byte-stringp)
  567.  
  568. (put 'listp 'byte-compile 'byte-compile-one-arg)
  569. (put 'listp 'byte-opcode 'byte-listp)
  570.  
  571. (put 'not 'byte-compile 'byte-compile-one-arg)
  572. (put 'not 'byte-opcode 'byte-not)
  573.  
  574. (put 'null 'byte-compile 'byte-compile-one-arg)
  575. (put 'null 'byte-opcode 'byte-not)
  576.  
  577. (put 'car 'byte-compile 'byte-compile-one-arg)
  578. (put 'car 'byte-opcode 'byte-car)
  579.  
  580. (put 'cdr 'byte-compile 'byte-compile-one-arg)
  581. (put 'cdr 'byte-opcode 'byte-cdr)
  582.  
  583. (put 'length 'byte-compile 'byte-compile-one-arg)
  584. (put 'length 'byte-opcode 'byte-length)
  585.  
  586. (put 'symbol-value 'byte-compile 'byte-compile-one-arg)
  587. (put 'symbol-value 'byte-opcode 'byte-symbol-value)
  588.  
  589. (put 'symbol-function 'byte-compile 'byte-compile-one-arg)
  590. (put 'symbol-function 'byte-opcode 'byte-symbol-function)
  591.  
  592. (put '1+ 'byte-compile 'byte-compile-one-arg)
  593. (put '1+ 'byte-opcode 'byte-add1)
  594.  
  595. (put '1- 'byte-compile 'byte-compile-one-arg)
  596. (put '1- 'byte-opcode 'byte-sub1)
  597.  
  598. (put 'goto-char 'byte-compile 'byte-compile-one-arg)
  599. (put 'goto-char 'byte-opcode 'byte-goto-char)
  600.  
  601. (put 'char-after 'byte-compile 'byte-compile-one-arg)
  602. (put 'char-after 'byte-opcode 'byte-char-after)
  603.  
  604. (put 'set-buffer 'byte-compile 'byte-compile-one-arg)
  605. (put 'set-buffer 'byte-opcode 'byte-set-buffer)
  606.  
  607. ;set-mark turns out to be too unimportant for its own opcode.
  608. ;(put 'set-mark 'byte-compile 'byte-compile-one-arg)
  609. ;(put 'set-mark 'byte-opcode 'byte-set-mark)
  610.  
  611.  
  612. (put 'eq 'byte-compile 'byte-compile-two-args)
  613. (put 'eq 'byte-opcode 'byte-eq)
  614. (put 'eql 'byte-compile 'byte-compile-two-args)
  615. (put 'eql 'byte-opcode 'byte-eq)
  616.  
  617. (put 'memq 'byte-compile 'byte-compile-two-args)
  618. (put 'memq 'byte-opcode 'byte-memq)
  619.  
  620. (put 'cons 'byte-compile 'byte-compile-two-args)
  621. (put 'cons 'byte-opcode 'byte-cons)
  622.  
  623. (put 'aref 'byte-compile 'byte-compile-two-args)
  624. (put 'aref 'byte-opcode 'byte-aref)
  625.  
  626. (put 'set 'byte-compile 'byte-compile-two-args)
  627. (put 'set 'byte-opcode 'byte-set)
  628.  
  629. (put 'fset 'byte-compile 'byte-compile-two-args)
  630. (put 'fset 'byte-opcode 'byte-fset)
  631.  
  632. (put '= 'byte-compile 'byte-compile-two-args)
  633. (put '= 'byte-opcode 'byte-eqlsign)
  634.  
  635. (put '< 'byte-compile 'byte-compile-two-args)
  636. (put '< 'byte-opcode 'byte-lss)
  637.  
  638. (put '> 'byte-compile 'byte-compile-two-args)
  639. (put '> 'byte-opcode 'byte-gtr)
  640.  
  641. (put '<= 'byte-compile 'byte-compile-two-args)
  642. (put '<= 'byte-opcode 'byte-leq)
  643.  
  644. (put '>= 'byte-compile 'byte-compile-two-args)
  645. (put '>= 'byte-opcode 'byte-geq)
  646.  
  647. (put 'get 'byte-compile 'byte-compile-two-args)
  648. (put 'get 'byte-opcode 'byte-get)
  649.  
  650. (put 'nth 'byte-compile 'byte-compile-two-args)
  651. (put 'nth 'byte-opcode 'byte-nth)
  652.  
  653. (put 'aset 'byte-compile 'byte-compile-three-args)
  654. (put 'aset 'byte-opcode 'byte-aset)
  655.  
  656. (defun byte-compile-no-args (form)
  657.   (if (/= (length form) 1)
  658.       ;; get run-time wrong-number-of-args error.
  659.       ;; Would be nice if there were some way to do
  660.       ;;  compile-time warnings.
  661.       (byte-compile-normal-call form)
  662.     (byte-compile-out (symbol-value (get (car form) 'byte-opcode)) 0)))
  663.  
  664. (defun byte-compile-one-arg (form)
  665.   (if (/= (length form) 2)
  666.       (byte-compile-normal-call form)
  667.     (byte-compile-form (car (cdr form)))  ;; Push the argument
  668.     (setq byte-compile-depth (1- byte-compile-depth))
  669.     (byte-compile-out (symbol-value (get (car form) 'byte-opcode)) 0)))
  670.  
  671. (defun byte-compile-two-args (form)
  672.   (if (/= (length form) 3)
  673.       (byte-compile-normal-call form)
  674.     (byte-compile-form (car (cdr form)))  ;; Push the arguments
  675.     (byte-compile-form (nth 2 form))
  676.     (setq byte-compile-depth (- byte-compile-depth 2))
  677.     (byte-compile-out (symbol-value (get (car form) 'byte-opcode)) 0)))
  678.  
  679. (defun byte-compile-three-args (form)
  680.   (if (/= (length form) 4)
  681.       (byte-compile-normal-call form)
  682.     (byte-compile-form (car (cdr form)))  ;; Push the arguments
  683.     (byte-compile-form (nth 2 form))
  684.     (byte-compile-form (nth 3 form))
  685.     (setq byte-compile-depth (- byte-compile-depth 3))
  686.     (byte-compile-out (symbol-value (get (car form) 'byte-opcode)) 0)))
  687.  
  688. (put 'substring 'byte-compile 'byte-compile-substring)
  689. (defun byte-compile-substring (form)
  690.   (if (or (> (length form) 4)
  691.       (< (length form) 2))
  692.       (byte-compile-normal-call form)
  693.     (byte-compile-form (nth 1 form))
  694.     (byte-compile-form (or (nth 2 form) ''nil))    ;Optional arguments
  695.     (byte-compile-form (or (nth 3 form) ''nil))
  696.     (setq byte-compile-depth (- byte-compile-depth 3))
  697.     (byte-compile-out byte-substring 0)))
  698.  
  699. (put 'interactive-p 'byte-compile 'byte-compile-interactive-p)
  700. (defun byte-compile-interactive-p (form)
  701.   (byte-compile-out byte-interactive-p 0))
  702.   
  703. (put 'list 'byte-compile 'byte-compile-list)
  704. (defun byte-compile-list (form)
  705.   (let ((len (length form)))
  706.     (if (= len 1)
  707.     (byte-compile-constant nil)
  708.       (if (< len 6)
  709.       (let ((args (cdr form)))
  710.        (while args
  711.          (byte-compile-form (car args))
  712.          (setq args (cdr args)))
  713.        (setq byte-compile-depth (- byte-compile-depth (1- len)))
  714.        (byte-compile-out (symbol-value
  715.                   (nth (- len 2)
  716.                    '(byte-list1 byte-list2 byte-list3 byte-list4)))
  717.                  0))
  718.     (byte-compile-normal-call form)))))
  719.  
  720. (put 'concat 'byte-compile 'byte-compile-concat)
  721. (defun byte-compile-concat (form)
  722.   (let ((len (length form)))
  723.     (cond ((= len 1)
  724.        (byte-compile-form ""))
  725.       ((= len 2)
  726.        ;; Concat of one arg is not a no-op if arg is not a string.
  727.        (byte-compile-normal-call form))
  728.       ((< len 6)
  729.        (let ((args (cdr form)))
  730.          (while args
  731.            (byte-compile-form (car args))
  732.            (setq args (cdr args)))
  733.          (setq byte-compile-depth (- byte-compile-depth (1- len)))
  734.          (byte-compile-out
  735.            (symbol-value (nth (- len 3)
  736.                   '(byte-concat2 byte-concat3 byte-concat4)))
  737.            0)))
  738.       (t
  739.        (byte-compile-normal-call form)))))
  740.  
  741. (put '- 'byte-compile 'byte-compile-minus)
  742. (defun byte-compile-minus (form)
  743.   (let ((len (length form)))
  744.     (cond ((= len 2)
  745.        (byte-compile-form (car (cdr form)))
  746.        (setq byte-compile-depth (- byte-compile-depth 1))
  747.        (byte-compile-out byte-negate 0))
  748.       ((= len 3)
  749.        (byte-compile-form (car (cdr form)))
  750.        (byte-compile-form (nth 2 form))
  751.        (setq byte-compile-depth (- byte-compile-depth 2))
  752.        (byte-compile-out byte-diff 0))
  753.       (t (byte-compile-normal-call form)))))
  754.  
  755. (put '+ 'byte-compile 'byte-compile-maybe-two-args)
  756. (put '+ 'byte-opcode 'byte-plus)
  757.  
  758. (put 'max 'byte-compile 'byte-compile-maybe-two-args)
  759. (put 'max 'byte-opcode 'byte-max)
  760.  
  761. (put 'min 'byte-compile 'byte-compile-maybe-two-args)
  762. (put 'min 'byte-opcode 'byte-min)
  763.  
  764. (defun byte-compile-maybe-two-args (form)
  765.   (let ((len (length form)))
  766.     (if (= len 3)
  767.     (progn
  768.       (byte-compile-form (car (cdr form)))
  769.       (byte-compile-form (nth 2 form))
  770.       (setq byte-compile-depth (- byte-compile-depth 2))
  771.       (byte-compile-out (symbol-value (get (car form) 'byte-opcode)) 0))
  772.       (byte-compile-normal-call form))))
  773.     
  774. (put 'function 'byte-compile 'byte-compile-function-form)
  775. (defun byte-compile-function-form (form)
  776.   (cond ((symbolp (car (cdr form)))
  777.      (byte-compile-form
  778.       (list 'symbol-function (list 'quote (nth 1 form)))))
  779.     (t
  780.      (byte-compile-constant (byte-compile-lambda (car (cdr form)))))))
  781.  
  782. (put 'indent-to 'byte-compile 'byte-compile-indent-to)
  783. (defun byte-compile-indent-to (form)
  784.   (let ((len (length form)))
  785.     (if (= len 2)
  786.     (progn
  787.       (byte-compile-form (car (cdr form)))
  788.       (setq byte-compile-depth (- byte-compile-depth 1))
  789.       (byte-compile-out byte-indent-to 0))
  790.       (byte-compile-normal-call form))))
  791.  
  792. (put 'insert 'byte-compile 'byte-compile-insert)
  793. (defun byte-compile-insert (form)
  794.   (let ((len (length form)))
  795.     (if (< len 3)
  796.     (let ((args (cdr form)))
  797.       (while args
  798.         (byte-compile-form (car args))
  799.         (setq byte-compile-depth (- byte-compile-depth 1))
  800.         (byte-compile-out byte-insert 0)
  801.         (setq args (cdr args))))
  802.       (byte-compile-normal-call form))))
  803.  
  804. (put 'setq-default 'byte-compile 'byte-compile-setq-default)
  805. (defun byte-compile-setq-default (form)
  806.   (byte-compile-form (cons 'set-default (cons (list 'quote (nth 1 form))
  807.                           (nthcdr 2 form)))))
  808.  
  809. (put 'quote 'byte-compile 'byte-compile-quote)
  810. (defun byte-compile-quote (form)
  811.   (byte-compile-constant (car (cdr form))))
  812.  
  813. (put 'setq 'byte-compile 'byte-compile-setq)
  814. (defun byte-compile-setq (form)
  815.   (let ((args (cdr form)))
  816.     (if args
  817.     (while args
  818.       (byte-compile-form (car (cdr args)))
  819.       (if (null (cdr (cdr args)))
  820.           (progn
  821.         (byte-compile-out 'byte-dup 0)
  822.         (setq byte-compile-maxdepth (max byte-compile-maxdepth (1+ byte-compile-depth)))))
  823.       (setq byte-compile-depth (1- byte-compile-depth))
  824.       (byte-compile-variable-ref 'byte-varset (car args))
  825.       (setq args (cdr (cdr args))))
  826.       ;; (setq), with no arguments.
  827.       (byte-compile-constant nil))))
  828.  
  829. (put 'let 'byte-compile 'byte-compile-let)
  830. (defun byte-compile-let (form)
  831.   (let ((varlist (car (cdr form))))
  832.     (while varlist
  833.       (if (symbolp (car varlist))
  834.       (byte-compile-push-constant nil)
  835.     (byte-compile-form (car (cdr (car varlist)))))
  836.       (setq varlist (cdr varlist))))
  837.   (let ((varlist (reverse (car (cdr form)))))
  838.     (setq byte-compile-depth (- byte-compile-depth (length varlist)))
  839.     (while varlist
  840.       (if (symbolp (car varlist))
  841.       (byte-compile-variable-ref 'byte-varbind (car varlist))
  842.     (byte-compile-variable-ref 'byte-varbind (car (car varlist))))
  843.       (setq varlist (cdr varlist))))
  844.   (byte-compile-body (cdr (cdr form)))
  845.   (byte-compile-out 'byte-unbind (length (car (cdr form)))))
  846.  
  847. (put 'let* 'byte-compile 'byte-compile-let*)
  848. (defun byte-compile-let* (form)
  849.   (let ((varlist (car (cdr form))))
  850.     (while varlist
  851.       (if (symbolp (car varlist))
  852.       (byte-compile-push-constant nil)
  853.     (byte-compile-form (car (cdr (car varlist)))))
  854.       (setq byte-compile-depth (1- byte-compile-depth))
  855.       (if (symbolp (car varlist))
  856.       (byte-compile-variable-ref 'byte-varbind (car varlist))
  857.     (byte-compile-variable-ref 'byte-varbind (car (car varlist))))
  858.       (setq varlist (cdr varlist))))
  859.   (byte-compile-body (cdr (cdr form)))
  860.   (byte-compile-out 'byte-unbind (length (car (cdr form)))))
  861.  
  862. (put 'save-excursion 'byte-compile 'byte-compile-save-excursion)
  863. (defun byte-compile-save-excursion (form)
  864.   (byte-compile-out 'byte-save-excursion 0)
  865.   (byte-compile-body (cdr form))
  866.   (byte-compile-out 'byte-unbind 1))
  867.  
  868. (put 'save-restriction 'byte-compile 'byte-compile-save-restriction)
  869. (defun byte-compile-save-restriction (form)
  870.   (byte-compile-out 'byte-save-restriction 0)
  871.   (byte-compile-body (cdr form))
  872.   (byte-compile-out 'byte-unbind 1))
  873.  
  874. (put 'with-output-to-temp-buffer 'byte-compile 'byte-compile-with-output-to-temp-buffer)
  875. (defun byte-compile-with-output-to-temp-buffer (form)
  876.   (byte-compile-form (car (cdr form)))
  877.   (byte-compile-out 'byte-temp-output-buffer-setup 0)
  878.   (byte-compile-body (cdr (cdr form)))
  879.   (byte-compile-out 'byte-temp-output-buffer-show 0)
  880.   (setq byte-compile-depth (1- byte-compile-depth)))
  881.  
  882. (put 'progn 'byte-compile 'byte-compile-progn)
  883. (defun byte-compile-progn (form)
  884.   (byte-compile-body (cdr form)))
  885.  
  886. (put 'interactive 'byte-compile 'byte-compile-noop)
  887. (defun byte-compile-noop (form)
  888.   (byte-compile-constant nil))
  889.  
  890. (defun byte-compile-body (body)
  891.   (if (null body)
  892.       (byte-compile-constant nil)
  893.     (while body
  894.       (byte-compile-form (car body))
  895.       (if (cdr body)
  896.       (byte-compile-discard)
  897.     ;; Convention is this will be counted after we return.
  898.     (setq byte-compile-depth (1- byte-compile-depth)))
  899.       (setq body (cdr body)))))
  900.  
  901. (put 'prog1 'byte-compile 'byte-compile-prog1)
  902. (defun byte-compile-prog1 (form)
  903.   (byte-compile-form (car (cdr form)))
  904.   (if (cdr (cdr form))
  905.       (progn
  906.     (byte-compile-body (cdr (cdr form)))
  907.     ;; This discards the value pushed by ..-body
  908.     ;; (which is not counted now in byte-compile-depth)
  909.     ;; and decrements byte-compile-depth for the value
  910.     ;; pushed by byte-compile-form above, which by convention
  911.     ;; will be counted in byte-compile-depth after we return.
  912.     (byte-compile-discard))))
  913.  
  914. (put 'prog2 'byte-compile 'byte-compile-prog2)
  915. (defun byte-compile-prog2 (form)
  916.   (byte-compile-form (car (cdr form)))
  917.   (byte-compile-discard)
  918.   (byte-compile-form (nth 2 form))
  919.   (if (cdr (cdr (cdr form)))
  920.       (progn
  921.     (byte-compile-body (cdr (cdr (cdr form))))
  922.     (byte-compile-discard))))
  923.  
  924. (defun byte-compile-discard ()
  925.   (byte-compile-out 'byte-discard 0)
  926.   (setq byte-compile-depth (1- byte-compile-depth)))
  927.  
  928. (put 'if 'byte-compile 'byte-compile-if)
  929. (defun byte-compile-if (form)
  930.   (if (null (nthcdr 3 form))
  931.       ;; No else-forms
  932.       (let ((donetag (byte-compile-make-tag)))
  933.     (byte-compile-form (car (cdr form)))
  934.     (byte-compile-goto 'byte-goto-if-nil-else-pop donetag)
  935.     (setq byte-compile-depth (1- byte-compile-depth))
  936.     (byte-compile-form (nth 2 form))
  937.     (setq byte-compile-depth (1- byte-compile-depth))
  938.     (byte-compile-out-tag donetag))
  939.     (let ((donetag (byte-compile-make-tag)) (elsetag (byte-compile-make-tag)))
  940.       (byte-compile-form (car (cdr form)))
  941.       (byte-compile-goto 'byte-goto-if-nil elsetag)
  942.       (setq byte-compile-depth (1- byte-compile-depth))
  943.       (byte-compile-form (nth 2 form))
  944.       (setq byte-compile-depth (1- byte-compile-depth))
  945.       (byte-compile-goto 'byte-goto donetag)
  946.       (byte-compile-out-tag elsetag)
  947.       (byte-compile-body (cdr (cdr (cdr form))))
  948.       (byte-compile-out-tag donetag))))
  949.  
  950. (put 'cond 'byte-compile 'byte-compile-cond)
  951. (defun byte-compile-cond (form)
  952.   (if (cdr form)
  953.       (byte-compile-cond-1 (cdr form))
  954.     (byte-compile-constant nil)))
  955.  
  956. (defun byte-compile-cond-1 (clauses)
  957.   (if (or (eq (car (car clauses)) t)
  958.       (and (eq (car-safe (car (car clauses))) 'quote)
  959.            (car-safe (cdr-safe (car (car clauses))))))
  960.       ;; Unconditional clause
  961.       (if (cdr (car clauses))
  962.       (byte-compile-body (cdr (car clauses)))
  963.     (byte-compile-form (car (car clauses))))
  964.     (if (null (cdr clauses))
  965.     ;; Only one clause
  966.     (let ((donetag (byte-compile-make-tag)))
  967.       (byte-compile-form (car (car clauses)))
  968.       (cond ((cdr (car clauses))
  969.          (byte-compile-goto 'byte-goto-if-nil-else-pop donetag)
  970.          (setq byte-compile-depth (1- byte-compile-depth))
  971.          (byte-compile-body (cdr (car clauses)))
  972.          (byte-compile-out-tag donetag))))
  973.       (let ((donetag (byte-compile-make-tag))
  974.         (elsetag (byte-compile-make-tag)))
  975.     (byte-compile-form (car (car clauses)))
  976.     (if (null (cdr (car clauses)))
  977.         ;; First clause is a singleton.
  978.         (progn
  979.           (byte-compile-goto 'byte-goto-if-not-nil-else-pop donetag)
  980.           (setq byte-compile-depth (1- byte-compile-depth)))
  981.       (byte-compile-goto 'byte-goto-if-nil elsetag)
  982.       (setq byte-compile-depth (1- byte-compile-depth))
  983.       (byte-compile-body (cdr (car clauses)))
  984.       (byte-compile-goto 'byte-goto donetag)
  985.       (byte-compile-out-tag elsetag))
  986.     (byte-compile-cond-1 (cdr clauses))
  987.     (byte-compile-out-tag donetag)))))
  988.  
  989. (put 'and 'byte-compile 'byte-compile-and)
  990. (defun byte-compile-and (form)
  991.   (let ((failtag (byte-compile-make-tag))
  992.     (args (cdr form)))
  993.     (if (null args)
  994.     (progn
  995.       (byte-compile-form t)
  996.       (setq byte-compile-depth (1- byte-compile-depth)))
  997.       (while args
  998.     (byte-compile-form (car args))
  999.     (setq byte-compile-depth (1- byte-compile-depth))
  1000.     (if (null (cdr args))
  1001.         (byte-compile-out-tag failtag)
  1002.       (byte-compile-goto 'byte-goto-if-nil-else-pop failtag))
  1003.     (setq args (cdr args))))))
  1004.  
  1005. (put 'or 'byte-compile 'byte-compile-or)
  1006. (defun byte-compile-or (form)
  1007.   (let ((wintag (byte-compile-make-tag))
  1008.     (args (cdr form)))
  1009.     (if (null args)
  1010.     (byte-compile-constant nil)
  1011.       (while args
  1012.     (byte-compile-form (car args))
  1013.     (setq byte-compile-depth (1- byte-compile-depth))
  1014.     (if (null (cdr args))
  1015.         (byte-compile-out-tag wintag)
  1016.       (byte-compile-goto 'byte-goto-if-not-nil-else-pop wintag))
  1017.     (setq args (cdr args))))))
  1018.  
  1019. (put 'while 'byte-compile 'byte-compile-while)
  1020. (defun byte-compile-while (form)
  1021.   (let ((endtag (byte-compile-make-tag))
  1022.     (looptag (byte-compile-make-tag))
  1023.     (args (cdr (cdr form))))
  1024.     (byte-compile-out-tag looptag)
  1025.     (byte-compile-form (car (cdr form)))
  1026.     (byte-compile-goto 'byte-goto-if-nil-else-pop endtag)
  1027.     (byte-compile-body (cdr (cdr form)))
  1028.     (byte-compile-discard)
  1029.     (byte-compile-goto 'byte-goto looptag)
  1030.     (byte-compile-out-tag endtag)))
  1031.  
  1032. (put 'catch 'byte-compile 'byte-compile-catch)
  1033. (defun byte-compile-catch (form)
  1034.   (byte-compile-form (car (cdr form)))
  1035.   (byte-compile-push-constant (byte-compile-top-level (cons 'progn (cdr (cdr form)))))
  1036.   (setq byte-compile-depth (- byte-compile-depth 2))
  1037.   (byte-compile-out 'byte-catch 0))
  1038.  
  1039. (put 'save-window-excursion 'byte-compile 'byte-compile-save-window-excursion)
  1040. (defun byte-compile-save-window-excursion (form)
  1041.   (byte-compile-push-constant
  1042.     (list (byte-compile-top-level (cons 'progn (cdr form)))))
  1043.   (setq byte-compile-depth (1- byte-compile-depth))
  1044.   (byte-compile-out 'byte-save-window-excursion 0))
  1045.  
  1046. (put 'unwind-protect 'byte-compile 'byte-compile-unwind-protect)
  1047. (defun byte-compile-unwind-protect (form)
  1048.   (byte-compile-push-constant
  1049.     (list (byte-compile-top-level (cons 'progn (cdr (cdr form))))))
  1050.   (setq byte-compile-depth (1- byte-compile-depth))
  1051.   (byte-compile-out 'byte-unwind-protect 0)
  1052.   (byte-compile-form (car (cdr form)))
  1053.   (setq byte-compile-depth (1- byte-compile-depth))
  1054.   (byte-compile-out 'byte-unbind 1))
  1055.  
  1056. (put 'condition-case 'byte-compile 'byte-compile-condition-case)
  1057. (defun byte-compile-condition-case (form)
  1058.   (byte-compile-push-constant (car (cdr form)))
  1059.   (byte-compile-push-constant (byte-compile-top-level (nth 2 form)))
  1060.   (let ((clauses (cdr (cdr (cdr form))))
  1061.     compiled-clauses)
  1062.     (while clauses
  1063.       (let ((clause (car clauses)))
  1064.     (setq compiled-clauses
  1065.           (cons (list (car clause)
  1066.               (byte-compile-top-level (cons 'progn (cdr clause))))
  1067.             compiled-clauses)))
  1068.       (setq clauses (cdr clauses)))
  1069.     (byte-compile-push-constant (nreverse compiled-clauses)))
  1070.   (setq byte-compile-depth (- byte-compile-depth 3))
  1071.   (byte-compile-out 'byte-condition-case 0))
  1072.  
  1073. (defun byte-compile-make-tag ()
  1074.   (cons nil nil))
  1075.  
  1076. (defun byte-compile-out-tag (tag)
  1077.   (let ((uses (car tag)))
  1078.     (setcar tag byte-compile-pc)
  1079.     (while uses
  1080.       (byte-compile-store-goto (car uses) byte-compile-pc)
  1081.       (setq uses (cdr uses)))))
  1082.  
  1083. (defun byte-compile-goto (opcode tag)
  1084.   (byte-compile-out opcode 0)
  1085.   (if (integerp (car tag))
  1086.       (byte-compile-store-goto byte-compile-pc (car tag))
  1087.     (setcar tag (cons byte-compile-pc (car tag))))
  1088.   (setq byte-compile-pc (+ byte-compile-pc 2)))
  1089.  
  1090. (defun byte-compile-store-goto (at-pc to-pc)
  1091.   (setq byte-compile-output
  1092.     (cons (cons at-pc (logand to-pc 255))
  1093.           byte-compile-output))
  1094.   (setq byte-compile-output
  1095.     (cons (cons (1+ at-pc) (lsh to-pc -8))
  1096.           byte-compile-output)))
  1097.  
  1098. (defun byte-compile-out (opcode offset)
  1099.   (setq opcode (eval opcode))
  1100.   (if (< offset 6)
  1101.       (byte-compile-out-1 (+ opcode offset))
  1102.     (if (< offset 256)
  1103.     (progn
  1104.       (byte-compile-out-1 (+ opcode 6))
  1105.       (byte-compile-out-1 offset))
  1106.       (byte-compile-out-1 (+ opcode 7))
  1107.       (byte-compile-out-1 (logand offset 255))
  1108.       (byte-compile-out-1 (lsh offset -8)))))
  1109.  
  1110. (defun byte-compile-out-const (offset)
  1111.   (if (< offset byte-constant-limit)
  1112.       (byte-compile-out-1 (+ byte-constant offset))
  1113.     (byte-compile-out-1 byte-constant2)
  1114.     (byte-compile-out-1 (logand offset 255))
  1115.     (byte-compile-out-1 (lsh offset -8))))
  1116.  
  1117. (defun byte-compile-out-1 (code)
  1118.   (setq byte-compile-output
  1119.     (cons (cons byte-compile-pc code)
  1120.           byte-compile-output))
  1121.   (setq byte-compile-pc (1+ byte-compile-pc)))
  1122.  
  1123. ;;; by crl@newton.purdue.edu
  1124. ;;;  Only works noninteractively.
  1125. (defun batch-byte-compile ()
  1126.   "Runs byte-compile-file on the files remaining on the command line.
  1127. Must be used only with -batch, and kills emacs on completion.
  1128. Each file will be processed even if an error occurred previously.
  1129. For example, invoke \"emacs -batch -f batch-byte-compile $emacs/ ~/*.el\""
  1130.   ;; command-line-args-left is what is left of the command line (from startup.el)
  1131.   (if (not noninteractive)
  1132.       (error "batch-byte-compile is to be used only with -batch"))
  1133.   (let ((error nil))
  1134.     (while command-line-args-left
  1135.       (if (file-directory-p (expand-file-name (car command-line-args-left)))
  1136.       (let ((files (directory-files (car command-line-args-left)))
  1137.         source dest)
  1138.         (while files
  1139.           (if (and (string-match ".el$" (car files))
  1140.                (not (auto-save-file-name-p (car files)))
  1141.                (setq source (expand-file-name (car files)
  1142.                               (car command-line-args-left)))
  1143.                (setq dest (concat (file-name-sans-versions source) "c"))
  1144.                (file-exists-p dest)
  1145.                (file-newer-than-file-p source dest))
  1146.           (if (null (batch-byte-compile-file source))
  1147.               (setq error t)))
  1148.           (setq files (cdr files))))
  1149.     (if (null (batch-byte-compile-file (car command-line-args-left)))
  1150.         (setq error t)))
  1151.       (setq command-line-args-left (cdr command-line-args-left)))
  1152.     (message "Done")
  1153.     (kill-emacs (if error 1 0))))
  1154.  
  1155. (defun batch-byte-compile-file (file)
  1156.   (condition-case err
  1157.       (progn (byte-compile-file file) t)
  1158.     (error
  1159.      (message (if (cdr err)
  1160.           ">>Error occurred processing %s: %s (%s)"
  1161.           ">>Error occurred processing %s: %s")
  1162.           file
  1163.           (get (car err) 'error-message)
  1164.           (prin1-to-string (cdr err)))
  1165.      nil)))
  1166.