bf compiler/interpreter 改良

vm に対する命令セットを定義して、処理を分けてみた。上記のエレガントな回答に比べ、命令セットが多くて格好悪いが実力の差なのでとりあえず気にしないことにする。

  • incp, decp, incc, decc, putc 処理をしたあとプログラムカウンタを１増やす
  • jmp 指定された値にプログラムカウンタを設定
  • ict プログラムカウンタを１増やす
  • jmc ポインタの指す値によってジャンプ。z を指定すると０の場合ジャンプ。nz を指定するとnon zero のときジャンプ。それ以外のときはプログラムカウンタを１増やす。

bf のプログラムをコンパイルして１文字づつ vm への命令に変換し、vm?で実行していく。

まだあちこち手抜きで、

  • 入れ子の[]には未対応。
  • vm への命令はシンボルだったりコンスセルだったりしている。
  • 本物の計算機と違ってプログラムとメモリーが違う場所に管理されている。一緒の場所に格納すれば、

　実装依存のテクニックでHello World をより短くかけるかもしれない。

  • 最適化なし。あまり余地がないような気もするが、例えば命令セットを増やせば最適化できる。
  • bf プログラムはバグがないと仮定(!)。
  • 言葉。正確な言葉を使っていない、、
(defclass vm ()
  ((ptr :accessor ptr :initform 0)
   (mem :accessor mem :initform (make-array 2000 :initial-element 0))
   (prg :accessor prg :initform "")
   (pc :accessor pc :initform 0)
   (vm-code :accessor vm-code :initform nil)
   (vm-code-length :accessor vm-code-length :initform nil)   
   ))

(defmethod print-object ((vm vm) stream)
  (print-unreadable-object (vm stream)
    (with-accessors ((ptr ptr) (mem mem) (prg prg) (pc pc)) vm
      (format stream "pc: ~a ptr: ~a *ptr: ~a" pc ptr (aref mem ptr)))))

;; instruction set
(defmethod incp ((vm vm))
  (with-accessors ((ptr ptr)) vm
    (incf ptr)
    (ict vm)))

(defmethod decp ((vm vm))
  (with-accessors ((ptr ptr)) vm
    (decf ptr)
    (ict vm)))

(defmethod incc ((vm vm))
  (with-accessors ((ptr ptr) (mem mem)) vm
    (incf (aref mem ptr))
    (ict vm)))

(defmethod decc ((vm vm))
  (with-accessors ((ptr ptr) (mem mem)) vm
    (decf (aref mem ptr))
    (ict vm)))

(defmethod putc ((vm vm))
  (with-accessors ((ptr ptr) (mem mem)) vm
    (format t "~a" (code-char (aref mem ptr)))
    (ict vm)))

(defmethod jmp ((vm vm) new-pc)
  (with-accessors ((pc pc)) vm
    (setf pc new-pc)))

(defmethod ict ((vm vm) &optional (size 1))
  (with-accessors ((pc pc)) vm
    (setf pc (+ pc size))))

(defmethod jmc ((vm vm) new-pc c)
  (with-accessors ((ptr ptr) (mem mem)) vm
    (if (ecase c
	  (z (= 0 (aref mem ptr)))
	  (nz (not (= 0 (aref mem ptr)))))
	(jmp vm new-pc)
      (ict vm))))

(defun bf->vm-code (bf)
  (let ((bf-len (length bf)))
    (loop for pc from 0 below bf-len
	for op = (aref bf pc)
	collect
	  (case op
	    (#\> 'incp)
	    (#\< 'decp)
	    (#\+ 'incc)
	    (#\- 'decc)
	    (#\. 'putc)
	    (#\[ (cons (position #\] bf :start pc) 'z))
	    (#\] (cons (position #\[ bf :from-end t :end pc) 'nz))))))

(defmethod compile-bf ((vm vm) bf)
  (setf (ptr vm) 0)
  (setf (mem vm) (make-array 2000 :initial-element 0))
  (setf (prg vm) bf)
  (setf (pc vm) 0)
  (setf (vm-code vm) (bf->vm-code bf))
  (setf (vm-code-length vm) (length (vm-code vm)))
  )

(defmethod run-vm ((vm vm))
  (with-accessors ((pc pc) (vm-code vm-code)) vm
    (cond
     ((>= pc (vm-code-length vm)) 'eof)
     (t
      (let ((op/pc (nth pc vm-code)))
	(case op/pc
	  (incp (incp vm))
	  (decp (decp vm))
	  (incc (incc vm))
	  (decc (decc vm))
	  (putc (putc vm))
	  (t
	   (jmc vm (car op/pc) (cdr op/pc))))
	(run-vm vm))))))

(defun compile-bf-and-exec (bf)
  "interpret bf program"
  (let ((vm (make-instance 'vm)))
    (compile-bf vm bf)
    (run-vm vm)))