bytecomp.el

早期freebsd实现

;; Compilation of Lisp code into byte code.
;; Copyright (C) 1985, 1986, 1987 Free Software Foundation, Inc.

;; This file is part of GNU Emacs.

;; GNU Emacs is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 1, or (at your option)
;; any later version.

;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.

;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING.  If not, write to
;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.

(provide 'byte-compile)

(defvar byte-compile-constnum -1
  "Transfer vector index of last constant allocated.")
(defvar byte-compile-constants nil
  "Alist describing contents to put in transfer vector.
Each element is (CONTENTS . INDEX)")
(defvar byte-compile-macro-environment nil
  "Alist of (MACRONAME . DEFINITION) macros defined in the file
which is being compiled.")
(defvar byte-compile-pc 0
  "Index in byte string to store next opcode at.")
(defvar byte-compile-output nil
  "Alist describing contents to put in byte code string.
Each element is (INDEX . VALUE)")
(defvar byte-compile-depth 0
  "Current depth of execution stack.")
(defvar byte-compile-maxdepth 0
  "Maximum depth of execution stack.")

(defconst byte-varref 8
  "Byte code opcode for variable reference.")
(defconst byte-varset 16
  "Byte code opcode for setting a variable.")
(defconst byte-varbind 24
  "Byte code opcode for binding a variable.")
(defconst byte-call 32
  "Byte code opcode for calling a function.")
(defconst byte-unbind 40
  "Byte code opcode for unbinding special bindings.")

(defconst byte-constant 192
  "Byte code opcode for reference to a constant.")
(defconst byte-constant-limit 64
  "Maximum index usable in  byte-constant  opcode.")

(defconst byte-constant2 129
  "Byte code opcode for reference to a constant with vector index >= 0100.")

(defconst byte-goto 130
  "Byte code opcode for unconditional jump")

(defconst byte-goto-if-nil 131
  "Byte code opcode for pop value and jump if it's nil.")

(defconst byte-goto-if-not-nil 132
  "Byte code opcode for pop value and jump if it's not nil.")

(defconst byte-goto-if-nil-else-pop 133
  "Byte code opcode for examine top-of-stack, jump and don't pop it if it's nil,
otherwise pop it.")

(defconst byte-goto-if-not-nil-else-pop 134
  "Byte code opcode for examine top-of-stack, jump and don't pop it if it's not nil,
otherwise pop it.")

(defconst byte-return 135
  "Byte code opcode for pop value and return it from byte code interpreter.")

(defconst byte-discard 136
  "Byte code opcode to discard one value from stack.")

(defconst byte-dup 137
  "Byte code opcode to duplicate the top of the stack.")

(defconst byte-save-excursion 138
  "Byte code opcode to make a binding to record the buffer, point and mark.")

(defconst byte-save-window-excursion 139
  "Byte code opcode to make a binding to record entire window configuration.")

(defconst byte-save-restriction 140
  "Byte code opcode to make a binding to record the current buffer clipping restrictions.")

(defconst byte-catch 141
  "Byte code opcode for catch.  Takes, on stack, the tag and an expression for the body.")

(defconst byte-unwind-protect 142
  "Byte code opcode for unwind-protect.  Takes, on stack, an expression for the body
and an expression for the unwind-action.")

(defconst byte-condition-case 143
  "Byte code opcode for condition-case.  Takes, on stack, the variable to bind,
an expression for the body, and a list of clauses.")

(defconst byte-temp-output-buffer-setup 144
  "Byte code opcode for entry to with-output-to-temp-buffer.
Takes, on stack, the buffer name.
Binds standard-output and does some other things.
Returns with temp buffer on the stack in place of buffer name.")

(defconst byte-temp-output-buffer-show 145
  "Byte code opcode for exit from with-output-to-temp-buffer.
Expects the temp buffer on the stack underneath value to return.
Pops them both, then pushes the value back on.
Unbinds standard-output and makes the temp buffer visible.")

(defconst byte-nth 56)
(defconst byte-symbolp 57)
(defconst byte-consp 58)
(defconst byte-stringp 59)
(defconst byte-listp 60)
(defconst byte-eq 61)
(defconst byte-memq 62)
(defconst byte-not 63)
(defconst byte-car 64)
(defconst byte-cdr 65)
(defconst byte-cons 66)
(defconst byte-list1 67)
(defconst byte-list2 68)
(defconst byte-list3 69)
(defconst byte-list4 70)
(defconst byte-length 71)
(defconst byte-aref 72)
(defconst byte-aset 73)
(defconst byte-symbol-value 74)
(defconst byte-symbol-function 75)
(defconst byte-set 76)
(defconst byte-fset 77)
(defconst byte-get 78)
(defconst byte-substring 79)
(defconst byte-concat2 80)
(defconst byte-concat3 81)
(defconst byte-concat4 82)
(defconst byte-sub1 83)
(defconst byte-add1 84)
(defconst byte-eqlsign 85)
(defconst byte-gtr 86)
(defconst byte-lss 87)
(defconst byte-leq 88)
(defconst byte-geq 89)
(defconst byte-diff 90)
(defconst byte-negate 91)
(defconst byte-plus 92)
(defconst byte-max 93)
(defconst byte-min 94)

(defconst byte-point 96)
;(defconst byte-mark 97) no longer generated -- lisp code shouldn't call this very frequently
(defconst byte-goto-char 98)
(defconst byte-insert 99)
(defconst byte-point-max 100)
(defconst byte-point-min 101)
(defconst byte-char-after 102)
(defconst byte-following-char 103)
(defconst byte-preceding-char 104)
(defconst byte-current-column 105)
(defconst byte-indent-to 106)
;(defconst byte-scan-buffer 107) no longer generated
(defconst byte-eolp 108)
(defconst byte-eobp 109)
(defconst byte-bolp 110)
(defconst byte-bobp 111)
(defconst byte-current-buffer 112)
(defconst byte-set-buffer 113)
(defconst byte-read-char 114)
;(defconst byte-set-mark 115)       ;obsolete
(defconst byte-interactive-p 116)

(defun byte-recompile-directory (directory &optional arg)
  "Recompile every .el file in DIRECTORY that needs recompilation.
This is if a .elc file exists but is older than the .el file.
If the .elc file does not exist, offer to compile the .el file
only if a prefix argument has been specified." 
  (interactive "DByte recompile directory: \nP")
  (save-some-buffers)
  (setq directory (expand-file-name directory))
  (let ((files (directory-files directory nil "\\.el\\'"))
	(count 0)
	source dest)
    (while files
      (if (and (not (auto-save-file-name-p (car files)))
	       (setq source (expand-file-name (car files) directory))
	       (setq dest (concat (file-name-sans-versions source) "c"))
	       (if (file-exists-p dest)
		   (file-newer-than-file-p source dest)
		   (and arg (y-or-n-p (concat "Compile " source "? ")))))
	  (progn (byte-compile-file source)
		 (setq count (1+ count))))
      (setq files (cdr files)))
    (message "Done (Total of %d file%s compiled)"
	     count (if (= count 1) "" "s"))))

(defun byte-compile-file (filename)
  "Compile a file of Lisp code named FILENAME into a file of byte code.
The output file's name is made by appending \"c\" to the end of FILENAME."
  (interactive "fByte compile file: ")
  ;; Expand now so we get the current buffer's defaults
  (setq filename (expand-file-name filename))
  (message "Compiling %s..." filename)
  (let ((inbuffer (get-buffer-create " *Compiler Input*"))
	(outbuffer (get-buffer-create " *Compiler Output*"))
	(byte-compile-macro-environment nil)
	(case-fold-search nil)
	sexp)
    (save-excursion
      (set-buffer inbuffer)
      (erase-buffer)
      (insert-file-contents filename)
      (goto-char 1)
      (set-buffer outbuffer)
      (emacs-lisp-mode)
      (erase-buffer)
      (while (save-excursion
	       (set-buffer inbuffer)
	       (while (progn (skip-chars-forward " \t\n\^l")
			     (looking-at ";"))
		 (forward-line 1))
	       (not (eobp)))
	(setq sexp (read inbuffer))
	(print (byte-compile-file-form sexp) outbuffer))
      (set-buffer outbuffer)
      (goto-char 1)
      ;; In each defun or autoload, if there is a doc string,
      ;; put a backslash-newline at the front of it.
      (while (search-forward "\n(" nil t)
	(cond ((looking-at "defun \\|autoload ")
	       (forward-sexp 3)
	       (skip-chars-forward " ")
	       (if (looking-at "\"")
		   (progn (forward-char 1)
			  (insert "\\\n"))))))
      (goto-char 1)
      ;; In each defconst or defvar, if there is a doc string
      ;; and it starts on the same line as the form begins
      ;; (i.e. if there is no newline in a string in the initial value)
      ;; then put in backslash-newline at the start of the doc string.
      (while (search-forward "\n(" nil t)
	(if (looking-at "defvar \\|defconst ")
	    (let ((this-line (1- (point))))
	      ;;Go to end of initial value expression
	      (if (condition-case ()
		      (progn (forward-sexp 3) t)
		    (error nil))
		  (progn
		    (skip-chars-forward " ")
		    (and (eq this-line
			     (save-excursion (beginning-of-line) (point)))
			 (looking-at "\"")
			 (progn (forward-char 1)
				(insert "\\\n"))))))))
      (let ((vms-stmlf-recfm t))
	(write-region 1 (point-max)
		      (concat (file-name-sans-versions filename) "c")))
      (kill-buffer (current-buffer))
      (kill-buffer inbuffer)))
  t)


(defun byte-compile-file-form (form)
  (cond ((not (listp form))
	 form)
	((memq (car form) '(defun defmacro))
	 (let* ((name (car (cdr form)))
		(tem (assq name byte-compile-macro-environment)))
	   (if (eq (car form) 'defun)
	       (progn
		 (message "Compiling %s (%s)..." filename (nth 1 form))
		 (cond (tem (setcdr tem nil))
		       ((and (fboundp name)
			     (eq (car-safe (symbol-function name)) 'macro))
			;; shadow existing macro definition
			(setq byte-compile-macro-environment
			      (cons (cons name nil)
				    byte-compile-macro-environment))))
		 (prog1 (cons 'defun (byte-compile-lambda (cdr form)))
		   (if (not noninteractive)
		       (message "Compiling %s..." filename))))
	     ;; defmacro
	     (if tem
		 (setcdr tem (cons 'lambda (cdr (cdr form))))
	       (setq byte-compile-macro-environment
		     (cons (cons name (cons 'lambda (cdr (cdr form))))
			   byte-compile-macro-environment)))
	     (cons 'defmacro (byte-compile-lambda (cdr form))))))
	((eq (car form) 'require)
	 (eval form)
	 form)
	(t form)))

(defun byte-compile (funname)
  "Byte-compile the definition of function FUNNAME (a symbol)."
  (if (and (fboundp funname)
	   (eq (car-safe (symbol-function funname)) 'lambda))
      (fset funname (byte-compile-lambda (symbol-function funname)))))

(defun byte-compile-lambda (fun)
  (let* ((bodyptr (cdr fun))
	 (int (assq 'interactive (cdr bodyptr)))
	 newbody)
    ;; Skip doc string.
    (if (and (cdr (cdr bodyptr)) (stringp (car (cdr bodyptr))))
	(setq bodyptr (cdr bodyptr)))
    (setq newbody (list (byte-compile-top-level
			  (cons 'progn (cdr bodyptr)))))
    (if int
	(setq newbody (cons (if (or (stringp (car (cdr int)))
				    (null (car (cdr int))))
				int
			      (list 'interactive
				    (byte-compile-top-level (car (cdr int)))))
			    newbody)))
    (if (not (eq bodyptr (cdr fun)))
	(setq newbody (cons (nth 2 fun) newbody)))
    (cons (car fun) (cons (car (cdr fun)) newbody))))

(defun byte-compile-top-level (form)
  (let ((byte-compile-constants nil)
	(byte-compile-constnum nil)
	(byte-compile-pc 0)
	(byte-compile-depth 0)
	(byte-compile-maxdepth 0)
	(byte-compile-output nil)
	(byte-compile-string nil)
	(byte-compile-vector nil))
    (let (vars temp (i -1))
      (setq temp (byte-compile-find-vars form))
      (setq form (car temp))
      (setq vars (nreverse (cdr temp)))
      (while vars
	(setq i (1+ i))
	(setq byte-compile-constants (cons (cons (car vars) i)
					   byte-compile-constants))
	(setq vars (cdr vars)))
      (setq byte-compile-constnum i))
    (byte-compile-form form)
    (byte-compile-out 'byte-return 0)
    (setq byte-compile-vector (make-vector (1+ byte-compile-constnum)
					   nil))
    (while byte-compile-constants
      (aset byte-compile-vector (cdr (car byte-compile-constants))
	    (car (car byte-compile-constants)))
      (setq byte-compile-constants (cdr byte-compile-constants)))
    (setq byte-compile-string (make-string byte-compile-pc 0))
    (while byte-compile-output
      (aset byte-compile-string (car (car byte-compile-output))
	    (cdr (car byte-compile-output)))
      (setq byte-compile-output (cdr byte-compile-output)))
    (list 'byte-code byte-compile-string
		     byte-compile-vector byte-compile-maxdepth)))

;; Expand all macros in FORM and find all variables it uses.
;; Return a pair (EXPANDEDFORM . VARS)
;; VARS is ordered with the variables encountered earliest
;; at the end.
;; The body and cases of a condition-case, and the body of a catch,
;; are not scanned; variables used in them are not reported,
;; and they are not macroexpanded.  This is because they will
;; be compiled separately when encountered during the main
;; compilation pass.
(defun byte-compile-find-vars (form)
  (let ((all-vars nil))
    (cons (byte-compile-find-vars-1 form)
	  all-vars)))

;; Walk FORM, making sure all variables it uses are in ALL-VARS,
;; and also expanding macros.
;; Return the result of expanding all macros in FORM.
;; This is a copy; FORM itself is not altered.
(defun byte-compile-find-vars-1 (form)
  (cond ((symbolp form)
	 (if (not (memq form all-vars))
	     (setq all-vars (cons form all-vars)))
	 form)
	((or (not (consp form)) (eq (car form) 'quote))
	 form)
	((memq (car form) '(let let*))
	 (let* ((binds (copy-sequence (car (cdr form))))