home *** CD-ROM | disk | FTP | other *** search
/ InfoMagic Source Code 1993 July / THE_SOURCE_CODE_CD_ROM.iso / msdos / demacs / lisp / bytecomp.el < prev    next >
Encoding:
Text File  |  1991-11-11  |  40.1 KB  |  1,162 lines
  1. ;;; 87.7.20  modified by M.Sato <masahiko@nttlab.NTT.junet>
  2. ;;; 88.1.18  Nemacs Ver.2.0
  3. ;;; 91/10/22 modified for Demacs 1.1 by Manabu Higashida
  4.  
  5. ;; Compilation of Lisp code into byte code.
  6. ;; Copyright (C) 1985, 1986, 1987 Free Software Foundation, Inc.
  7.  
  8. ;; This file is part of GNU Emacs.
  9.  
  10. ;; GNU Emacs is distributed in the hope that it will be useful,
  11. ;; but WITHOUT ANY WARRANTY.  No author or distributor
  12. ;; accepts responsibility to anyone for the consequences of using it
  13. ;; or for whether it serves any particular purpose or works at all,
  14. ;; unless he says so in writing.  Refer to the GNU Emacs General Public
  15. ;; License for full details.
  16.  
  17. ;; Everyone is granted permission to copy, modify and redistribute
  18. ;; GNU Emacs, but only under the conditions described in the
  19. ;; GNU Emacs General Public License.   A copy of this license is
  20. ;; supposed to have been given to you along with GNU Emacs so you
  21. ;; can know your rights and responsibilities.  It should be in a
  22. ;; file named COPYING.  Among other things, the copyright notice
  23. ;; and this notice must be preserved on all copies.
  24.  
  25. (provide 'byte-compile)
  26.  
  27. (defvar byte-compile-constnum -1
  28.   "Transfer vector index of last constant allocated.")
  29. (defvar byte-compile-constants nil
  30.   "Alist describing contents to put in transfer vector.
  31. Each element is (CONTENTS . INDEX)")
  32. (defvar byte-compile-macro-environment nil
  33.   "Alist of (MACRONAME . DEFINITION) macros defined in the file
  34. which is being compiled.")
  35. (defvar byte-compile-pc 0
  36.   "Index in byte string to store next opcode at.")
  37. (defvar byte-compile-output nil
  38.   "Alist describing contents to put in byte code string.
  39. Each element is (INDEX . VALUE)")
  40. (defvar byte-compile-depth 0
  41.   "Current depth of execution stack.")
  42. (defvar byte-compile-maxdepth 0
  43.   "Maximum depth of execution stack.")
  44.  
  45. (defconst byte-varref 8
  46.   "Byte code opcode for variable reference.")
  47. (defconst byte-varset 16
  48.   "Byte code opcode for setting a variable.")
  49. (defconst byte-varbind 24
  50.   "Byte code opcode for binding a variable.")
  51. (defconst byte-call 32
  52.   "Byte code opcode for calling a function.")
  53. (defconst byte-unbind 40
  54.   "Byte code opcode for unbinding special bindings.")
  55.  
  56. (defconst byte-constant 192
  57.   "Byte code opcode for reference to a constant.")
  58. (defconst byte-constant-limit 64
  59.   "Maximum index usable in  byte-constant  opcode.")
  60.  
  61. (defconst byte-constant2 129
  62.   "Byte code opcode for reference to a constant with vector index >= 0100.")
  63.  
  64. (defconst byte-goto 130
  65.   "Byte code opcode for unconditional jump")
  66.  
  67. (defconst byte-goto-if-nil 131
  68.   "Byte code opcode for pop value and jump if it's nil.")
  69.  
  70. (defconst byte-goto-if-not-nil 132
  71.   "Byte code opcode for pop value and jump if it's not nil.")
  72.  
  73. (defconst byte-goto-if-nil-else-pop 133
  74.   "Byte code opcode for examine top-of-stack, jump and don't pop it if it's nil,
  75. otherwise pop it.")
  76.  
  77. (defconst byte-goto-if-not-nil-else-pop 134
  78.   "Byte code opcode for examine top-of-stack, jump and don't pop it if it's not nil,
  79. otherwise pop it.")
  80.  
  81. (defconst byte-return 135
  82.   "Byte code opcode for pop value and return it from byte code interpreter.")
  83.  
  84. (defconst byte-discard 136
  85.   "Byte code opcode to discard one value from stack.")
  86.  
  87. (defconst byte-dup 137
  88.   "Byte code opcode to duplicate the top of the stack.")
  89.  
  90. (defconst byte-save-excursion 138
  91.   "Byte code opcode to make a binding to record the buffer, point and mark.")
  92.  
  93. (defconst byte-save-window-excursion 139
  94.   "Byte code opcode to make a binding to record entire window configuration.")
  95.  
  96. (defconst byte-save-restriction 140
  97.   "Byte code opcode to make a binding to record the current buffer clipping restrictions.")
  98.  
  99. (defconst byte-catch 141
  100.   "Byte code opcode for catch.  Takes, on stack, the tag and an expression for the body.")
  101.  
  102. (defconst byte-unwind-protect 142
  103.   "Byte code opcode for unwind-protect.  Takes, on stack, an expression for the body
  104. and an expression for the unwind-action.")
  105.  
  106. (defconst byte-condition-case 143
  107.   "Byte code opcode for condition-case.  Takes, on stack, the variable to bind,
  108. an expression for the body, and a list of clauses.")
  109.  
  110. (defconst byte-temp-output-buffer-setup 144
  111.   "Byte code opcode for entry to with-output-to-temp-buffer.
  112. Takes, on stack, the buffer name.
  113. Binds standard-output and does some other things.
  114. Returns with temp buffer on the stack in place of buffer name.")
  115.  
  116. (defconst byte-temp-output-buffer-show 145
  117.   "Byte code opcode for exit from with-output-to-temp-buffer.
  118. Expects the temp buffer on the stack underneath value to return.
  119. Pops them both, then pushes the value back on.
  120. Unbinds standard-output and makes the temp buffer visible.")
  121.  
  122. (defconst byte-nth 56)
  123. (defconst byte-symbolp 57)
  124. (defconst byte-consp 58)
  125. (defconst byte-stringp 59)
  126. (defconst byte-listp 60)
  127. (defconst byte-eq 61)
  128. (defconst byte-memq 62)
  129. (defconst byte-not 63)
  130. (defconst byte-car 64)
  131. (defconst byte-cdr 65)
  132. (defconst byte-cons 66)
  133. (defconst byte-list1 67)
  134. (defconst byte-list2 68)
  135. (defconst byte-list3 69)
  136. (defconst byte-list4 70)
  137. (defconst byte-length 71)
  138. (defconst byte-aref 72)
  139. (defconst byte-aset 73)
  140. (defconst byte-symbol-value 74)
  141. (defconst byte-symbol-function 75)
  142. (defconst byte-set 76)
  143. (defconst byte-fset 77)
  144. (defconst byte-get 78)
  145. (defconst byte-substring 79)
  146. (defconst byte-concat2 80)
  147. (defconst byte-concat3 81)
  148. (defconst byte-concat4 82)
  149. (defconst byte-sub1 83)
  150. (defconst byte-add1 84)
  151. (defconst byte-eqlsign 85)
  152. (defconst byte-gtr 86)
  153. (defconst byte-lss 87)
  154. (defconst byte-leq 88)
  155. (defconst byte-geq 89)
  156. (defconst byte-diff 90)
  157. (defconst byte-negate 91)
  158. (defconst byte-plus 92)
  159. (defconst byte-max 93)
  160. (defconst byte-min 94)
  161.  
  162. (defconst byte-point 96)
  163. ;(defconst byte-mark 97) no longer generated -- lisp code shouldn't call this very frequently
  164. (defconst byte-goto-char 98)
  165. (defconst byte-insert 99)
  166. (defconst byte-point-max 100)
  167. (defconst byte-point-min 101)
  168. (defconst byte-char-after 102)
  169. (defconst byte-following-char 103)
  170. (defconst byte-preceding-char 104)
  171. (defconst byte-current-column 105)
  172. (defconst byte-indent-to 106)
  173. ;(defconst byte-scan-buffer 107) no longer generated
  174. (defconst byte-eolp 108)
  175. (defconst byte-eobp 109)
  176. (defconst byte-bolp 110)
  177. (defconst byte-bobp 111)
  178. (defconst byte-current-buffer 112)
  179. (defconst byte-set-buffer 113)
  180. (defconst byte-read-char 114)
  181. ;(defconst byte-set-mark 115)       ;obsolete
  182. (defconst byte-interactive-p 116)
  183.  
  184. (defun byte-recompile-directory (directory &optional arg)
  185.   "Recompile every .el file in DIRECTORY that needs recompilation.
  186. This is if a .elc file exists but is older than the .el file.
  187. If the .elc file does not exist, offer to compile the .el file
  188. only if a prefix argument has been specified." 
  189.   (interactive "DByte recompile directory: \nP")
  190.   (save-some-buffers)
  191.   (setq directory (expand-file-name directory))
  192.   (let ((files (directory-files directory nil "\\.el\\'"))
  193.     (count 0)
  194.     source dest)
  195.     (while files
  196.       (if (and (not (auto-save-file-name-p (car files)))
  197.            (setq source (expand-file-name (car files) directory))
  198.            (setq dest (concat (file-name-sans-versions source) "c"))
  199.            (if (file-exists-p dest)
  200.            (file-newer-than-file-p source dest)
  201.            (and arg (y-or-n-p (concat "Compile " source "? ")))))
  202.       (progn (byte-compile-file source)
  203.          (setq count (1+ count))))
  204.       (setq files (cdr files)))
  205.     (message "Done (Total of %d file%s compiled)"
  206.          count (if (= count 1) "" "s"))))
  207.  
  208. (defun byte-compile-file (filename)
  209.   "Compile a file of Lisp code named FILENAME into a file of byte code.
  210. The output file's name is made by appending \"c\" to the end of FILENAME."
  211.   (interactive "fByte compile file: ")
  212.   ;; Expand now so we get the current buffer's defaults
  213.   (setq filename (expand-file-name filename))
  214.   (message "Compiling %s..." filename)
  215.   (let ((inbuffer (get-buffer-create " *Compiler Input*"))
  216.     (outbuffer (get-buffer-create " *Compiler Output*"))
  217.     (byte-compile-macro-environment nil)
  218.     (case-fold-search nil)
  219.     sexp)
  220.     (save-excursion
  221.       (set-buffer inbuffer)
  222.       (erase-buffer)
  223.       (insert-file-contents filename)
  224.       (goto-char 1)
  225.       (set-buffer outbuffer)
  226.       (emacs-lisp-mode)
  227.       (erase-buffer)
  228.       (while (save-excursion
  229.            (set-buffer inbuffer)
  230.            (while (progn (skip-chars-forward " \t\n\^l")
  231.                  (looking-at ";"))
  232.          (forward-line 1))
  233.            (not (eobp)))
  234.     (setq sexp (read inbuffer))
  235.     (print (byte-compile-file-form sexp) outbuffer))
  236.       (set-buffer outbuffer)
  237.       (goto-char 1)
  238.       ;; In each defun or autoload, if there is a doc string,
  239.       ;; put a backslash-newline at the front of it.
  240.       (while (search-forward "\n(" nil t)
  241.     (cond ((looking-at "defun \\|autoload ")
  242.            (forward-sexp 3)
  243.            (skip-chars-forward " ")
  244.            (if (looking-at "\"")
  245.            (progn (forward-char 1)
  246.               (insert "\\\n"))))))
  247.       (goto-char 1)
  248.       ;; In each defconst or defvar, if there is a doc string
  249.       ;; and it starts on the same line as the form begins
  250.       ;; (i.e. if there is no newline in a string in the initial value)
  251.       ;; then put in backslash-newline at the start of the doc string.
  252.       (while (search-forward "\n(" nil t)
  253.     (if (looking-at "defvar \\|defconst ")
  254.         (let ((this-line (1- (point))))
  255.           ;;Go to end of initial value expression
  256.           (if (condition-case ()
  257.               (progn (forward-sexp 3) t)
  258.             (error nil))
  259.           (progn
  260.             (skip-chars-forward " ")
  261.             (and (eq this-line
  262.                  (save-excursion (beginning-of-line) (point)))
  263.              (looking-at "\"")
  264.              (progn (forward-char 1)
  265.                 (insert "\\\n"))))))))
  266.  ;;; patch by M.Sato  87.7.20
  267.  ;;;  (let ((vms-stmlf-recfm t))
  268.       (let ((vms-stmlf-recfm t)
  269.         (kanji-flag nil))
  270.  ;;; end of patch
  271.  ;;; patched by Manabu Higashida 91/10/22 for Demacs 1.1
  272.     (if (eq system-type 'ms-dos)
  273.         (set-file-type 'binary (current-buffer)))
  274.  ;;; end of patch
  275.     (write-region 1 (point-max)
  276.               (concat (file-name-sans-versions filename) "c")))
  277.       (kill-buffer (current-buffer))
  278.       (kill-buffer inbuffer)))
  279.   t)
  280.  
  281.  
  282. (defun byte-compile-file-form (form)
  283.   (cond ((not (listp form))
  284.      form)
  285.     ((memq (car form) '(defun defmacro))
  286.      (let* ((name (car (cdr form)))
  287.         (tem (assq name byte-compile-macro-environment)))
  288.        (if (eq (car form) 'defun)
  289.            (progn
  290.          (message "Compiling %s (%s)..." filename (nth 1 form))
  291.          (cond (tem (setcdr tem nil))
  292.                ((and (fboundp name)
  293.                  (eq (car-safe (symbol-function name)) 'macro))
  294.             ;; shadow existing macro definition
  295.             (setq byte-compile-macro-environment
  296.                   (cons (cons name nil)
  297.                     byte-compile-macro-environment))))
  298.          (prog1 (cons 'defun (byte-compile-lambda (cdr form)))
  299.            (if (not noninteractive)
  300.                (message "Compiling %s..." filename))))
  301.          ;; defmacro
  302.          (if tem
  303.          (setcdr tem (cons 'lambda (cdr (cdr form))))
  304.            (setq byte-compile-macro-environment
  305.              (cons (cons name (cons 'lambda (cdr (cdr form))))
  306.                byte-compile-macro-environment)))
  307.          (cons 'defmacro (byte-compile-lambda (cdr form))))))
  308.     ((eq (car form) 'require)
  309.      (eval form)
  310.      form)
  311.     (t form)))
  312.  
  313. (defun byte-compile (funname)
  314.   "Byte-compile the definition of function FUNNAME (a symbol)."
  315.   (if (and (fboundp funname)
  316.        (eq (car-safe (symbol-function funname)) 'lambda))
  317.       (fset funname (byte-compile-lambda (symbol-function funname)))))
  318.  
  319. (defun byte-compile-lambda (fun)
  320.   (let* ((bodyptr (cdr fun))
  321.      (int (assq 'interactive (cdr bodyptr)))
  322.      newbody)
  323.     ;; Skip doc string.
  324.     (if (stringp (car (cdr bodyptr)))
  325.     (setq bodyptr (cdr bodyptr)))
  326.     (setq newbody (list (byte-compile-top-level
  327.               (cons 'progn (cdr bodyptr)))))
  328.     (if int
  329.     (setq newbody (cons (if (or (stringp (car (cdr int)))
  330.                     (null (car (cdr int))))
  331.                 int
  332.                   (list 'interactive
  333.                     (byte-compile-top-level (car (cdr int)))))
  334.                 newbody)))
  335.     (if (not (eq bodyptr (cdr fun)))
  336.     (setq newbody (cons (nth 2 fun) newbody)))
  337.     (cons (car fun) (cons (car (cdr fun)) newbody))))
  338.  
  339. (defun byte-compile-top-level (form)
  340.   (let ((byte-compile-constants nil)
  341.     (byte-compile-constnum nil)
  342.     (byte-compile-pc 0)
  343.     (byte-compile-depth 0)
  344.     (byte-compile-maxdepth 0)
  345.     (byte-compile-output nil)
  346.     (byte-compile-string nil)
  347.     (byte-compile-vector nil))
  348.     (let (vars temp (i -1))
  349.       (setq temp (byte-compile-find-vars form))
  350.       (setq form (car temp))
  351.       (setq vars (nreverse (cdr temp)))
  352.       (while vars
  353.     (setq i (1+ i))
  354.     (setq byte-compile-constants (cons (cons (car vars) i)
  355.                        byte-compile-constants))
  356.     (setq vars (cdr vars)))
  357.       (setq byte-compile-constnum i))
  358.     (byte-compile-form form)
  359.     (byte-compile-out 'byte-return 0)
  360.     (setq byte-compile-vector (make-vector (1+ byte-compile-constnum)
  361.                        nil))
  362.     (while byte-compile-constants
  363.       (aset byte-compile-vector (cdr (car byte-compile-constants))
  364.         (car (car byte-compile-constants)))
  365.       (setq byte-compile-constants (cdr byte-compile-constants)))
  366.     (setq byte-compile-string (make-string byte-compile-pc 0))
  367.     (while byte-compile-output
  368.       (aset byte-compile-string (car (car byte-compile-output))
  369.         (cdr (car byte-compile-output)))
  370.       (setq byte-compile-output (cdr byte-compile-output)))
  371.     (list 'byte-code byte-compile-string
  372.              byte-compile-vector byte-compile-maxdepth)))
  373.  
  374. ;; Expand all macros in FORM and find all variables it uses.
  375. ;; Return a pair (EXPANDEDFORM . VARS)
  376. ;; VARS is ordered with the variables encountered earliest
  377. ;; at the end.
  378. ;; The body and cases of a condition-case, and the body of a catch,
  379. ;; are not scanned; variables used in them are not reported,
  380. ;; and they are not macroexpanded.  This is because they will
  381. ;; be compiled separately when encountered during the main
  382. ;; compilation pass.
  383. (defun byte-compile-find-vars (form)
  384.   (let ((all-vars nil))
  385.     (cons (byte-compile-find-vars-1 form)
  386.       all-vars)))
  387.  
  388. ;; Walk FORM, making sure all variables it uses are in ALL-VARS,
  389. ;; and also expanding macros.
  390. ;; Return the result of expanding all macros in FORM.
  391. ;; This is a copy; FORM itself is not altered.
  392. (defun byte-compile-find-vars-1 (form)
  393.   (cond ((symbolp form)
  394.      (if (not (memq form all-vars))
  395.          (setq all-vars (cons form all-vars)))
  396.      form)
  397.     ((or (not (consp form)) (eq (car form) 'quote))
  398.      form)
  399.     ((memq (car form) '(let let*))
  400.      (let* ((binds (copy-sequence (car (cdr form))))
  401.         (body (cdr (cdr form)))
  402.         (tail binds))
  403.        (while tail
  404.          (if (symbolp (car tail))
  405.          (if (not (memq (car tail) all-vars))
  406.              (setq all-vars (cons (car tail) all-vars)))
  407.            (if (consp (car tail))
  408.            (progn
  409.              (if (not (memq (car (car tail)) all-vars))
  410.              (setq all-vars (cons (car (car tail)) all-vars)))
  411.              (setcar tail
  412.                  (list (car (car tail))
  413.                    (byte-compile-find-vars-1 (car (cdr (car tail)))))))))
  414.          (setq tail (cdr tail)))
  415.        (cons (car form)
  416.          (cons binds
  417.                (mapcar 'byte-compile-find-vars-1 body)))))
  418.     ((or (eq (car form) 'function)
  419.          ;; Because condition-case is compiled by breaking out
  420.          ;; all its subexpressions and compiling them separately,
  421.          ;; we regard it here as containing nothing but constants.
  422.          (eq (car form) 'condition-case))
  423.      form)
  424.     ((eq (car form) 'catch)
  425.      ;; catch is almost like condition case, but we
  426.      ;; treat its first argument normally.
  427.      (cons 'catch
  428.            (cons (byte-compile-find-vars-1 (nth 1 form))
  429.              (nthcdr 2 form))))
  430.     ((eq (car form) 'cond)
  431.      (let* ((clauses (copy-sequence (cdr form)))
  432.         (tail clauses))
  433.        (while tail
  434.          (setcar tail (mapcar 'byte-compile-find-vars-1 (car tail)))
  435.          (setq tail (cdr tail)))
  436.        (cons 'cond clauses)))
  437.     ((not (eq form (setq form (macroexpand form byte-compile-macro-environment))))
  438.      (byte-compile-find-vars-1 form))
  439.     ((symbolp (car form))
  440.      (cons (car form) (mapcar 'byte-compile-find-vars-1 (cdr form))))
  441.     (t (mapcar 'byte-compile-find-vars-1 form))))
  442.  
  443. ;; This is the recursive entry point for compiling each subform of an expression.
  444.  
  445. ;; Note that handler functions SHOULD NOT increment byte-compile-depth
  446. ;; for the values they are returning!  That is done on return here.
  447. ;; Handlers should make sure that the depth on exit is the same as
  448. ;; it was when the handler was called.
  449.  
  450. (defun byte-compile-form (form)
  451.   (setq form (macroexpand form byte-compile-macro-environment))
  452.   (cond ((eq form 'nil)
  453.      (byte-compile-constant form))
  454.     ((eq form 't)
  455.      (byte-compile-constant form))
  456.     ((symbolp form)
  457.      (byte-compile-variable-ref 'byte-varref form))
  458.     ((not (consp form))
  459.      (byte-compile-constant 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. (defun byte-compile-cond-1 (clauses)
  956.   (if (or (eq (car (car clauses)) t)
  957.       (eq (car-safe (car (car clauses))) 'quote))
  958.       ;; Unconditional clause
  959.       (byte-compile-body (cdr (car clauses)))
  960.     (if (null (cdr clauses))
  961.     ;; Only one clause
  962.     (let ((donetag (byte-compile-make-tag)))
  963.       (byte-compile-form (car (car clauses)))
  964.       (cond ((cdr (car clauses))
  965.          (byte-compile-goto 'byte-goto-if-nil-else-pop donetag)
  966.          (setq byte-compile-depth (1- byte-compile-depth))
  967.          (byte-compile-body (cdr (car clauses)))
  968.          (byte-compile-out-tag donetag))))
  969.       (let ((donetag (byte-compile-make-tag))
  970.         (elsetag (byte-compile-make-tag)))
  971.     (byte-compile-form (car (car clauses)))
  972.     (if (null (cdr (car clauses)))
  973.         ;; First clause is a singleton.
  974.         (progn
  975.           (byte-compile-goto 'byte-goto-if-not-nil-else-pop donetag)
  976.           (setq byte-compile-depth (1- byte-compile-depth)))
  977.       (byte-compile-goto 'byte-goto-if-nil elsetag)
  978.       (setq byte-compile-depth (1- byte-compile-depth))
  979.       (byte-compile-body (cdr (car clauses)))
  980.       (byte-compile-goto 'byte-goto donetag)
  981.       (byte-compile-out-tag elsetag))
  982.     (byte-compile-cond-1 (cdr clauses))
  983.     (byte-compile-out-tag donetag)))))
  984.  
  985. (put 'and 'byte-compile 'byte-compile-and)
  986. (defun byte-compile-and (form)
  987.   (let ((failtag (byte-compile-make-tag))
  988.     (args (cdr form)))
  989.     (if (null args)
  990.     (progn
  991.       (byte-compile-form t)
  992.       (setq byte-compile-depth (1- byte-compile-depth)))
  993.       (while args
  994.     (byte-compile-form (car args))
  995.     (setq byte-compile-depth (1- byte-compile-depth))
  996.     (if (null (cdr args))
  997.         (byte-compile-out-tag failtag)
  998.       (byte-compile-goto 'byte-goto-if-nil-else-pop failtag))
  999.     (setq args (cdr args))))))
  1000.  
  1001. (put 'or 'byte-compile 'byte-compile-or)
  1002. (defun byte-compile-or (form)
  1003.   (let ((wintag (byte-compile-make-tag))
  1004.     (args (cdr form)))
  1005.     (if (null args)
  1006.     (byte-compile-constant nil)
  1007.       (while args
  1008.     (byte-compile-form (car args))
  1009.     (setq byte-compile-depth (1- byte-compile-depth))
  1010.     (if (null (cdr args))
  1011.         (byte-compile-out-tag wintag)
  1012.       (byte-compile-goto 'byte-goto-if-not-nil-else-pop wintag))
  1013.     (setq args (cdr args))))))
  1014.  
  1015. (put 'while 'byte-compile 'byte-compile-while)
  1016. (defun byte-compile-while (form)
  1017.   (let ((endtag (byte-compile-make-tag))
  1018.     (looptag (byte-compile-make-tag))
  1019.     (args (cdr (cdr form))))
  1020.     (byte-compile-out-tag looptag)
  1021.     (byte-compile-form (car (cdr form)))
  1022.     (byte-compile-goto 'byte-goto-if-nil-else-pop endtag)
  1023.     (byte-compile-body (cdr (cdr form)))
  1024.     (byte-compile-discard)
  1025.     (byte-compile-goto 'byte-goto looptag)
  1026.     (byte-compile-out-tag endtag)))
  1027.  
  1028. (put 'catch 'byte-compile 'byte-compile-catch)
  1029. (defun byte-compile-catch (form)
  1030.   (byte-compile-form (car (cdr form)))
  1031.   (byte-compile-push-constant (byte-compile-top-level (cons 'progn (cdr (cdr form)))))
  1032.   (setq byte-compile-depth (- byte-compile-depth 2))
  1033.   (byte-compile-out 'byte-catch 0))
  1034.  
  1035. (put 'save-window-excursion 'byte-compile 'byte-compile-save-window-excursion)
  1036. (defun byte-compile-save-window-excursion (form)
  1037.   (byte-compile-push-constant
  1038.     (list (byte-compile-top-level (cons 'progn (cdr form)))))
  1039.   (setq byte-compile-depth (1- byte-compile-depth))
  1040.   (byte-compile-out 'byte-save-window-excursion 0))
  1041.  
  1042. (put 'unwind-protect 'byte-compile 'byte-compile-unwind-protect)
  1043. (defun byte-compile-unwind-protect (form)
  1044.   (byte-compile-push-constant
  1045.     (list (byte-compile-top-level (cons 'progn (cdr (cdr form))))))
  1046.   (setq byte-compile-depth (1- byte-compile-depth))
  1047.   (byte-compile-out 'byte-unwind-protect 0)
  1048.   (byte-compile-form (car (cdr form)))
  1049.   (setq byte-compile-depth (1- byte-compile-depth))
  1050.   (byte-compile-out 'byte-unbind 1))
  1051.  
  1052. (put 'condition-case 'byte-compile 'byte-compile-condition-case)
  1053. (defun byte-compile-condition-case (form)
  1054.   (byte-compile-push-constant (car (cdr form)))
  1055.   (byte-compile-push-constant (byte-compile-top-level (nth 2 form)))
  1056.   (let ((clauses (cdr (cdr (cdr form))))
  1057.     compiled-clauses)
  1058.     (while clauses
  1059.       (let ((clause (car clauses)))
  1060.     (setq compiled-clauses
  1061.           (cons (list (car clause)
  1062.               (byte-compile-top-level (cons 'progn (cdr clause))))
  1063.             compiled-clauses)))
  1064.       (setq clauses (cdr clauses)))
  1065.     (byte-compile-push-constant (nreverse compiled-clauses)))
  1066.   (setq byte-compile-depth (- byte-compile-depth 3))
  1067.   (byte-compile-out 'byte-condition-case 0))
  1068.  
  1069. (defun byte-compile-make-tag ()
  1070.   (cons nil nil))
  1071.  
  1072. (defun byte-compile-out-tag (tag)
  1073.   (let ((uses (car tag)))
  1074.     (setcar tag byte-compile-pc)
  1075.     (while uses
  1076.       (byte-compile-store-goto (car uses) byte-compile-pc)
  1077.       (setq uses (cdr uses)))))
  1078.  
  1079. (defun byte-compile-goto (opcode tag)
  1080.   (byte-compile-out opcode 0)
  1081.   (if (integerp (car tag))
  1082.       (byte-compile-store-goto byte-compile-pc (car tag))
  1083.     (setcar tag (cons byte-compile-pc (car tag))))
  1084.   (setq byte-compile-pc (+ byte-compile-pc 2)))
  1085.  
  1086. (defun byte-compile-store-goto (at-pc to-pc)
  1087.   (setq byte-compile-output
  1088.     (cons (cons at-pc (logand to-pc 255))
  1089.           byte-compile-output))
  1090.   (setq byte-compile-output
  1091.     (cons (cons (1+ at-pc) (lsh to-pc -8))
  1092.           byte-compile-output)))
  1093.  
  1094. (defun byte-compile-out (opcode offset)
  1095.   (setq opcode (eval opcode))
  1096.   (if (< offset 6)
  1097.       (byte-compile-out-1 (+ opcode offset))
  1098.     (if (< offset 256)
  1099.     (progn
  1100.       (byte-compile-out-1 (+ opcode 6))
  1101.       (byte-compile-out-1 offset))
  1102.       (byte-compile-out-1 (+ opcode 7))
  1103.       (byte-compile-out-1 (logand offset 255))
  1104.       (byte-compile-out-1 (lsh offset -8)))))
  1105.  
  1106. (defun byte-compile-out-const (offset)
  1107.   (if (< offset byte-constant-limit)
  1108.       (byte-compile-out-1 (+ byte-constant offset))
  1109.     (byte-compile-out-1 byte-constant2)
  1110.     (byte-compile-out-1 (logand offset 255))
  1111.     (byte-compile-out-1 (lsh offset -8))))
  1112.  
  1113. (defun byte-compile-out-1 (code)
  1114.   (setq byte-compile-output
  1115.     (cons (cons byte-compile-pc code)
  1116.           byte-compile-output))
  1117.   (setq byte-compile-pc (1+ byte-compile-pc)))
  1118.  
  1119. ;;; by crl@newton.purdue.edu
  1120. ;;;  Only works noninteractively.
  1121. (defun batch-byte-compile ()
  1122.   "Runs byte-compile-file on the files remaining on the command line.
  1123. Must be used only with -batch, and kills emacs on completion.
  1124. Each file will be processed even if an error occurred previously.
  1125. For example, invoke \"emacs -batch -f batch-byte-compile $emacs/ ~/*.el\""
  1126.   ;; command-line-args-left is what is left of the command line (from startup.el)
  1127.   (if (not noninteractive)
  1128.       (error "batch-byte-compile is to be used only with -batch"))
  1129.   (let ((error nil))
  1130.     (while command-line-args-left
  1131.       (if (file-directory-p (expand-file-name (car command-line-args-left)))
  1132.       (let ((files (directory-files (car command-line-args-left)))
  1133.         source dest)
  1134.         (while files
  1135.           (if (and (string-match ".el$" (car files))
  1136.                (not (auto-save-file-name-p (car files)))
  1137.                (setq source (expand-file-name (car files)
  1138.                               (car command-line-args-left)))
  1139.                (setq dest (concat (file-name-sans-versions source) "c"))
  1140.                (file-exists-p dest)
  1141.                (file-newer-than-file-p source dest))
  1142.           (if (null (batch-byte-compile-file source))
  1143.               (setq error t)))
  1144.           (setq files (cdr files))))
  1145.     (if (null (batch-byte-compile-file (car command-line-args-left)))
  1146.         (setq error t)))
  1147.       (setq command-line-args-left (cdr command-line-args-left)))
  1148.     (message "Done")
  1149.     (kill-emacs (if error 1 0))))
  1150.  
  1151. (defun batch-byte-compile-file (file)
  1152.   (condition-case err
  1153.       (progn (byte-compile-file file) t)
  1154.     (error
  1155.      (message (if (cdr err)
  1156.           ">>Error occurred processing %s: %s (%s)"
  1157.           ">>Error occurred processing %s: %s")
  1158.           file
  1159.           (get (car err) 'error-message)
  1160.           (prin1-to-string (cdr err)))
  1161.      nil)))
  1162.