/lisp/compile.l

Large files files are truncated, but you can click here to view the full file

;;; -*- Mode: Lisp; Package: COMPILER -*-
;;;
;;; This file is part of xyzzy.
;;;

(provide "compile")

;;; OPE-CODES
;;;  LEXICAL-REF: レキシカル変数の参照    (LEXICAL-REF (<SYMBOL> <SPECIAL-P> <REF-CLOSURE-P>))
;;;  GLOBAL-REF: グローバル変数の参照     (GLOBAL-REF <SYMBOL>)
;;;  LEXICAL-SET: レキシカル変数の設定    (LEXICAL-SET (<SYMBOL> <SPECIAL-P> <REF-CLOSURE-P>))
;;;  GLOBAL-SET: グローバル変数の設定     (GLOBAL-SET <SYMBOL>)
;;;  CONSTANT: 自己参照型                 (CONSTANT <OBJECT>)
;;;  CALL: 関数コール                     (CALL <FUNCTION> <NARGS>)
;;;  DISCARD: スタックポインタを1-        (DISCARD)
;;;  GOTO:                                (GOTO <TAG>)
;;;  IF-NIL-GOTO: stack[0]がnilならばgoto (IF-NIL-GOTO <TAG>)
;;;  IF-NIL-GOTO-AND-POP: stack[0]がnilならばgoto (IF-NIL-GOTO-AND-POP <TAG>)
;;;  IF-NON-NIL-GOTO: stack[0]がnon-nilならばgoto (IF-NON-NIL-GOTO <TAG>)
;;;  IF-NON-NIL-GOTO-AND-POP: stack[0]がnon-nilならばgoto (IF-NON-NIL-GOTO-AND-POP <TAG>)
;;;  LABEL:                                (LABEL <TAG>)
;;;  RETURN:                               (RETURN <TAG>)
;;;  GO:                                   (GO <TAG>)
;;;  ADJUST-STACK                          (ADJUST-STACK <STACK-DEPTH> <TAG>)
;;;  BLOCK                                 (BLOCK <TAG>)
;;;  SPECIAL                               (SPECIAL <TAG> {<VAR>}*)
;;;  SPECIAL-END
;;;  MULTIPLE-VALUE-SET                    (MULTIPLE-VALUE-SET <COUNT>)
;;;  MULTIPLE-VALUE-SET-END                (MULTIPLE-VALUE-SET-END)
;;;  LIST-MULTIPLE-VALUE
;;;  CALL-MULTIPLE-VALUE
;;;  SAVE-MULTIPLE-VALUE
;;;  TAGBODY
;;;  UNWIND-PROTECT
;;;  CATCH
;;;  THROW
;;;  MAKE-CLOSURE
;;;  SAVE-EXCURSION
;;;  SAVE-RESTRICTION
;;;  SAVE-WINDOW-EXCURSION

;;; OPTIMIZER
;;;  SET - DISCARD - REF        --->  SET
;;;  SET - DISCARD              --->  SET-DISCARD
;;;  REF - DISCARD              --->  none
;;;  CONSTANT - DISCARD         --->  none
;;;  NULL/NOT NULL/NOT          --->  none(無条件にやるのはまずい? まだやってないけど)
;;;  NULL/NOT - IF-NIL-GOTO     ---> IF-NON-NIL-GOTO (予定)
;;;  NULL/NOT - IF-NON-NIL-GOTO ---> IF-NIL-GOTO (予定)
;;;  jump optimize
;;;  omit unreached code
;;;  local return/go            ---> GOTO
;;;  constant folding

(lisp:in-package "lisp")

(eval-when (:compile-toplevel :load-toplevel :execute)
  (export '(compile-file byte-compile-file
	    byte-recompile-directory compile
	    mc-compile-file mc-byte-compile-file
	    mc-byte-recompile-directory)))

(eval-when (:compile-toplevel :load-toplevel :execute)
  (unless (find-package "compiler")
    (defpackage "compiler"
      (:use "lisp" "editor")
      (:internal-size 200)
      (:external-size 10))))

(in-package "compiler")

(let ()
  ;; *MACRO-ENVIRONMENT*: defmacro(コンパイル単位)と
  ;; ローカルな関数・マクロのリスト
  (defvar *macro-environment* nil)

  ;; *SPECIAL-VARIABLES*: スペシャル変数のリスト(コンパイル単位)
  (defvar *special-variables* nil)

  ;; *CONSTANT-VARIABLES*: 定数変数のリスト(コンパイル単位)
  ;; (SYMBOL . VALUE)
  (defvar *constant-variables* nil)

  ;; *STACK-DEPTH*: 現在のスタックの深さ
  (defvar *stack-depth* 0)

  ;; *STACK-DEPTH-MAX*: 最大のスタックの深さ
  (defvar *stack-depth-max* 0)

  ;; *VARIABLE-LIST*: 束縛変数のリスト
  (defvar *variable-list* nil)

  ;; *BOUND-VARS*: 束縛変数のリスト
  (defvar *bound-vars* nil)

  ;; *STACK-FRAME-INDEX*:
  (defvar *stack-frame-index* 0)

  ;; *STACK-FRAME-MAX*: 同時に有効になる束縛変数の個数の最大値
  (defvar *stack-frame-max* 0)

  ;; *BLOCK-ENVIRONMENT*: block環境のリスト
  (defvar *block-environment* nil)

  ;; *TAGBODY-ENVIRONMENT*: tagbody環境のリスト
  (defvar *tagbody-environment* nil)

  ;; *INSN-LIST*: 中間コードのリスト
  (defvar *insn-list* nil)

  (defvar *compile-time-too* nil))

