bytecomp.el

早期freebsd实现

		(body (cdr (cdr form)))
		(tail binds))
	   (while tail
	     (if (symbolp (car tail))
		 (if (not (memq (car tail) all-vars))
		     (setq all-vars (cons (car tail) all-vars)))
	       (if (consp (car tail))
		   (progn
		     (if (not (memq (car (car tail)) all-vars))
			 (setq all-vars (cons (car (car tail)) all-vars)))
		     (setcar tail
			     (list (car (car tail))
				   (byte-compile-find-vars-1 (car (cdr (car tail)))))))))
	     (setq tail (cdr tail)))
	   (cons (car form)
		 (cons binds
		       (mapcar 'byte-compile-find-vars-1 body)))))
	((or (eq (car form) 'function)
	     ;; Because condition-case is compiled by breaking out
	     ;; all its subexpressions and compiling them separately,
	     ;; we regard it here as containing nothing but constants.
	     (eq (car form) 'condition-case))
	 form)
	((eq (car form) 'catch)
	 ;; catch is almost like condition case, but we
	 ;; treat its first argument normally.
	 (cons 'catch
	       (cons (byte-compile-find-vars-1 (nth 1 form))
		     (nthcdr 2 form))))
	((eq (car form) 'cond)
	 (let* ((clauses (copy-sequence (cdr form)))
		(tail clauses))
	   (while tail
	     (setcar tail (mapcar 'byte-compile-find-vars-1 (car tail)))
	     (setq tail (cdr tail)))
	   (cons 'cond clauses)))
	((not (eq form (setq form (macroexpand form byte-compile-macro-environment))))
	 (byte-compile-find-vars-1 form))
	((symbolp (car form))
	 (cons (car form) (mapcar 'byte-compile-find-vars-1 (cdr form))))
	(t (mapcar 'byte-compile-find-vars-1 form))))

;; This is the recursive entry point for compiling each subform of an expression.

;; Note that handler functions SHOULD NOT increment byte-compile-depth
;; for the values they are returning!  That is done on return here.
;; Handlers should make sure that the depth on exit is the same as
;; it was when the handler was called.

(defun byte-compile-form (form)
  (setq form (macroexpand form byte-compile-macro-environment))
  (cond ((eq form 'nil)
	 (byte-compile-constant form))
	((eq form 't)
	 (byte-compile-constant form))
	((symbolp form)
	 (byte-compile-variable-ref 'byte-varref form))
	((not (consp form))
	 (byte-compile-constant form))
	((not (symbolp (car form)))
	 (if (eq (car-safe (car form)) 'lambda)
	     (let ((vars (nth 1 (car form)))
		   (vals (cdr form))
		   result)
	       (while vars
		 (setq result (cons (list (car vars) (car vals)) result))
		 (setq vars (cdr vars) vals (cdr vals)))
	       (byte-compile-form
		(cons 'let (cons (nreverse result) (cdr (cdr (car form)))))))
	   (byte-compile-normal-call form)))
	(t
	 (let ((handler (get (car form) 'byte-compile)))
	   (if handler
	       (funcall handler form)
	     (byte-compile-normal-call form)))))
  (setq byte-compile-maxdepth
	(max byte-compile-maxdepth
	     (setq byte-compile-depth (1+ byte-compile-depth)))))

(defun byte-compile-normal-call (form)
  (byte-compile-push-constant (car form))
  (let ((copy (cdr form)))
    (while copy (byte-compile-form (car copy)) (setq copy (cdr copy))))
  (byte-compile-out 'byte-call (length (cdr form)))
  (setq byte-compile-depth (- byte-compile-depth (length (cdr form)))))

(defun byte-compile-variable-ref (base-op var)
  (let ((data (assq var byte-compile-constants)))
    (if data
	(byte-compile-out base-op (cdr data))
      (error (format "Variable %s seen on pass 2 of byte compiler but not pass 1"
		     (prin1-to-string var))))))

;; Use this when the value of a form is a constant,
;; because byte-compile-depth will be incremented accordingly
;; on return to byte-compile-form, so it should not be done by the handler.
(defun byte-compile-constant (const)
  (let ((data (if (stringp const)
		  (assoc const byte-compile-constants)
		(assq const byte-compile-constants))))
    (if data
	(byte-compile-out-const (cdr data))
      (setq byte-compile-constants
	    (cons (cons const (setq byte-compile-constnum (1+ byte-compile-constnum)))
		  byte-compile-constants))
      (byte-compile-out-const byte-compile-constnum))))

;; Use this for a constant that is not the value of its containing form.
;; Note that the calling function must explicitly decrement byte-compile-depth
;; (or perhaps call byte-compile-discard to do so)
;; for the word pushed by this function.
(defun byte-compile-push-constant (const)
  (byte-compile-constant const)
  (setq byte-compile-maxdepth
	(max byte-compile-maxdepth
	     (setq byte-compile-depth (1+ byte-compile-depth)))))

;; Compile those primitive ordinary functions
;; which have special byte codes just for speed.

(put 'point 'byte-compile 'byte-compile-no-args)
(put 'point 'byte-opcode 'byte-point)

(put 'dot 'byte-compile 'byte-compile-no-args)
(put 'dot 'byte-opcode 'byte-point)

;(put 'mark 'byte-compile 'byte-compile-no-args)
;(put 'mark 'byte-opcode 'byte-mark)

(put 'point-max 'byte-compile 'byte-compile-no-args)
(put 'point-max 'byte-opcode 'byte-point-max)

(put 'point-min 'byte-compile 'byte-compile-no-args)
(put 'point-min 'byte-opcode 'byte-point-min)

(put 'dot-max 'byte-compile 'byte-compile-no-args)
(put 'dot-max 'byte-opcode 'byte-point-max)

(put 'dot-min 'byte-compile 'byte-compile-no-args)
(put 'dot-min 'byte-opcode 'byte-point-min)

(put 'following-char 'byte-compile 'byte-compile-no-args)
(put 'following-char 'byte-opcode 'byte-following-char)

(put 'preceding-char 'byte-compile 'byte-compile-no-args)
(put 'preceding-char 'byte-opcode 'byte-preceding-char)

(put 'current-column 'byte-compile 'byte-compile-no-args)
(put 'current-column 'byte-opcode 'byte-current-column)

(put 'eolp 'byte-compile 'byte-compile-no-args)
(put 'eolp 'byte-opcode 'byte-eolp)

(put 'eobp 'byte-compile 'byte-compile-no-args)
(put 'eobp 'byte-opcode 'byte-eobp)

(put 'bolp 'byte-compile 'byte-compile-no-args)
(put 'bolp 'byte-opcode 'byte-bolp)

(put 'bobp 'byte-compile 'byte-compile-no-args)
(put 'bobp 'byte-opcode 'byte-bobp)

(put 'current-buffer 'byte-compile 'byte-compile-no-args)
(put 'current-buffer 'byte-opcode 'byte-current-buffer)

(put 'read-char 'byte-compile 'byte-compile-no-args)
(put 'read-char 'byte-opcode 'byte-read-char)


(put 'symbolp 'byte-compile 'byte-compile-one-arg)
(put 'symbolp 'byte-opcode 'byte-symbolp)

(put 'consp 'byte-compile 'byte-compile-one-arg)
(put 'consp 'byte-opcode 'byte-consp)

(put 'stringp 'byte-compile 'byte-compile-one-arg)
(put 'stringp 'byte-opcode 'byte-stringp)

(put 'listp 'byte-compile 'byte-compile-one-arg)
(put 'listp 'byte-opcode 'byte-listp)

(put 'not 'byte-compile 'byte-compile-one-arg)
(put 'not 'byte-opcode 'byte-not)

(put 'null 'byte-compile 'byte-compile-one-arg)
(put 'null 'byte-opcode 'byte-not)

(put 'car 'byte-compile 'byte-compile-one-arg)
(put 'car 'byte-opcode 'byte-car)

(put 'cdr 'byte-compile 'byte-compile-one-arg)
(put 'cdr 'byte-opcode 'byte-cdr)

(put 'length 'byte-compile 'byte-compile-one-arg)
(put 'length 'byte-opcode 'byte-length)

(put 'symbol-value 'byte-compile 'byte-compile-one-arg)
(put 'symbol-value 'byte-opcode 'byte-symbol-value)

(put 'symbol-function 'byte-compile 'byte-compile-one-arg)
(put 'symbol-function 'byte-opcode 'byte-symbol-function)

(put '1+ 'byte-compile 'byte-compile-one-arg)
(put '1+ 'byte-opcode 'byte-add1)

(put '1- 'byte-compile 'byte-compile-one-arg)
(put '1- 'byte-opcode 'byte-sub1)

(put 'goto-char 'byte-compile 'byte-compile-one-arg)
(put 'goto-char 'byte-opcode 'byte-goto-char)

(put 'char-after 'byte-compile 'byte-compile-one-arg)
(put 'char-after 'byte-opcode 'byte-char-after)

(put 'set-buffer 'byte-compile 'byte-compile-one-arg)
(put 'set-buffer 'byte-opcode 'byte-set-buffer)

;set-mark turns out to be too unimportant for its own opcode.
;(put 'set-mark 'byte-compile 'byte-compile-one-arg)
;(put 'set-mark 'byte-opcode 'byte-set-mark)


(put 'eq 'byte-compile 'byte-compile-two-args)
(put 'eq 'byte-opcode 'byte-eq)
(put 'eql 'byte-compile 'byte-compile-two-args)
(put 'eql 'byte-opcode 'byte-eq)

(put 'memq 'byte-compile 'byte-compile-two-args)
(put 'memq 'byte-opcode 'byte-memq)

(put 'cons 'byte-compile 'byte-compile-two-args)
(put 'cons 'byte-opcode 'byte-cons)

(put 'aref 'byte-compile 'byte-compile-two-args)
(put 'aref 'byte-opcode 'byte-aref)

(put 'set 'byte-compile 'byte-compile-two-args)
(put 'set 'byte-opcode 'byte-set)

(put 'fset 'byte-compile 'byte-compile-two-args)
(put 'fset 'byte-opcode 'byte-fset)

(put '= 'byte-compile 'byte-compile-two-args)
(put '= 'byte-opcode 'byte-eqlsign)

(put '< 'byte-compile 'byte-compile-two-args)
(put '< 'byte-opcode 'byte-lss)

(put '> 'byte-compile 'byte-compile-two-args)
(put '> 'byte-opcode 'byte-gtr)

(put '<= 'byte-compile 'byte-compile-two-args)
(put '<= 'byte-opcode 'byte-leq)

(put '>= 'byte-compile 'byte-compile-two-args)
(put '>= 'byte-opcode 'byte-geq)

(put 'get 'byte-compile 'byte-compile-two-args)
(put 'get 'byte-opcode 'byte-get)

(put 'nth 'byte-compile 'byte-compile-two-args)
(put 'nth 'byte-opcode 'byte-nth)

(put 'aset 'byte-compile 'byte-compile-three-args)
(put 'aset 'byte-opcode 'byte-aset)

(defun byte-compile-no-args (form)
  (if (/= (length form) 1)
      ;; get run-time wrong-number-of-args error.
      ;; Would be nice if there were some way to do
      ;;  compile-time warnings.
      (byte-compile-normal-call form)
    (byte-compile-out (symbol-value (get (car form) 'byte-opcode)) 0)))

(defun byte-compile-one-arg (form)
  (if (/= (length form) 2)
      (byte-compile-normal-call form)
    (byte-compile-form (car (cdr form)))  ;; Push the argument
    (setq byte-compile-depth (1- byte-compile-depth))
    (byte-compile-out (symbol-value (get (car form) 'byte-opcode)) 0)))

(defun byte-compile-two-args (form)
  (if (/= (length form) 3)
      (byte-compile-normal-call form)
    (byte-compile-form (car (cdr form)))  ;; Push the arguments
    (byte-compile-form (nth 2 form))
    (setq byte-compile-depth (- byte-compile-depth 2))
    (byte-compile-out (symbol-value (get (car form) 'byte-opcode)) 0)))

(defun byte-compile-three-args (form)
  (if (/= (length form) 4)
      (byte-compile-normal-call form)
    (byte-compile-form (car (cdr form)))  ;; Push the arguments
    (byte-compile-form (nth 2 form))
    (byte-compile-form (nth 3 form))
    (setq byte-compile-depth (- byte-compile-depth 3))
    (byte-compile-out (symbol-value (get (car form) 'byte-opcode)) 0)))

(put 'substring 'byte-compile 'byte-compile-substring)
(defun byte-compile-substring (form)
  (if (or (> (length form) 4)
	  (< (length form) 2))
      (byte-compile-normal-call form)
    (byte-compile-form (nth 1 form))
    (byte-compile-form (or (nth 2 form) ''nil))	;Optional arguments
    (byte-compile-form (or (nth 3 form) ''nil))
    (setq byte-compile-depth (- byte-compile-depth 3))
    (byte-compile-out byte-substring 0)))

(put 'interactive-p 'byte-compile 'byte-compile-interactive-p)
(defun byte-compile-interactive-p (form)
  (byte-compile-out byte-interactive-p 0))
  
(put 'list 'byte-compile 'byte-compile-list)
(defun byte-compile-list (form)
  (let ((len (length form)))
    (if (= len 1)
	(byte-compile-constant nil)
      (if (< len 6)
	  (let ((args (cdr form)))
	   (while args
	     (byte-compile-form (car args))
	     (setq args (cdr args)))
	   (setq byte-compile-depth (- byte-compile-depth (1- len)))
	   (byte-compile-out (symbol-value
			      (nth (- len 2)
				   '(byte-list1 byte-list2 byte-list3 byte-list4)))
			     0))
	(byte-compile-normal-call form)))))

(put 'concat 'byte-compile 'byte-compile-concat)
(defun byte-compile-concat (form)
  (let ((len (length form)))
    (cond ((= len 1)
	   (byte-compile-form ""))
	  ((= len 2)
	   ;; Concat of one arg is not a no-op if arg is not a string.
	   (byte-compile-normal-call form))
	  ((< len 6)
	   (let ((args (cdr form)))
	     (while args
	       (byte-compile-form (car args))
	       (setq args (cdr args)))
	     (setq byte-compile-depth (- byte-compile-depth (1- len)))
	     (byte-compile-out
	       (symbol-value (nth (- len 3)
				  '(byte-concat2 byte-concat3 byte-concat4)))
	       0)))
	  (t
	   (byte-compile-normal-call form)))))

(put '- 'byte-compile 'byte-compile-minus)
(defun byte-compile-minus (form)
  (let ((len (length form)))
    (cond ((= len 2)
	   (byte-compile-form (car (cdr form)))
	   (setq byte-compile-depth (- byte-compile-depth 1))
	   (byte-compile-out byte-negate 0))
	  ((= len 3)
	   (byte-compile-form (car (cdr form)))
	   (byte-compile-form (nth 2 form))
	   (setq byte-compile-depth (- byte-compile-depth 2))
	   (byte-compile-out byte-diff 0))
	  (t (byte-compile-normal-call form)))))

(put '+ 'byte-compile 'byte-compile-maybe-two-args)
(put '+ 'byte-opcode 'byte-plus)

(put 'max 'byte-compile 'byte-compile-maybe-two-args)
(put 'max 'byte-opcode 'byte-max)

(put 'min 'byte-compile 'byte-compile-maybe-two-args)
(put 'min 'byte-opcode 'byte-min)

(defun byte-compile-maybe-two-args (form)
  (let ((len (length form)))
    (if (= len 3)
	(progn
	  (byte-compile-form (car (cdr form)))
	  (byte-compile-form (nth 2 form))
	  (setq byte-compile-depth (- byte-compile-depth 2))
	  (byte-compile-out (symbol-value (get (car form) 'byte-opcode)) 0))
      (byte-compile-normal-call form))))
	
(put 'function 'byte-compile 'byte-compile-function-form)
(defun byte-compile-function-form (form)
  (cond ((symbolp (car (cdr form)))