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