bytecomp.el

早期freebsd实现

	 (byte-compile-form
	  (list 'symbol-function (list 'quote (nth 1 form)))))
	(t
	 (byte-compile-constant (byte-compile-lambda (car (cdr form)))))))

(put 'indent-to 'byte-compile 'byte-compile-indent-to)
(defun byte-compile-indent-to (form)
  (let ((len (length form)))
    (if (= len 2)
	(progn
	  (byte-compile-form (car (cdr form)))
	  (setq byte-compile-depth (- byte-compile-depth 1))
	  (byte-compile-out byte-indent-to 0))
      (byte-compile-normal-call form))))

(put 'insert 'byte-compile 'byte-compile-insert)
(defun byte-compile-insert (form)
  (let ((len (length form)))
    (if (< len 3)
	(let ((args (cdr form)))
	  (while args
	    (byte-compile-form (car args))
	    (setq byte-compile-depth (- byte-compile-depth 1))
	    (byte-compile-out byte-insert 0)
	    (setq args (cdr args))))
      (byte-compile-normal-call form))))

(put 'setq-default 'byte-compile 'byte-compile-setq-default)
(defun byte-compile-setq-default (form)
  (byte-compile-form (cons 'set-default (cons (list 'quote (nth 1 form))
					      (nthcdr 2 form)))))

(put 'quote 'byte-compile 'byte-compile-quote)
(defun byte-compile-quote (form)
  (byte-compile-constant (car (cdr form))))

(put 'setq 'byte-compile 'byte-compile-setq)
(defun byte-compile-setq (form)
  (let ((args (cdr form)))
    (if args
	(while args
	  (byte-compile-form (car (cdr args)))
	  (if (null (cdr (cdr args)))
	      (progn
		(byte-compile-out 'byte-dup 0)
		(setq byte-compile-maxdepth (max byte-compile-maxdepth (1+ byte-compile-depth)))))
	  (setq byte-compile-depth (1- byte-compile-depth))
	  (byte-compile-variable-ref 'byte-varset (car args))
	  (setq args (cdr (cdr args))))
      ;; (setq), with no arguments.
      (byte-compile-constant nil))))

(put 'let 'byte-compile 'byte-compile-let)
(defun byte-compile-let (form)
  (let ((varlist (car (cdr form))))
    (while varlist
      (if (symbolp (car varlist))
	  (byte-compile-push-constant nil)
	(byte-compile-form (car (cdr (car varlist)))))
      (setq varlist (cdr varlist))))
  (let ((varlist (reverse (car (cdr form)))))
    (setq byte-compile-depth (- byte-compile-depth (length varlist)))
    (while varlist
      (if (symbolp (car varlist))
	  (byte-compile-variable-ref 'byte-varbind (car varlist))
	(byte-compile-variable-ref 'byte-varbind (car (car varlist))))
      (setq varlist (cdr varlist))))
  (byte-compile-body (cdr (cdr form)))
  (byte-compile-out 'byte-unbind (length (car (cdr form)))))

(put 'let* 'byte-compile 'byte-compile-let*)
(defun byte-compile-let* (form)
  (let ((varlist (car (cdr form))))
    (while varlist
      (if (symbolp (car varlist))
	  (byte-compile-push-constant nil)
	(byte-compile-form (car (cdr (car varlist)))))
      (setq byte-compile-depth (1- byte-compile-depth))
      (if (symbolp (car varlist))
	  (byte-compile-variable-ref 'byte-varbind (car varlist))
	(byte-compile-variable-ref 'byte-varbind (car (car varlist))))
      (setq varlist (cdr varlist))))
  (byte-compile-body (cdr (cdr form)))
  (byte-compile-out 'byte-unbind (length (car (cdr form)))))

(put 'save-excursion 'byte-compile 'byte-compile-save-excursion)
(defun byte-compile-save-excursion (form)
  (byte-compile-out 'byte-save-excursion 0)
  (byte-compile-body (cdr form))
  (byte-compile-out 'byte-unbind 1))

(put 'save-restriction 'byte-compile 'byte-compile-save-restriction)
(defun byte-compile-save-restriction (form)
  (byte-compile-out 'byte-save-restriction 0)
  (byte-compile-body (cdr form))
  (byte-compile-out 'byte-unbind 1))

(put 'with-output-to-temp-buffer 'byte-compile 'byte-compile-with-output-to-temp-buffer)
(defun byte-compile-with-output-to-temp-buffer (form)
  (byte-compile-form (car (cdr form)))
  (byte-compile-out 'byte-temp-output-buffer-setup 0)
  (byte-compile-body (cdr (cdr form)))
  (byte-compile-out 'byte-temp-output-buffer-show 0)
  (setq byte-compile-depth (1- byte-compile-depth)))

(put 'progn 'byte-compile 'byte-compile-progn)
(defun byte-compile-progn (form)
  (byte-compile-body (cdr form)))

(put 'interactive 'byte-compile 'byte-compile-noop)
(defun byte-compile-noop (form)
  (byte-compile-constant nil))

(defun byte-compile-body (body)
  (if (null body)
      (byte-compile-constant nil)
    (while body
      (byte-compile-form (car body))
      (if (cdr body)
	  (byte-compile-discard)
	;; Convention is this will be counted after we return.
	(setq byte-compile-depth (1- byte-compile-depth)))
      (setq body (cdr body)))))

(put 'prog1 'byte-compile 'byte-compile-prog1)
(defun byte-compile-prog1 (form)
  (byte-compile-form (car (cdr form)))
  (if (cdr (cdr form))
      (progn
	(byte-compile-body (cdr (cdr form)))
	;; This discards the value pushed by ..-body
	;; (which is not counted now in byte-compile-depth)
	;; and decrements byte-compile-depth for the value
	;; pushed by byte-compile-form above, which by convention
	;; will be counted in byte-compile-depth after we return.
	(byte-compile-discard))))

(put 'prog2 'byte-compile 'byte-compile-prog2)
(defun byte-compile-prog2 (form)
  (byte-compile-form (car (cdr form)))
  (byte-compile-discard)
  (byte-compile-form (nth 2 form))
  (if (cdr (cdr (cdr form)))
      (progn
	(byte-compile-body (cdr (cdr (cdr form))))
	(byte-compile-discard))))

(defun byte-compile-discard ()
  (byte-compile-out 'byte-discard 0)
  (setq byte-compile-depth (1- byte-compile-depth)))

(put 'if 'byte-compile 'byte-compile-if)
(defun byte-compile-if (form)
  (if (null (nthcdr 3 form))
      ;; No else-forms
      (let ((donetag (byte-compile-make-tag)))
	(byte-compile-form (car (cdr form)))
	(byte-compile-goto 'byte-goto-if-nil-else-pop donetag)
	(setq byte-compile-depth (1- byte-compile-depth))
	(byte-compile-form (nth 2 form))
	(setq byte-compile-depth (1- byte-compile-depth))
	(byte-compile-out-tag donetag))
    (let ((donetag (byte-compile-make-tag)) (elsetag (byte-compile-make-tag)))
      (byte-compile-form (car (cdr form)))
      (byte-compile-goto 'byte-goto-if-nil elsetag)
      (setq byte-compile-depth (1- byte-compile-depth))
      (byte-compile-form (nth 2 form))
      (setq byte-compile-depth (1- byte-compile-depth))
      (byte-compile-goto 'byte-goto donetag)
      (byte-compile-out-tag elsetag)
      (byte-compile-body (cdr (cdr (cdr form))))
      (byte-compile-out-tag donetag))))

(put 'cond 'byte-compile 'byte-compile-cond)
(defun byte-compile-cond (form)
  (if (cdr form)
      (byte-compile-cond-1 (cdr form))
    (byte-compile-constant nil)))
(defun byte-compile-cond-1 (clauses)
  (if (or (eq (car (car clauses)) t)
	  (eq (car-safe (car (car clauses))) 'quote))
      ;; Unconditional clause
      (byte-compile-body (cdr (car clauses)))
    (if (null (cdr clauses))
	;; Only one clause
	(let ((donetag (byte-compile-make-tag)))
	  (byte-compile-form (car (car clauses)))
	  (cond ((cdr (car clauses))
		 (byte-compile-goto 'byte-goto-if-nil-else-pop donetag)
		 (setq byte-compile-depth (1- byte-compile-depth))
		 (byte-compile-body (cdr (car clauses)))
		 (byte-compile-out-tag donetag))))
      (let ((donetag (byte-compile-make-tag))
	    (elsetag (byte-compile-make-tag)))
	(byte-compile-form (car (car clauses)))
	(if (null (cdr (car clauses)))
	    ;; First clause is a singleton.
	    (progn
	      (byte-compile-goto 'byte-goto-if-not-nil-else-pop donetag)
	      (setq byte-compile-depth (1- byte-compile-depth)))
	  (byte-compile-goto 'byte-goto-if-nil elsetag)
	  (setq byte-compile-depth (1- byte-compile-depth))
	  (byte-compile-body (cdr (car clauses)))
	  (byte-compile-goto 'byte-goto donetag)
	  (byte-compile-out-tag elsetag))
	(byte-compile-cond-1 (cdr clauses))
	(byte-compile-out-tag donetag)))))

(put 'and 'byte-compile 'byte-compile-and)
(defun byte-compile-and (form)
  (let ((failtag (byte-compile-make-tag))
	(args (cdr form)))
    (if (null args)
	(progn
	  (byte-compile-form t)
	  (setq byte-compile-depth (1- byte-compile-depth)))
      (while args
	(byte-compile-form (car args))
	(setq byte-compile-depth (1- byte-compile-depth))
	(if (null (cdr args))
	    (byte-compile-out-tag failtag)
	  (byte-compile-goto 'byte-goto-if-nil-else-pop failtag))
	(setq args (cdr args))))))

(put 'or 'byte-compile 'byte-compile-or)
(defun byte-compile-or (form)
  (let ((wintag (byte-compile-make-tag))
	(args (cdr form)))
    (if (null args)
	(byte-compile-constant nil)
      (while args
	(byte-compile-form (car args))
	(setq byte-compile-depth (1- byte-compile-depth))
	(if (null (cdr args))
	    (byte-compile-out-tag wintag)
	  (byte-compile-goto 'byte-goto-if-not-nil-else-pop wintag))
	(setq args (cdr args))))))

(put 'while 'byte-compile 'byte-compile-while)
(defun byte-compile-while (form)
  (let ((endtag (byte-compile-make-tag))
	(looptag (byte-compile-make-tag))
	(args (cdr (cdr form))))
    (byte-compile-out-tag looptag)
    (byte-compile-form (car (cdr form)))
    (byte-compile-goto 'byte-goto-if-nil-else-pop endtag)
    (byte-compile-body (cdr (cdr form)))
    (byte-compile-discard)
    (byte-compile-goto 'byte-goto looptag)
    (byte-compile-out-tag endtag)))

(put 'catch 'byte-compile 'byte-compile-catch)
(defun byte-compile-catch (form)
  (byte-compile-form (car (cdr form)))
  (byte-compile-push-constant (byte-compile-top-level (cons 'progn (cdr (cdr form)))))
  (setq byte-compile-depth (- byte-compile-depth 2))
  (byte-compile-out 'byte-catch 0))

(put 'save-window-excursion 'byte-compile 'byte-compile-save-window-excursion)
(defun byte-compile-save-window-excursion (form)
  (byte-compile-push-constant
    (list (byte-compile-top-level (cons 'progn (cdr form)))))
  (setq byte-compile-depth (1- byte-compile-depth))
  (byte-compile-out 'byte-save-window-excursion 0))

(put 'unwind-protect 'byte-compile 'byte-compile-unwind-protect)
(defun byte-compile-unwind-protect (form)
  (byte-compile-push-constant
    (list (byte-compile-top-level (cons 'progn (cdr (cdr form))))))
  (setq byte-compile-depth (1- byte-compile-depth))
  (byte-compile-out 'byte-unwind-protect 0)
  (byte-compile-form (car (cdr form)))
  (setq byte-compile-depth (1- byte-compile-depth))
  (byte-compile-out 'byte-unbind 1))

(put 'condition-case 'byte-compile 'byte-compile-condition-case)
(defun byte-compile-condition-case (form)
  (byte-compile-push-constant (car (cdr form)))
  (byte-compile-push-constant (byte-compile-top-level (nth 2 form)))
  (let ((clauses (cdr (cdr (cdr form))))
	compiled-clauses)
    (while clauses
      (let ((clause (car clauses)))
	(setq compiled-clauses
	      (cons (list (car clause)
			  (byte-compile-top-level (cons 'progn (cdr clause))))
		    compiled-clauses)))
      (setq clauses (cdr clauses)))
    (byte-compile-push-constant (nreverse compiled-clauses)))
  (setq byte-compile-depth (- byte-compile-depth 3))
  (byte-compile-out 'byte-condition-case 0))

(defun byte-compile-make-tag ()
  (cons nil nil))

(defun byte-compile-out-tag (tag)
  (let ((uses (car tag)))
    (setcar tag byte-compile-pc)
    (while uses
      (byte-compile-store-goto (car uses) byte-compile-pc)
      (setq uses (cdr uses)))))

(defun byte-compile-goto (opcode tag)
  (byte-compile-out opcode 0)
  (if (integerp (car tag))
      (byte-compile-store-goto byte-compile-pc (car tag))
    (setcar tag (cons byte-compile-pc (car tag))))
  (setq byte-compile-pc (+ byte-compile-pc 2)))

(defun byte-compile-store-goto (at-pc to-pc)
  (setq byte-compile-output
	(cons (cons at-pc (logand to-pc 255))
	      byte-compile-output))
  (setq byte-compile-output
	(cons (cons (1+ at-pc) (lsh to-pc -8))
	      byte-compile-output)))

(defun byte-compile-out (opcode offset)
  (setq opcode (eval opcode))
  (if (< offset 6)
      (byte-compile-out-1 (+ opcode offset))
    (if (< offset 256)
	(progn
	  (byte-compile-out-1 (+ opcode 6))
	  (byte-compile-out-1 offset))
      (byte-compile-out-1 (+ opcode 7))
      (byte-compile-out-1 (logand offset 255))
      (byte-compile-out-1 (lsh offset -8)))))

(defun byte-compile-out-const (offset)
  (if (< offset byte-constant-limit)
      (byte-compile-out-1 (+ byte-constant offset))
    (byte-compile-out-1 byte-constant2)
    (byte-compile-out-1 (logand offset 255))
    (byte-compile-out-1 (lsh offset -8))))

(defun byte-compile-out-1 (code)
  (setq byte-compile-output
	(cons (cons byte-compile-pc code)
	      byte-compile-output))
  (setq byte-compile-pc (1+ byte-compile-pc)))

;;; by [e-mail]
;;;  Only works noninteractively.
(defun batch-byte-compile ()
  "Runs byte-compile-file on the files remaining on the command line.
Must be used only with -batch, and kills emacs on completion.
Each file will be processed even if an error occurred previously.
For example, invoke \"emacs -batch -f batch-byte-compile $emacs/ ~/*.el\""
  ;; command-line-args-left is what is left of the command line (from startup.el)
  (if (not noninteractive)
      (error "batch-byte-compile is to be used only with -batch"))
  (let ((error nil))
    (while command-line-args-left
      (if (file-directory-p (expand-file-name (car command-line-args-left)))
	  (let ((files (directory-files (car command-line-args-left)))
		source dest)
	    (while files
	      (if (and (string-match ".el$" (car files))
		       (not (auto-save-file-name-p (car files)))
		       (setq source (expand-file-name (car files)
						      (car command-line-args-left)))
		       (setq dest (concat (file-name-sans-versions source) "c"))
		       (file-exists-p dest)
		       (file-newer-than-file-p source dest))
		  (if (null (batch-byte-compile-file source))
		      (setq error t)))
	      (setq files (cdr files))))
	(if (null (batch-byte-compile-file (car command-line-args-left)))
	    (setq error t)))
      (setq command-line-args-left (cdr command-line-args-left)))
    (message "Done")
    (kill-emacs (if error 1 0))))

(defun batch-byte-compile-file (file)
  (condition-case err
      (progn (byte-compile-file file) t)
    (error
     (message (if (cdr err)
		  ">>Error occurred processing %s: %s (%s)"
		  ">>Error occurred processing %s: %s")
	      file
	      (get (car err) 'error-message)
	      (prin1-to-string (cdr err)))
     nil)))