(let ()
  (setf (get 'defun 'toplevel-macro) 'print-defun)
  (setf (get 'defmacro 'toplevel-macro) 'print-form)
  (setf (get 'defconstant 'toplevel-macro) 'print-form)
  (setf (get 'defvar 'toplevel-macro) 'print-form)
  (setf (get 'defparameter 'toplevel-macro) 'print-form)

  (setf (get 'defmacro 'compiler-effect) 'record-defmacro)
  (setf (get 'defconstant 'compiler-effect) 'record-defconstant)
  (setf (get 'defvar 'compiler-effect) 'record-defvar)
  (setf (get 'defparameter 'compiler-effect) 'record-defvar)

  (setf (get 'quote 'special-form) 'compile-quote)
  (setf (get 'function 'special-form) 'compile-function)
  (setf (get 'progn 'special-form) 'compile-progn)
  (setf (get 'let 'special-form) 'compile-let)
  (setf (get 'let* 'special-form) 'compile-let*)
  (setf (get 'if 'special-form) 'compile-if)
  (setf (get 'setq 'special-form) 'compile-setq)
  (setf (get 'block 'special-form) 'compile-block)
  (setf (get 'return-from 'special-form) 'compile-return-from)
  (setf (get 'tagbody 'special-form) 'compile-tagbody)
  (setf (get 'go 'special-form) 'compile-go)
  (setf (get 'unwind-protect 'special-form) 'compile-unwind-protect)
  (setf (get 'catch 'special-form) 'compile-catch)
  (setf (get 'throw 'special-form) 'compile-throw)
  (setf (get 'eval-when 'special-form) 'compile-eval-when)
  (setf (get 'multiple-value-call 'special-form) 'compile-multiple-value-call)
  (setf (get 'multiple-value-prog1 'special-form) 'compile-multiple-value-prog1)
  (setf (get 'multiple-value-bind 'special-form) 'compile-multiple-value-bind)
  (setf (get 'multiple-value-setq 'special-form) 'compile-multiple-value-setq)
  (setf (get 'save-excursion 'special-form) 'compile-save-excursion)
  (setf (get 'save-restriction 'special-form) 'compile-save-restriction)
  (setf (get 'save-window-excursion 'special-form) 'compile-save-window-excursion)

  (setf (get 'flet 'special-form) 'compile-flet)
  (setf (get 'labels 'special-form) 'compile-labels)
  (setf (get 'macrolet 'special-form) 'compile-macrolet)
  (setf (get '*compile-flet-bind 'special-form) '*compile-flet-bind))

(defun byte-compile-file (filename)
  (interactive "fByte compile file: " :title0 "Byte compile file")
  (long-operation
    (compile-file filename)))

(defun mc-byte-compile-file (filename &optional encoding)
  (interactive "fByte compile file: \n0zEncoding: " :title0 "Byte compile file")
  (long-operation
    (mc-compile-file filename encoding)))

(defun byte-recompile-directory (dirname &optional arg)
  (interactive "DByte compile directory: \np")
  (byte-recompile-directory-1 dirname arg #'compile-file))

(defun mc-byte-recompile-directory (dirname &optional arg)
  (interactive "DByte compile directory: \np")
  (byte-recompile-directory-1 dirname arg #'mc-compile-file))

(defun byte-recompile-directory-1 (dirname arg compile-fn)
  (long-operation
    (let ((count 0))
      (dolist (src (mapcan #'(lambda (ext)
			       (directory (merge-pathnames ext dirname) :absolute t))
			   '("*.l" "*.lisp")))
	(let ((dst (compile-file-pathname src)))
	  (when (if (file-exist-p dst)
		    (file-newer-than-file-p src dst)
		  (and arg (yes-no-or-cancel-p "~Aをコンパイルしますか?" src)))
	    (funcall compile-fn src)
	    (setq count (1+ count)))))
      (format t "Total ~[No~:;~:*~d~] file~:*~p compiled~%" count)
      count)))

(defun compile-file (filename)
  (with-open-file (is filename :direction :input :if-does-not-exist :error)
    (compile-file-1 filename is)))

(defun mc-compile-file (filename &optional encoding)
  (unless (file-exist-p filename)
    (error 'file-not-found
      :datum "ファイルが見つかりません"
      :pathname filename))
  (let (buffer)
    (unwind-protect
	(ed:save-excursion
	  (setq buffer (ed:create-new-buffer " *compile file*"))
	  (ed:set-buffer buffer)
	  (let ((ed:*expected-fileio-encoding*
		 (or encoding
		     (ed::find-file-auto-encoding filename)
		     ed:*expected-fileio-encoding*)))
	    (declare (special ed:*expected-fileio-encoding*))
	    (ed:insert-file-contents filename t)
	    (compile-file-1 filename (ed:make-buffer-stream buffer)
			    (cadr (assoc (ed:buffer-fileio-encoding) ed:*character-set-alist*
					 :key #'symbol-value)))))
      (when buffer
	(ed:delete-buffer buffer)))))

(defun compile-file-1 (filename is &optional encoding)
  (setq filename (namestring filename))
  (with-open-file (os (compile-file-pathname filename)
		      :direction :output
		      :if-exists :supersede
		      :if-does-not-exist :create)
    (when encoding
      (format os ";;; -*- Mode: Lisp; Encoding: ~A; -*-~%" encoding))
    (let ((*macro-environment* nil)
	  (*special-variables* nil)
	  (*constant-variables* nil)
	  (*compile-time-too* nil)
	  (*package* *package*))
      (let ((eof (make-symbol "eof"))
	    form)
	(while (setq form (read is nil eof))
	  (if (eq form eof)
	      (return))
	  (let ((opackage *package*))
	    (setq form (process-toplevel form))
	    (let ((*package* opackage))
	      (if (and (consp form)
		       (eq (car form) 'progn))
		  (dolist (f (cdr form))
		    (unless (constant-variable-p f)
		      (write f :stream os :escape t :circle t)
		      (terpri os)))
		(unless (constant-variable-p form)
		  (write form :stream os :escape t :circle t)
		  (terpri os)))))))))
  (princ "done.\n")
  t)

(defun compile (name &optional definition)
  (setq definition
	(coerce (or definition
		    (setq definition (symbol-function name)))
		'function))
  (cond ((compiled-function-p definition))
	((and (listp definition)
	      (eq (car definition) 'macro)))
	((si:*closurep definition)
	 (when (or (si:closure-variable definition)
		   (si:closure-function definition)
		   (si:closure-frame definition))
	   (error "空でない環境で定義された関数はコンパイルできません"))
	 (let ((*macro-environment* nil)
	       (*special-variables* nil)
	       (*constant-variables* nil)
	       (*stack-depth* 0)
	       (*stack-depth-max* 0)
	       (*variable-list* nil)
	       (*bound-vars* nil)
	       (*stack-frame-index* 0)
	       (*stack-frame-max* 0)
	       (*block-environment* nil)
	       (*tagbody-environment* nil)
	       (*insn-list* nil)
	       (form (si:closure-body definition)))
	   (multiple-value-bind (decl intr nargs)
	       (compile-lambda form)
	     (setq definition
		   (coerce `(lambda ,(cadr form) ,@decl ,@intr
			      ,(output-bytecode
				(optimize-insn (nreverse *insn-list*))
				nargs))
			   'function)))))
	(t
	 (error "~Sはコンパイルできません" definition)))
  (if (null name)
      definition
    (progn
      (setf (symbol-function name) definition)
      name)))

(defun print-defun (f)
  (format t "Compiling ~S...~%" (cadr f)))

(defun print-form (f)
  (format t "~S...~%" f))

(defun record-defmacro (form)
  (when (special-form-p (cadr form))
    (error 'invalid-function :datum (cadr form)))
  (push (cons (cadr form)
	      (cons 'macro (cddr form)))
	*macro-environment*)
  form)

(defun record-defconstant (form)
  (let ((symbol (cadr form))
	(value (eval (caddr form))))
    (check-type symbol symbol)
    (unless (constantp symbol)
      (set symbol value))
    (push (cons symbol value) *constant-variables*)
    (push symbol *special-variables*)
    form))

(defun record-defvar (form)
  (let ((symbol (cadr form)))
    (check-type symbol symbol)
    (push symbol *special-variables*)
    form))

(defun output-insn (ope &rest args)
  (push (cons ope args) *insn-list*))

(defun output-label (tag)
  (push (list 'insn-label tag) *insn-list*))

(defun update-stack (l)
  (incf *stack-depth* l)
  (setq *stack-depth-max* (max *stack-depth* *stack-depth-max*)))

;;; VARが定数変数?
(defun constant-variable-p (var)
  (or (constantp var)
      (assoc var *constant-variables* :test #'eq)))

(defmacro bound-var-symbol (x) `(car ,x))
(defmacro bound-var-special-p (x) `(cadr ,x))
(defmacro bound-var-refered-from-closure-p (x) `(caddr ,x))
(defmacro bound-var-stack-frame-index (x) `(cadddr ,x))

;;; VARがグローバルなスペシャル変数?
(defun global-special-p (var)
  (or (si:*specialp var)
      (member var *special-variables* :test #'eq)))

;;; 変数を作る: (SYMBOL SPECIALP <closureから参照された?> <stack frameのインデックス>)
(defun make-variable (var)
  (unless (symbolp var)
    (compile-error "Wrong type argument: ~S" var))
  (when (constant-variable-p var)
    (compile-error "Attempt to modify constant: ~S" var))
  (let ((x (list var nil nil nil)))
    (push x *variable-list*)
    x))

;;; 変数にスタックフレームのインデックスをセットする
(defun make-stack-frame (vars)
  (dolist (var vars)
    (setf (bound-var-stack-frame-index var) *stack-frame-index*)
    (incf *stack-frame-index*))
  (setq *stack-frame-max* (max *stack-frame-max* *stack-frame-index*)))

;;; シンボルVARの値を得る。
(defun compile-varref (var)
  (let ((closurep nil))
    (dolist (l *bound-vars* 'nil)
      (if (eq l 'closure)
	  (setq closurep t)
	(let ((v (assoc var l :test #'eq)))
	  (when v
	    (if (bound-var-special-p v)
		(return))
	    (output-insn 'insn-lexical-ref v)
	    (if closurep
		(setf (bound-var-refered-from-closure-p v) 't))
	    (return-from compile-varref)))))
    (if (constant-variable-p var)
	(let ((value (assoc var *constant-variables* :test #'eq)))
	  (setq value (if value (cdr value) (symbol-value var)))
	  (if (or (integerp value)
		  (floatp value)
		  (characterp value)
		  (and (symbolp value)
		       (symbol-package value)))
	      (compile-constant value)
	    (output-insn 'insn-global-ref var)))
      (output-insn 'insn-global-ref var))))

;;; シンボルVARに値をセットする
(defun compile-varset (var)
  (check-type var symbol)
  (cond ((constant-variable-p var)
	 (compile-error 'modify-constant :name var))
	((let ((closurep nil))
	   (dolist (l *bound-vars* 'nil)
	     (if (eq l 'closure)
		 (setq closurep t)
	       (let ((v (assoc var l :test #'eq)))
		 (when v
		   (if (bound-var-special-p v)
		       (return 'nil))
		   (output-insn 'insn-lexical-set v)
		   (if closurep
		       (setf (bound-var-refered-from-closure-p v) 't))
		   (return 't)))))))
	(t
	 (output-insn 'insn-global-set var))))

;;; 自己評価フォームを出力
(defun compile-constant (object)
  (output-insn 'insn-constant object))

;;; スペシャル宣言された束縛変数を集める。
(defun process-declare (decl)
  (let ((decls '())
	(specials '()))
    (dolist (d decl)
      (dolist (l (cdr d))
	(if (eq (car l) 'special)
	    (dolist (x (cdr l))
	      (if (symbolp x)
		  (push x decls))))))
    (dolist (v (car *bound-vars*))
      (when (global-special-p (car v))
	(push v specials)))
    (dolist (d decls)
      (unless (or (global-special-p d)
		  (assoc d specials :test #'eq))
	(dolist (l *bound-vars*)
	  (let ((v (assoc d l :test #'eq)))
	    (when v
	      (push v specials)
	      (return))))))
    specials))

;;; スペシャル宣言された束縛変数にマークをつける。
(defun mark-special-vars (specials)
  (dolist (v specials)
    (setf (bound-var-special-p v) 't)))

;;; ブロックを確立する: (<識別子> <TAG> <closureから参照された?>)
(defun estab-block (name)
  (let ((x (list name (make-tag (gensym "BLOCK")) 'nil)))
    (output-insn 'insn-block x)
    (push x *block-environment*)))

;;; ブロックを解除する。
(defun unestab-block ()
  (let ((x (pop *block-environment*)))
    (output-label (cadr x))))

;;; NAMEにマッチするブロックのTAGを返す。
(defun find-block (name)
  (let ((closurep nil))
    (dolist (x *block-environment*)
      (cond ((eq x 'closure)
	     (setq closurep t))
	    ((eq (car x) name)
	     (if closurep
		 (setf (caddr x) t))
	     (return-from find-block (values x closurep))))))
  (compile-error 'no-target :operation 'return-from :target name))

;;; タグを作る (<識別子> <stack-depth> <closureから参照された?>)
(defun make-tag (&optional (name (gensym "TAG")))
  (list name *stack-depth* 'nil))

;;; NAMEにマッチするtabgodyのTAGを返す。
(defun find-tagbody (name)
  (let ((closurep nil))
    (dolist (l *tagbody-environment*)
      (if (eq l 'closure)
	  (setq closurep t)
	(let ((x (assoc name l :test #'eq)))
	  (when x
	    (if closurep
		(setf (caddr x) t))
	    (return-from find-tagbody (values x closurep)))))))
  (compile-error 'no-target :operation 'go :target name))

(defun parse-lambda-list (arglist)
  (let ((lambda-keys '(&optional &rest &key &aux))
	(vars '())
	arg)
    (while (setq arg (pop arglist))
      (if (member arg lambda-keys :test #'eq)
	  (return))
      (push (make-variable arg) vars))
    (pop lambda-keys)
    (when (eq arg '&optional)
      (while (setq arg (pop arglist))
	(cond ((member arg lambda-keys :test #'eq)
	       (return))
	      ((symbolp arg)
	       (push (make-variable arg) vars))
	      ((consp arg)
	       (push (make-variable (car arg)) vars)
	       (when (caddr arg)
		 (push (make-variable (caddr arg)) vars)))
	      (t
	       (compile-error 'type-error
			      :datum arg
			      :expected-type '(or symbol cons))))))
    (pop lambda-keys)
    (when (eq arg '&rest)
      (setq arg (pop arglist))
      (push (make-variable arg) vars)
      (setq arg (pop arglist)))
    (pop lambda-keys)
    (when (eq arg '&key)
      (while (setq arg (pop arglist))
	(cond ((member arg lambda-keys :test #'eq)
	       (return))
	      ((symbolp arg)
	       (push (make-variable arg) vars))
	      ((consp arg)
	       (cond ((symbolp (car arg))
		      (push (make-variable (car arg)) vars))
		     ((consp (car arg))
		      (push (make-variable (cadar arg)) vars))
		     (t
		      (compile-error 'type-error
				     :expected-type '(or symbol cons)
				     :datum (car arg))))
	       (when (caddr arg)
		 (push (make-variable (caddr arg)) vars)))
	      (t
	       (compile-error 'type-error
			      :expected-type '(or symbol cons)
			      :datum arg)))))
    (when (eq arg '&aux)
      (while (setq arg (pop arglist))
	(cond ((symbolp arg)
	       (push (make-variable arg) vars))
	      ((consp arg)
	       (push (make-variable (car arg)) vars))
	      (t
	       (compile-error 'type-error
			      :expected-type '(or symbol cons)
			      :datum arg)))))
    vars))

(defun compile-lambda (form)
  (multiple-value-bind (decl body)
      (lisp::find-declaration (cddr form))
    (multiple-value-bind (intr body)
	(lisp::find-interactive body)
      (let* ((*stack-frame-index* *stack-frame-index*)
	     (args (parse-lambda-list (cadr form)))
	     (nargs (length args)))
	(push args *bound-vars*)
	(make-stack-frame args)
	(mark-special-vars (process-declare decl))
	(compile-progn body)
	(pop *bound-vars*)
	(values decl intr nargs)))))

(defun compile-closure (form)
  (let ((*stack-depth* 0)
	(*stack-depth-max* 0)
	(*stack-frame-index* 0)
	(*stack-frame-max* 0)
	(*insn-list* nil)
	decl
	intr
	nargs
	insn)
    (push 'closure *tagbody-environment*)
    (push 'closure *block-environment*)
    (push 'closure *bound-vars*)
    (multiple-value-setq (decl intr nargs) (compile-lambda form))
    (pop *bound-vars*)
    (pop *block-environment*)
    (pop *tagbody-environment*)
    (setq insn (optimize-insn (nreverse *insn-list*)))
    `(lambda ,(cadr form) ,@decl ,@intr ,(output-bytecode insn nargs))))

(defun compile-toplevel (fn form)
  (cond ((eq (car form) 'quote)
	 form)
	((and (eq (car form) 'function)
	      (symbolp (cadr form)))
	 form)
	(t
	 (let ((*stack-depth* 0)
	       (*stack-depth-max* 0)
	       (*variable-list* nil)
	       (*bound-vars* nil)
	       (*stack-frame-index* 0)
	       (*stack-frame-max* 0)
	       (*block-environment* nil)
	       (*tagbody-environment* nil)
	       (*insn-list* nil))
	   (compile-form form)
	   (output-bytecode (optimize-insn (nreverse *insn-list*)) 0)))))

(defun process-toplevel (f)
  (cond ((or (atom f)
	     (not (symbolp (car f))))
	 f)
	((eq (car f) 'progn)
	 (setq f (mapcan #'(lambda (x)
			    (setq x (process-toplevel x))
			    (if x (list x)))
			 (cdr f)))
	 (if (endp (cdr f))
	     (car f)
	   (cons 'progn f)))
	((eq (car f) 'eval-when)
	 (cond ((endp (cdr f))
		(compile-error "EVAL-WHENフォームの形式が不正です: ~S" f))
	       ((or (member :load-toplevel (cadr f) :test #'eq)
		    (member 'load (cadr f) :test #'eq))
		(let ((*compile-time-too*
		       (or (member :compile-toplevel (cadr f) :test #'eq)
			   (member 'compile (cadr f) :test #'eq)
			   (and (or (member :execute (cadr f) :test #'eq)
				    (member 'eval (cadr f) :test #'eq))
				*compile-time-too*))))
		  (process-toplevel (cons 'progn (cddr f)))))
	       ((or (member :compile-toplevel (cadr f) :test #'eq)
		    (member 'compile (cadr f) :test #'eq)
		    (and (or (member :execute (cadr f) :test #'eq)
			     (member 'eval (cadr f) :test #'eq))
			 *compile-time-too*))
		(mapc #'eval (cddr f))
		nil)
	       (t nil)))
	((eq (car f) 'quote)
	 f)
	(t
	 (let (tem)
	   (and (setq tem (get (car f) 'toplevel-macro))
		(funcall tem f))
	   (and (setq tem (get (car f) 'compiler-effect))
		(funcall tem f))
	   (setq tem (macroexpand-1 f *macro-environment*))
	   (unless (eq tem f)
	     (return-from process-toplevel (process-toplevel tem)))
	   (if *compile-time-too*
	       (eval f))
	   (setq tem (get (car f) 'special-form))
	   (if tem
	       (compile-toplevel tem f)
	     (cons (car f)
		   (mapcar #'(lambda (x)
			      (if (and (consp x)
				       (symbolp (car x))
				       (get (car x) 'special-form))
				  (compile-toplevel (get (car x) 'special-form) x)
				x))
			   (cdr f))))))))


(defun compile-call (form)
  (let ((f (assoc (car form) *macro-environment* :test #'eq)))
    (cond ((null f)
	   (when (and (consp (car form))
		      (eq (caar form) 'lambda))
	     (push 'funcall form))
	   (dolist (f (cdr form))
	     (compile-form f))
	   (output-insn 'insn-call (car form) (- (length form) 1)))
	  ((symbolp (cdr f))
	   (compile-form (cdr f))
	   (dolist (f (cdr form))
	     (compile-form f))
	   (output-insn 'insn-call 'funcall (length form)))
	  (t
	   (compile-error "不正な関数コールです: ~S" form)))))

(defun compile-form (form)
  (let ((ostack *stack-depth*))
    (cond ((symbolp form)
	   (compile-varref form))
	  ((consp form)
	   (if (symbolp (car form))
	       (let ((tem (get (car form) 'special-form)))
		 (cond (tem
			(funcall tem (cdr form)))
		       (t
			(and (setq tem (get (car form) 'compiler-effect))
			     (funcall tem form))
			(multiple-value-setq (form tem)
			  (macroexpand-1 form *macro-environment*))
			(if tem
			    (compile-form form)
			  (progn
			    (and (null (assoc (car form) *macro-environment*
					      :test #'eq))
				 (setq tem (get (car form) 'optimize-form))
				 (setq form (funcall tem form)))
			    (compile-call form))))))
	     (compile-call form)))
	  (t
	   (compile-constant form)))
    (setq *stack-depth* ostack)
    (update-stack 1)))

(defun compile-setq (form)
  (if (null form)
      (compile-form nil)
    (do ((f form (cddr f)))
	((endp f))
      (cond ((endp (cdr f))
	     (compile-error 'too-few-arguments))
	    (t
	     (compile-form (cadr f))
	     (compile-varset (car f))
	     (unless (endp (cddr f))
	       (decf *stack-depth*)
	       (output-insn 'insn-discard)))))))

(defun compile-progn (form)
  (compile-form (car form))
  (dolist (x (cdr form))
    (decf *stack-depth*)
    (output-insn 'insn-discard)
    (compile-form x)))

(defun compile-let (form)
  (if (endp form)
      (compile-error "LETフォームの形式が不正です: ~S" form))
  (multiple-value-bind (decl body)
      (lisp::find-declaration (cdr form))
    (let ((*stack-frame-index* *stack-frame-index*)
	  (varlist (car form))
	  (vars '())
	  (tag (make-tag (gensym "LET"))))
      (dolist (var varlist)
	(compile-form (if (consp var) (cadr var) 'nil)))
      (dolist (var varlist)
	(push (make-variable (if (consp var) (car var) var)) vars))
      (output-insn 'insn-lexical-bind (cons tag vars))
      (push vars *bound-vars*)
      (make-stack-frame vars)
      (dolist (var (reverse varlist))
	(compile-varset (if (consp var) (car var) var))
	(output-insn 'insn-discard))
      (decf *stack-depth* (length varlist))
      (let ((specials (process-declare decl)))
	(if specials
	    (progn
	      (output-insn 'insn-special (list* tag specials))
	      (dolist (v specials)
		(compile-varref (bound-var-symbol v)))
	      (output-insn 'insn-special-end)
	      (mark-special-vars specials)
	      (compile-progn body))
	  (compile-progn body)))
      (output-label tag)
      (pop *bound-vars*))))

;;;(defun compile-let* (form)
;;;  (if (endp form)
;;;      (compile-error "LET*フォームの形式が不正です: ~S" form))
;;;  (multiple-value-bind (decl body)
;;;      (lisp::find-declaration (cdr form))
;;;    (let ((*stack-frame-index* *stack-frame-index*)
;;;	  (varlist (car form))
;;;	  (vars '())
;;;	  (tag (make-tag (gensym "LET"))))
;;;      (push 'nil *bound-vars*)
;;;      (dolist (var varlist)
;;;	(push (make-variable (if (consp var) (car var) var)) vars))
;;;      (setq vars (nreverse vars))
;;;      (output-insn 'insn-lexical-bind (cons tag vars))
;;;      (dolist (var varlist)
;;;	(compile-form (if (consp var) (cadr var) 'nil))
;;;	(push (pop vars) (car *bound-vars*))
;;;	(decf *stack-depth*)
;;;	(compile-varset (if (consp var) (car var) var))
;;;	(output-insn 'insn-discard))
;;;      (make-stack-frame (car *bound-vars*))
;;;      (let ((specials (process-declare decl)))
;;;	(if specials
;;;	    (progn
;;;	      (output-insn 'insn-special (list* tag specials))
;;;	      (dolist (v specials)
;;;		(compile-varref (bound-var-symbol v)))
;;;	      (output-insn 'insn-special-end)
;;;	      (mark-special-vars specials)
;;;	      (compile-progn body))
;;;	  (compile-progn body)))
;;;      (output-label tag)
;;;      (pop *bound-vars*))))

(defun compile-let* (form)
  (if (endp form)
      (compile-error "LET*フォームの形式が不正です: ~S" form))
  (multiple-value-bind (decl body)
      (lisp::find-declaration (cdr form))
    (let ((*stack-frame-index* *stack-frame-index*)
	  (varlist (car form))
	  (vars '())
	  (tag (make-tag (gensym "LET"))))
      (push 'nil *bound-vars*)
      (dolist (var varlist)
	(push (make-variable (if (consp var) (car var) var)) vars))
      (setq vars (nreverse vars))
      (output-insn 'insn-lexical-bind (cons tag vars))
      (dolist (var varlist)
	(compile-form (if (consp var) (cadr var) 'nil))
	(let ((v (pop vars)))
	  (push v (car *bound-vars*))
	  (decf *stack-depth*)
	  (compile-varset (if (consp var) (car var) var))
	  (output-insn 'insn-discard)
	  (make-stack-frame (list v))))
      (let ((specials (process-declare decl)))
	(if specials
	    (progn
	      (output-insn 'insn-special (list* tag specials))
	      (dolist (v specials)
		(compile-varref (bound-var-symbol v)))
	      (output-insn 'insn-special-end)
	      (mark-special-vars specials)
	      (compile-progn body))
	  (compile-progn body)))
      (output-label tag)
      (pop *bound-vars*))))

(defun compile-multiple-value-bind (form)
  (if (or (endp form)
	  (endp (cdr form)))
      (compile-error "MULTIPLE-VALUE-BINDフォームの形式が不正です: ~S" form))
  (multiple-value-bind (decl body)
      (lisp::find-declaration (cddr form))
    (let ((*stack-frame-index* *stack-frame-index*)
	  (varlist (car form))
	  (vars '())
	  (tag (make-tag (gensym "MULTIPLE-VALUE-BIND"))))
      (compile-form (cadr form))         ; compile values-form
      (dolist (var varlist)
	(push (make-variable var) vars))
      (output-insn 'insn-lexical-bind (cons tag vars))
      (push vars *bound-vars*)
      (make-stack-frame vars)
      (output-insn 'insn-multiple-value-set (length vars))
      (dolist (var varlist)
	(compile-varset (if (consp var) (car var) var)))
      (output-insn 'insn-multiple-value-set-end)
      (output-insn 'insn-discard)
      (decf *stack-depth*)
      (let ((specials (process-declare decl)))
	(if specials
	    (progn
	      (output-insn 'insn-special (list* tag specials))
	      (dolist (v specials)
		(compile-varref (bound-var-symbol v)))
	      (output-insn 'insn-special-end)
	      (mark-special-vars specials)
	      (compile-progn body))
	  (compile-progn body)))
      (output-label tag)
      (pop *bound-vars*))))

(defun compile-multiple-value-setq (form)
  (if (or (endp form)
	  (not (listp form))
	  (endp (cdr form)))
      (compile-error "MULTIPLE-VALUE-SETQフォームの形式が不正です: ~S" form))
  (compile-form (cadr form))         ; compile values-form
  (output-insn 'insn-multiple-value-set (length (car form)))
  (dolist (var (car form))
    (compile-varset var))
  (output-insn 'insn-multiple-value-set-end))

(defun compile-multiple-value-call (form)
  (if (endp form)
      (compile-error "MULTIPLE-VALUE-CALLフォームの形式が不正です: ~S" form))
  (compile-form (car form))
  (compile-form 'nil)
  (dolist (f (cdr form))
    (compile-form f)
    (decf *stack-depth*)
    (output-insn 'insn-list-multiple-value))
  ;(decf *stack-depth*)
  (output-insn 'insn-call-multiple-value))

(defun compile-multiple-value-prog1 (form)
  (if (endp form)
      (compile-error "MULTIPLE-VALUE-PROG1フォームの形式が不正です: ~S" form))
  (let ((end-tag (make-tag (gensym "MV-PROG1"))))
    (compile-form (car form))
    (output-insn 'insn-save-multiple-value end-tag)
    (compile-progn (cdr form))
    ;(decf *stack-depth*)
    (output-insn 'insn-discard)
    (output-label end-tag)))

(defun compile-tagbody (form)
  (let ((end-tag (make-tag (gensym "TAGBODY")))
	tags)
    (dolist (f form)
      (if (or (integerp f) (symbolp f))
	  (push (make-tag f) tags)))
    (push tags *tagbody-environment*)
    (output-insn 'insn-tagbody end-tag tags)
    (dolist (f form)
      (if (or (integerp f) (symbolp f))
	  (output-label (assoc f tags :test #'eq))
	(progn
	  (compile-form f)
	  (decf *stack-depth*)
	  (output-insn 'insn-discard))))
    (pop *tagbody-environment*)
    (compile-form 'nil)
    (output-label end-tag)))

(defun compile-go (form)
  (if (or (endp form)
	  (not (endp (cdr form))))
      (compile-error "TAGBODYフォームの形式が不正です: ~S" form))
  (multiple-value-bind (goal closurep)
      (find-tagbody (car form))
    (if closurep
	(output-insn 'insn-go goal)
      (progn
	(unless (= (cadr goal) *stack-depth*)
	  (output-insn 'insn-adjust-stack (cadr goal)))
	(output-insn 'insn-goto goal)))))

(defun compile-block (form)
  (if (endp form)
      (compile-error "BLOCKフォームの形式が不正です: ~S" form))
  (check-type (car form) symbol)
  (estab-block (car form))
  (compile-progn (cdr form))
  (unestab-block))

(defun compile-return-from (form)
  (if (endp form)
      (compile-error "RETURN-FROMフォームの形式が不正です: ~S" form))
  (check-type (car form) symbol)
  (multiple-value-bind (goal closurep)
      (find-block (car form))
    (when (and (not closurep)
	       (/= (cadadr goal) *stack-depth*))
      (setq *stack-depth* (cadadr goal))
      (output-insn 'insn-adjust-stack *stack-depth*))
    (cond ((endp (cdr form))
	   (compile-form 'nil))
	  ((endp (cddr form))
	   (compile-form (cadr form)))
	  (t
	   (compile-error "RETURN-FROMフォームの形式が不正です: ~S" form)))
    (if closurep
	(output-insn 'insn-return goal)
      (output-insn 'insn-goto (cadr goal)))))

(defun compile-if (form)
  (let ((l (length form)))
    (cond ((= l 2)
	   (let ((donetag (make-tag)))
	     (compile-form (car form))
	     (output-insn 'insn-if-nil-goto donetag)
	     (decf *stack-depth*)
	     (compile-form (cadr form))
	     (output-label donetag)))
	  ((= l 3)
	   (let ((elsetag (make-tag))
		 (donetag (make-tag)))
	     (compile-form (car form))
	     (output-insn 'insn-if-nil-goto-and-pop elsetag)
	     (decf *stack-depth*)
	     (compile-form (cadr form))
	     (output-insn 'insn-goto donetag)
	     (decf *stack-depth*)
	     (output-label elsetag)
	     (compile-form (caddr form))
	     (output-label donetag)))
	  (t
	   (compile-error "IFフォームの形式が不正です: ~S" form)))))

(defun compile-quote (form)
  (unless (= (length form) 1)
    (compile-error "QUOTEフォームの形式が不正です: ~S" form))
  (compile-constant (car form)))

(defun compile-unwind-protect (form)
  (if (endp form)
      (compile-error "UNWIND-PROTECTフォームの形式が不正です: ~S" form))
  (let ((ctag (make-tag (gensym "CLEANUP")))
	(ptag (make-tag (gensym "PROTECT"))))
    (output-insn 'insn-unwind-protect ctag ptag)
    (compile-form (car form))
    (output-label ctag)
    (compile-progn (cdr form))
    ;(decf *stack-depth*)
    (output-insn 'insn-discard)  ; ???
    (output-label ptag)))

(defun compile-catch (form)
  (if (endp form)
      (compile-error "CATCHフォームの形式が不正です: ~S" form))
  (compile-form (car form))
  (decf *stack-depth*)
  (let ((tag (make-tag (gensym "CATCH"))))
    (output-insn 'insn-catch tag)
    (compile-progn (cdr form))
    (output-label tag)))

(defun compile-throw (form)
  (if (/= (length form) 2)
      (compile-error "THROWフォームの形式が不正です: ~S" form))
  (compile-form (cadr form))
  (compile-form (car form))
  ;;(decf *stack-depth*)
  (output-insn 'insn-throw))

(defun compile-eval-when (form)
  (if (endp form)
      (compile-error "EVAL-WHENフォームの形式が不正です: ~S" form))
  ;;(incf *stack-depth*)
  (if (or (member ':execute (car form) :test #'eq)
	  (member 'eval (car form) :test #'eq))
      (compile-progn (cdr form))
    (compile-form 'nil)))

(defun compile-function (form)
  (unless (= (length form) 1)
    (compile-error "FUNCTIONフォームの形式が不正です: ~S" form))
  ;;(incf *stack-depth*)
  (cond ((symbolp (car form))
	 (let ((f (assoc (car form) *macro-environment* :test #'eq)))
	   (cond ((null f)
		  (output-insn 'insn-function-symbol (car form)))
		 ((symbolp (cdr f))
		  (compile-form (cdr f)))
		 (t
		  (compile-error 'invalid-function
				 :datum (car form))))))
	((and (consp (car form))
	      (eq (caar form) 'lambda))
	 (output-insn 'insn-make-closure
		      (compile-closure (car form))))
	(t
	 (compile-error 'invalid-function :datum (car form)))))

(defun flet-temp-vars (fnam form)
  (when (or (endp form)
	    (endp (cdr form)))
    (compile-error "~Aフォームの形式が不正です: ~S" fnam form))
  (let ((env-vars '())
	(bind-forms '()))
    (dolist (def (car form))
      (when (or (endp def)
		(endp (cdr def)))
	(compile-error "~Aフォームの形式が不正です: ~S" fnam def))
      (let ((name (car def))
	    (body (cdr def)))
	(unless (symbolp name)
	  (compile-error "関数名が不正です: ~S" name))
	(when (or (endp body)
		  (not (listp (car body))))
	  (compile-error "不正な関数です: ~S" body))
	(let ((lambda-list (car body)))
	  (multiple-value-bind (decl body)
	      (lisp::find-declaration (cdr body))
	    (if (eq fnam 'macrolet)
		(push (cons name `(macro ,lambda-list ,@decl (block ,name ,@body)))
		      env-vars)
	      (let ((temp (gensym)))
		(push (cons name temp) env-vars)
		(multiple-value-bind (intr body)
		    (lisp::find-interactive body)
		  (push `(,temp #'(lambda ,lambda-list ,@decl ,@intr (block ,name ,@body)))
			bind-forms))))))))
    (values env-vars bind-forms)))

;;; DO NOT CALL THIS FUNCTION.
(defun *compile-flet-bind (vars)
  (setq *macro-environment* (append (car vars) *macro-environment*))
  (compile-form 'nil))

(defun compile-flet-unbind (vars)
  (dolist (x vars)
    (setq *macro-environment* (delete x *macro-environment* :test #'eq))))

(defun compile-flet (form)
  (multiple-value-bind (env-vars bind-forms)
      (flet-temp-vars 'flet form)
    (multiple-value-bind (decl body)
	(lisp::find-declaration (cdr form))
      (compile-form `(let ,bind-forms
		       (*compile-flet-bind ,env-vars)
		       ,@body)))
    (compile-flet-unbind env-vars)))

(defun compile-labels (form)
  (multiple-value-bind (env-vars bind-forms)
      (flet-temp-vars 'labels form)
    (multiple-value-bind (decl body)
	(lisp::find-declaration (cdr form))
      (compile-form `(let ,(mapcar #'car bind-forms)
		       (*compile-flet-bind ,env-vars)
		       ,@(mapcar #'(lambda (x) (cons 'setq x)) bind-forms)
		       ,@body)))
    (compile-flet-unbind env-vars)))

(defun compile-macrolet (form)
  (let ((vars (flet-temp-vars 'macrolet form)))
    (setq *macro-environment* (append vars *macro-environment*))
    (multiple-value-bind (decl body)
	(lisp::find-declaration (cdr form))
      (compile-progn body))
    (compile-flet-unbind vars)))

(defun compile-save-excursion (form)
  (let ((end-tag (make-tag (gensym "SAVE-EXCURSION"))))
    (output-insn 'insn-save-excursion end-tag)
    (compile-progn form)
    (output-label end-tag)))

(defun compile-save-restriction (form)
  (let ((end-tag (make-tag (gensym "SAVE-RESTRICTION"))))
    (output-insn 'insn-save-restriction end-tag)
    (compile-progn form)
    (output-label end-tag)))

(defun compile-save-window-excursion (form)
  (let ((end-tag (make-tag (gensym "SAVE-WINDOW-EXCURSION"))))
    (output-insn 'insn-save-window-excursion end-tag)
    (compile-progn form)
    (output-label end-tag)))

(defun compile-error (&rest r)
  (apply #'error r))

;;; optimize

(defun remove-nil-insns (insn)
  (mapcan #'(lambda (x) (if x (list x))) insn))

;;; closureから参照されないlet/block/tagbodyを削除する。
(defun remove-local-lexicals (insn)
  (let ((mod nil))
    (do ((i insn (cdr i)))
	((endp i))
      (when (or (and (eq (caar i) 'insn-block)
		     (not (caddr (cadar i))))
		(and (eq (caar i) 'insn-tagbody)
		     (not (setf (caddar i)
				(let ((tags '()))
				  (dolist (x (caddar i) tags)
				    (when (caddr x)
				      (push x tags)))))))
		(and (eq (caar i) 'insn-lexical-bind)
		     (not (setf (cdadar i)
				(let ((vars '()))
				  (dolist (x (cdadar i) vars)
				    (when (bound-var-refered-from-closure-p x)
				      (push x vars))))))))
	(setf (car i) 'nil)
	(setq mod t)))
    (if mod
	(remove-nil-insns insn)
      insn)))

(defun remove-duplicate-labels (insn)
  (do ((i insn (cdr i)))
      ((endp i))
    (when (eq (caar i) 'insn-label)
      (setf (cdr i)
	    (do* ((j (cdr i) (cdr j))
		  (op (car j) (car j)))
		((or (endp j)
		     (not (eq (car op) 'insn-label)))
		 j)
	      (nsubst (cadar i) (cadr op) insn :test #'eq)))))
  insn)

(let ()
  (setf (get 'insn-goto 'jump) 't)
  (setf (get 'insn-if-nil-goto 'jump) 't)
  (setf (get 'insn-if-nil-goto 'if-nil-goto) 't)
  (setf (get 'insn-if-non-nil-goto 'jump) 't)
  (setf (get 'insn-if-nil-goto-and-pop 'jump) 't)
  (setf (get 'insn-if-nil-goto-and-pop 'if-nil-goto) 't)
  (setf (get 'insn-if-nil-goto-and-pop 'goto-and-pop) 't)
  (setf (get 'insn-if-non-nil-goto-and-pop 'jump) 't)
  (setf (get 'insn-if-non-nil-goto-and-pop 'goto-and-pop) 't))

;;; ジャンプを最適化
(defun optimize-jump (insn)
  (let ((continue 't))
    (while continue
      (setq continue 'nil)
      (do ((i insn (cdr i)))
	  ((endp i))
	(when (eq (caar i) 'insn-label)
	  (cond ((eq (caadr i) 'insn-goto)
		 ;; ラベルの直後が無条件ジャンプ(A)のとき、そのラベルを参照している
		 ;; ジャンプ(B)を無条件ジャンプ(A)の飛び先に変更する。
		 (let ((label (cadadr i)))
		   (dolist (j insn)
		     (when (and (get (car j) 'jump)
				(eq (cadr j) (cadar i))
				(not (eq j (cadr i))))
		       (setf (cadr j) label)
		       (setq continue 't)))))
		((get (caadr i) 'jump)
		 ;; ラベルの直後が条件ジャンプ(A)のとき、そのラベルを参照している同一の
		 ;; 条件ジャンプ(B)を条件ジャンプ(A)の飛び先に変更する。
		 ;; ・条件ジャンプ(A)がgoto-and-popならば条件ジャンプ(B)のオペコードも
		 ;;   条件ジャンプ(A)と同じものに変更する。
		 ;; ・条件ジャンプ(A)がgoto-and-popでないならば条件ジャンプ(B)がgoto-and-pop
		 ;;   でない場合のみ。
		 (let* ((ope (caadr i))
			(label (cadadr i))
			(ope-if-nil-goto (get ope 'if-nil-goto))
			(ope-goto-and-pop (get ope 'goto-and-pop)))
		   (dolist (j insn)
		     (when (and (get (car j) 'jump)
				(eq (cadr j) (cadar i))
				(not (eq j (cadr i)))
				(eq (get (car j) 'if-nil-goto) ope-if-nil-goto))
		       (cond (ope-goto-and-pop
			      (setf (car j) ope)
			      (setf (cadr j) label)
			      (setq continue 't))
			     ((not (get (car j) 'goto-and-pop))
			      (setf (cadr j) label)
			      (setq continue 't))))))))))))

  ;; 次の行へのジャンプを削除する。
  ;; ただし条件ジャンプの場合、
  ;; ・goto-and-popの場合はdiscardへ変更する。
  ;; ・goto-and-popでない場合はなにもしない。
  (let ((mod nil))
    (do ((i insn (cdr i)))
	((endp i))
      (when (and (get (caar i) 'jump)
		 (eq (caadr i) 'insn-label)
		 (eq (cadar i) (cadadr i)))
	(cond ((eq (caar i) 'insn-goto)
	       (setf (car i) 'nil)
	       (setq mod t))
	      ((get (caar i) 'goto-and-pop)
	       (setf (car i) '(insn-discard))))))
    (if mod
	(remove-nil-insns insn)
      insn)))

;;; 未参照ラベルを削除
(defun remove-unreferenced-label (insn)
  (let ((mod nil))
    (do ((i insn (cdr i)))
	((endp i))
      (when (eq (caar i) 'insn-label)
	(let ((save (car i)))
	  (setf (car i) nil)
	  (if (si:*tree-find (cadr save) insn :test #'eq)
	      (setf (car i) save)
	    (setq mod t)))))
    (if mod
	(remove-nil-insns insn)
      insn)))

(let ()
  (setf (get 'insn-goto 'no-cond-jump) 't)
  (setf (get 'insn-go 'no-cond-jump) 't)
  (setf (get 'insn-return 'no-cond-jump) 't))

;;; 未参照コードを削除
(defun remove-unreferenced-code (insn)
  (do ((i insn (cdr i)))
      ((endp i) insn)
    (when (get (caar i) 'no-cond-jump)
      (setf (cdr i) (member 'insn-label (cdr i) :test #'eq :key #'car)))))

(defun optimize-set-discard-ref (insn)
  (let ((mod nil))
    (do ((i insn (cdr i)))
	((endp i))
      (when (and (eq (caadr i) 'insn-discard)
		 (or (and (eq (caar i) 'insn-lexical-set)
			  (eq (caaddr i) 'insn-lexical-ref))
		     (and (eq (caar i) 'insn-global-ref)
			  (eq (caaddr i) 'insn-global-ref)))
		 (eq (cadar i) (car (cdaddr i))))
	(setf (cadr i) 'nil)
	(setf (caddr i) 'nil)
	(setq mod t)))
    (if mod
	(remove-nil-insns insn)
      insn)))

(defun optimize-set-discard (insn)
  (let ((mod nil))
    (do ((i insn (cdr i)))
	((endp i))
      (when (eq (caadr i) 'insn-discard)
	(cond ((eq (caar i) 'insn-lexical-set)
	       (setf (caar i) 'insn-lexical-set-discard)
	       (setf (cadr i) 'nil)
	       (setq mod t))
	      ((eq (caar i) 'insn-global-set)
	       (setf (caar i) 'insn-global-set-discard)
	       (setf (cadr i) 'nil)
	       (setq mod t)))))
    (if mod
	(remove-nil-insns insn)
      insn)))

(defun remove-ref-discard (insn)
  (let ((mod nil))
    (do ((i insn (cdr i)))
	((endp i))
      (when (and (or (eq (caar i) 'insn-lexical-ref)
		     (eq (caar i) 'insn-global-ref)
		     (eq (caar i) 'insn-constant))
		 (eq (caadr i) 'insn-discard))
	(setf (car i) 'nil)
	(setf (cadr i) 'nil)
	(setq mod t)))
    (if mod
	(remove-nil-insns insn)
      insn)))

;; 定数の畳み込み
;; 副作用がなく1引数または2引数で多値を返さない数値演算関数のみ

(dolist (x '(zerop plusp minusp oddp evenp
	     = /= < > <= >= + - * /
	     max min conjugate
	     gcd lcm isqrt
	     exp log sqrt abs
	     sin cos tan asin acos atan
	     signum float rational complex realpart imagpart
	     rationalize numerator denominator
	     float-radix float-sign float-digits float-precision
	     lognot logcount logand logior logxor logeqv
	     cis phase sinh cosh tanh asinh acosh atanh))
  (setf (get x 'fold-const-1) 't))

(dolist (x '(= /= < > <= >= + - * /
	     max min gcd lcm expt complex rem mod ash
	     logtest logbitp logand logior logxor logeqv
	     lognand lognor logandc1 logandc2 logorc1 logorc2
	     log float float-sign))
  (setf (get x 'fold-const-2) 't))

(defun constant-folding (insn)
  (loop
    (let ((mod nil))
      (do ((i insn (cdr i)))
	  ((endp i))
	(let ((op1 (car i))
	      (op2 (cadr i))
	      (op3 (caddr i)))
	  (cond ((and (eq (car op1) 'insn-constant)
		      (numberp (cadr op1))
		      (eq (car op2) 'insn-call)
		      (symbolp (cadr op2))
		      (get (cadr op2) 'fold-const-1)
		      (= (caddr op2) 1))
		 (let ((val (ignore-errors
			     (multiple-value-list
			      (funcall (cadr op2) (cadr op1))))))
		   (when (= (length val) 1)
		     (setf (cadr op1) (car val))
		     (setf (cadr i) 'nil)
		     (setq mod t))))
		((and (eq (car op1) 'insn-constant)
		      (numberp (cadr op1))
		      (eq (car op2) 'insn-constant)
		      (numberp (cadr op2))
		      (eq (car op3) 'insn-call)
		      (symbolp (cadr op3))
		      (get (cadr op3) 'fold-const-2)
		      (= (caddr op3) 2))
		 (let ((val (ignore-errors
			     (multiple-value-list
			      (funcall (cadr op3) (cadr op1) (cadr op2))))))
		   (when (= (length val) 1)
		     (setf (cadr op1) (car val))
		     (setf (cadr i) 'nil)
		     (setf (caddr i) 'nil)
		     (setq mod t)))))))
      (unless mod
	(return insn)))
    (setq insn (remove-nil-insns insn))))

(defun optimize-insn (insn)
  (when t
    (setq insn (remove-local-lexicals insn))
    (setq insn (remove-duplicate-labels insn))
    (setq insn (optimize-jump insn))
    (setq insn (remove-unreferenced-label insn))
    (setq insn (remove-unreferenced-code insn))
    (setq insn (remove-unreferenced-label insn))
    (setq insn (optimize-set-discard-ref insn))
    (setq insn (optimize-set-discard insn))
    (setq insn (remove-ref-discard insn))
    (setq insn (constant-folding insn))
    (setq insn (remove-ref-discard insn))
  )
  insn)


(setf (get 'cons 'optimize-form)
      #'(lambda (form)
	 (if (and (= (length form) 3)
		  (null (caddr form)))
	     (list 'list (cadr form))
	   form)))

(setf (get 'not 'optimize-form) #'(lambda (x) `(null ,(cadr x))))

(let ((fn #'(lambda (form)
	      (if (<= (length form) 3)
		  form
		(let ((ope (car form))
		      (c (cadr form)))
		  (dolist (x (cddr form) c)
		    (setq c (list ope c x))))))))
  (dolist (x '(+ - * min max))
    (setf (get x 'optimize-form) fn)))

(setf (get '/ 'optimize-form)
      #'(lambda (form)
	  (let ((l (length form)))
	    (cond ((= l 2)
		   (list '/ 1 (cadr form)))
		  ((<= (length form) 3)
		   form)
		  (t
		   (let ((ope (car form))
			 (c (cadr form)))
		     (dolist (x (cddr form) c)
		       (setq c (list ope c x)))))))))

(let ()
  (setf (get '1+ 'optimize-form) #'(lambda (x) `(+ ,(cadr x) 1)))
  (setf (get '1- 'optimize-form) #'(lambda (x) `(- ,(cadr x) 1)))

  (setf (get 'caar 'optimize-form) #'(lambda (x) `(car (car ,(cadr x)))))
  (setf (get 'cadr 'optimize-form) #'(lambda (x) `(car (cdr ,(cadr x)))))
  (setf (get 'cdar 'optimize-form) #'(lambda (x) `(cdr (car ,(cadr x)))))
  (setf (get 'cddr 'optimize-form) #'(lambda (x) `(cdr (cdr ,(cadr x)))))
  (setf (get 'caaar 'optimize-form) #'(lambda (x) `(car (car (car ,(cadr x))))))
  (setf (get 'caadr 'optimize-form) #'(lambda (x) `(car (car (cdr ,(cadr x))))))
  (setf (get 'cadar 'optimize-form) #'(lambda (x) `(car (cdr (car ,(cadr x))))))
  (setf (get 'caddr 'optimize-form) #'(lambda (x) `(car (cdr (cdr ,(cadr x))))))
  (setf (get 'cdaar 'optimize-form) #'(lambda (x) `(cdr (car (car ,(cadr x))))))
  (setf (get 'cdadr 'optimize-form) #'(lambda (x) `(cdr (car (cdr ,(cadr x))))))
  (setf (get 'cddar 'optimize-form) #'(lambda (x) `(cdr (cdr (car ,(cadr x))))))
  (setf (get 'cdddr 'optimize-form) #'(lambda (x) `(cdr (cdr (cdr ,(cadr x))))))
  (setf (get 'caaaar 'optimize-form) #'(lambda (x) `(car (car (car (car ,(cadr x)))))))
  (setf (get 'caaadr 'optimize-form) #'(lambda (x) `(car (car (car (cdr ,(cadr x)))))))
  (setf (get 'caadar 'optimize-form) #'(lambda (x) `(car (car (cdr (car ,(cadr x)))))))
  (setf (get 'caaddr 'optimize-form) #'(lambda (x) `(car (car (cdr (cdr ,(cadr x)))))))
  (setf (get 'cadaar 'optimize-form) #'(lambda (x) `(car (cdr (car (car ,(cadr x)))))))
  (setf (get 'cadadr 'optimize-form) #'(lambda (x) `(car (cdr (car (cdr ,(cadr x)))))))
  (setf (get 'caddar 'optimize-form) #'(lambda (x) `(car (cdr (cdr (car ,(cadr x)))))))
  (setf (get 'cadddr 'optimize-form) #'(lambda (x) `(car (cdr (cdr (cdr ,(cadr x)))))))
  (setf (get 'cdaaar 'optimize-form) #'(lambda (x) `(cdr (car (car (car ,(cadr x)))))))
  (setf (get 'cdaadr 'optimize-form) #'(lambda (x) `(cdr (car (car (cdr ,(cadr x)))))))
  (setf (get 'cdadar 'optimize-form) #'(lambda (x) `(cdr (car (cdr (car ,(cadr x)))))))
  (setf (get 'cdaddr 'optimize-form) #'(lambda (x) `(cdr (car (cdr (cdr ,(cadr x)))))))
  (setf (get 'cddaar 'optimize-form) #'(lambda (x) `(cdr (cdr (car (car ,(cadr x)))))))
  (setf (get 'cddadr 'optimize-form) #'(lambda (x) `(cdr (cdr (car (cdr ,(cadr x)))))))
  (setf (get 'cdddar 'optimize-form) #'(lambda (x) `(cdr (cdr (cdr (car ,(cadr x)))))))
  (setf (get 'cddddr 'optimize-form) #'(lambda (x) `(cdr (cdr (cdr (cdr ,(cadr x)))))))

  (setf (get 'rest 'optimize-form) #'(lambda (x) `(cdr ,(cadr x))))
  (setf (get 'first 'optimize-form) #'(lambda (x) `(car ,(cadr x))))
  (setf (get 'second 'optimize-form) #'(lambda (x) `(car (cdr ,(cadr x)))))
  (setf (get 'third 'optimize-form) #'(lambda (x) `(car (cdr (cdr ,(cadr x))))))
  (setf (get 'fourth 'optimize-form) #'(lambda (x) `(car (cdr (cdr (cdr ,(cadr x)))))))
  (setf (get 'fifth 'optimize-form) #'(lambda (x) `(nth 4 ,(cadr x))))
  (setf (get 'sixth 'optimize-form) #'(lambda (x) `(nth 5 ,(cadr x))))
  (setf (get 'seventh 'optimize-form) #'(lambda (x) `(nth 6 ,(cadr x))))
  (setf (get 'eighth 'optimize-form) #'(lambda (x) `(nth 7 ,(cadr x))))
  (setf (get 'ninth 'optimize-form) #'(lambda (x) `(nth 8 ,(cadr x))))
  (setf (get 'tenth 'optimize-form) #'(lambda (x) `(nth 9 ,(cadr x)))))

(let ((fn #'(lambda (x)
	      (if (endp (cdr x))
		  (list (car x) 1)
		x))))
  (dolist (x '(forward-char forward-line forward-virtual-line))
    (setf (get x 'optimize-form) fn)))

(let ()
  (defconstant byte-code-constant 1)
  (defconstant byte-…