Forthを実装する
Forthを実装する
スタックベース変数いらずのふしぎなプログラミング言語、ForthをCommon Lispで実装しました。というか絶賛開発中のufというもので、これです。
執筆時点で
- 整数値のパース
- 基本的なスタック操作命令と出力
- ワード（Forthにおける関数）の定義と呼び出し
- 条件分岐
- 不完全な（なんだかバグい）REPL
ができます／あります。フィボナッチ数の計算ができるところまでは確認しました。
動機
先日、自作Lispのためハッシュテーブルの実装について考えたと書きました。
そのLispは抽象機械で実行されるタイプにしようと思って考えているのですが、肝心なVMの設計のしかたや感覚がどうにもわからない。じっさいのCPUみたいなものを考えだすと、それはそれでどうもちがうようです。そこで「ほぼ機械語」「スタックマシンみたいなもの」という評の言語があり、名をForthといい、それを覚えてみればいろいろ見えてきそうだなあと思ったため、実装してみました。
実装言語は手慣れているのでCommon Lispにしました。
Forthとは
Forthは、空白で区切られたアトムと呼ばれる構文単位からなるプログラムと、データのやり取りに使うデータスタック、それと他の言語における関数に相当するワード（値ではないアトム）――これは処理の本体を指す――、とその戻りスタック、で構成されたプログラミング言語です。
特徴として、プログラムのほとんどが何かの関数名で構成され、オペランドがないためコードサイズがとても小さくなる、ということがよく言われます。
どうもこの言語、かなり変わったしくみと見た目をしているだけでなく、ANSI、そしてISOで仕様が定められている程度には利用されているようです。最新のForthの仕様は2012年のもの！ すごいですねえ。
構文
Forthの構文は非常にシンプルで、スペース区切りで命令を並べていくだけです。実際のForthには文字列やコメントなど、一部のものについてパーサが特別扱いする要素があります。が、今回実装したオレオレForthにはそのようなものはまだ実装されていないので、スペース区切りでトークンが並んでいるものとして差し支えありません。
コード例は以下のような感じです（ただしオレオレ処理系にコメントはありません）：
\ 1+2を出力 2 1 + . \ あたらしいワード `<=` (less than or equal)を定義 \ ちなみにForth 2012の規格とは引数の順序が異なる : <= over over < rot swap = or ; \ 上で定義した `<=` を実行して結果を出力（Forthでは-1が真値） 2 1 <= .
意味論
Forthは意味論もとてもシンプルです。Forthにおける切り出されたトークンはアトムとよばれ、アトムには定数とワードの二種類があります。コードを実行するとき、解釈しようとしているアトムがディクショリナリに登録されたワードである場合、そのワードの処理が実行されます。そうでなければ定数としてスタックに積まれます。それだけです。
それまでに登録されているワードを使って新たなワードを自分で定義することができ、そうやって実行環境を拡張しながらプログラムを書いていくのがForthの特徴です。
実装
さて、とりあえずまずは動くものがほしかったので、最小限の要素で実装してみます。とりあえずインタプリタとしてフィボナッチ数が計算できるくらいまでの規模を目指します。
まず、（実装して）用意するものはパーサです。まあこれは「ストリームから一文字ずつ読んでいってバッファに溜めていき、空白やEOFなどの終わりが来たらシンボルの形でプログラムリストに追加」をやるだけです。数値型が使えると電卓になっていいので、とりあえずCommon Lispの整数型に対応させてみました。
;; https://github.com/t-sin/uf/blob/340662c05e1998d8d94594700275d5051b5c39bb/core.lisp#L26 (defun parse (stream) (let (code buf atomp numberp) (flet ((read-atom (ch) (unless atomp (setf atomp t) (when (digit-char-p ch) (setf numberp t)) (setf buf nil)) (unless (digit-char-p ch) (setf numberp nil)) (push ch buf)) (terminate-atom () (when atomp (setf atomp nil) (let ((s (concatenate 'string (nreverse buf)))) (if numberp (push (parse-integer s) code) (push (intern s :uf/dict) code)))))) (loop :for ch := (read-char stream nil :eof) :until (eq ch :eof) :do (case ch (#\space (terminate-atom)) (#\newline (terminate-atom)) (t (read-atom ch))) :finally (progn (terminate-atom) (return (nreverse code)))))))
つぎに評価器、というか解釈器ですが、その前に必要なオブジェクトを構造体として定義しました。
;; https://github.com/t-sin/uf/blob/340662c05e1998d8d94594700275d5051b5c39bb/core.lisp#L55 (defstruct word name fn start system-p) (defstruct vm code ip dict stack rstack ifdepth skip-to debug-p) (defparameter *dictionary* nil) ;; vmのディクショナリから現在指している箇所のアトムを拾う (defun get-atom (vm) (prog1 (nth (vm-ip vm) (vm-code vm)) (incf (vm-ip vm))))
word構造体は名前と、システム定義のワードの場合は本体の関数、ユーザ定義の場合はコード中のエントリポイントを格納します。あと、実行状態をvm構造体として定義しました。実行対象のコードそのもの、プログラムカウンタ(ip)、ディクショナリ、データスタック(stack)、ワード呼び出しのスタック(rstack)、条件分岐ワードifのネストの深さ(ifdepth)、ifでスキップするときの状態……。これだけの情報があれば、途中からプログラムを再開できそう。できるといいなあ。*dictionary*はデフォルト状態のディクショナリを保持しておき、vmを作るときにコピーする運用としたいと思います。
解釈器の前にもうひとつ、ワードの定義処理も書いておきます。ワード定義のためのワード:がきたらここに飛ぶようにします。定義は、名前(:の次のワード)を覚えておき、ワードのコード開始位置を覚えたあと、定義終わりのワード;まで読み飛ばします。この実装ではシステムのワードを上書きできないようにしてあります。また、ディクショナリは本来線形リストにするものらしいですが、めんどくさかったのでCommon Lispのパッケージをひとつ、処理系実行用に当てています。あまりよくないかも…。
;; https://github.com/t-sin/uf/blob/340662c05e1998d8d94594700275d5051b5c39bb/core.lisp#L70 ;; compilationの萌芽かな…？ (defun define-word (vm) (let ((name (get-atom vm))) (when (null name) (error "invalid word definition : it doesn't have a name.")) (let ((start-pos (vm-ip vm))) (loop :for atom := (get-atom vm) :until (eq atom 'uf/dict::|;|) :do (when (null atom) (error "invalid word definition '~a': it doesn't have ';'." name))) (let ((word (make-word :name name :system-p nil :start start-pos))) (let ((w (find name (vm-dict vm) :key #'word-name))) (if (and (not (null w)) (word-system-p w)) (error "cannot overwrite the predefined word: ~s" name) (push word (vm-dict vm))))))))
そして、解釈器本体です。コードはとても長いというわけではないので意を決して貼ります。
やっていることはとっても単純で、ワード定義の:や;、条件分岐のif、else、thenを特別扱いしつつ、そのいずれでもなかった場合は、ディクショナリからのワード探索を行なう、というふうにしました。(vm-skip-to vm)で分岐してスキップのときの処理と、通常の解釈のときの処理を分けていますが、これはifのためです。ワード定義はネストされませんが、ifはネストされる可能性があります。そのため、ifの深さを見ながら不要な部分をスキップする処理が、スキップ部分の処理です。
;; https://github.com/t-sin/uf/blob/340662c05e1998d8d94594700275d5051b5c39bb/core.lisp#L87:embed:cite ;; interpretationの萌芽かな…？ (defun execute (vm) (loop :for atom := (get-atom vm) :until (null atom) :do (when (vm-debug-p vm) (format t "; name = '~a', stack = ~s, ifdepth = ~s, skip-to = ~s~%" atom (vm-stack vm) (vm-ifdepth vm) (vm-skip-to vm))) :if (not (null (vm-skip-to vm))) :do (cond ((eq atom 'uf/dict::|if|) (incf (vm-ifdepth vm))) ((eq atom 'uf/dict::|else|) (cond ((zerop (vm-ifdepth vm)) (error "unexpected `else`")) ((and (eq (car (vm-skip-to vm)) :false) (= (1+ (cdr (vm-skip-to vm))) (vm-ifdepth vm))) (setf (vm-skip-to vm) nil)))) ((eq atom 'uf/dict::|then|) (if (zerop (vm-ifdepth vm)) (error "unexpected `then`") (progn (decf (vm-ifdepth vm)) (when (= (vm-ifdepth vm) (cdr (vm-skip-to vm))) (setf (vm-skip-to vm) nil)))))) :else :do (cond ((eq atom 'uf/dict::|:|) (define-word vm)) ((eq atom 'uf/dict::|;|) (if (null (vm-rstack vm)) (error "invalid syntax: reach ';' with empty rstack.") (setf (vm-ip vm) (pop (vm-rstack vm))))) ((eq atom 'uf/dict::|if|) (unless (= (pop (vm-stack vm)) -1) (setf (vm-skip-to vm) (cons :false (vm-ifdepth vm)))) (incf (vm-ifdepth vm))) ((eq atom 'uf/dict::|else|) (cond ((zerop (vm-ifdepth vm)) (error "unexpected `else`")) ((null (vm-skip-to vm)) (setf (vm-skip-to vm) (cons :true (1- (vm-ifdepth vm))))))) ((eq atom 'uf/dict::|then|) (if (zerop (vm-ifdepth vm)) (error "unexpected `else`") (progn (decf (vm-ifdepth vm)) (when (and (vm-skip-to vm) (> (vm-ifdepth vm) (cdr (vm-skip-to vm))))) (setf (vm-skip-to vm) nil)))) (t (let ((word (find atom (vm-dict vm) :key #'word-name))) (if word (if (word-system-p word) (funcall (word-fn word) vm) (progn (push (vm-ip vm) (vm-rstack vm)) (setf (vm-ip vm) (word-start word)))) (push atom (vm-stack vm))))))))
あとは、基本的なワードを定義するのみですが、これにはそこそこ長いコードを毎回書かなくてはならずめんどうです。そこでマクロdefwordを書いて楽をしました。
;; https://github.com/t-sin/uf/blob/340662c05e1998d8d94594700275d5051b5c39bb/runtime.lisp (defmacro defword ((name) &body body) (let (($fn-name (intern (format nil "word:~a" (symbol-name name)) :uf/dict)) ($word (gensym "uf"))) `(progn (defun ,$fn-name (vm) (declare (ignorable vm)) ,@body) (let ((,$word (find ',$fn-name uf/core:*dictionary* :key #'word-name))) (if ,$word (error "word ~s is already registered" (word-name ,$word)) (push (make-word :name ',(intern (symbol-name name) :uf/dict) :fn (function ,$fn-name) :system-p t) uf/core:*dictionary*))))))
それによって定義されたのが、標準出力にスタックトップの値を出力するこんなワードです。
;; https://github.com/t-sin/uf/blob/340662c05e1998d8d94594700275d5051b5c39bb/runtime.lisp (defword (|.|) (format t "~a" (pop (vm-stack vm))))
これで、以下のようにしてフィボナッチ数を計算できるようになりました。
やったー！ 自作Forthでフィボナッチ数を計算できたぞー！ pic.twitter.com/Z2pUZDgZvw
— t-sin (@sin_clav) 2018年10月18日
感想
かなり小さなコードで動くものが書けるというのがForthすごいところです。たぶんパーサが簡単な分、Lisp処理系よりも簡単なのではないでしょうか。たぶん実用的にするのにも、基礎ができたらあとはワードを充実させるだけで対応可能っぽいので、DSLにするのにもいいかもしれないです。
ただ、ifの実装はスタック的な走査を生でゴリゴリ書かないといけないので、ちょっと面倒くさいです。今回の実装では力技で乗り切りましたが……。
これから
ufの実装は、ifの実装がちょっと汚く、これを如何とすべきか、というところがひとつ。解決の方針としては、そもそもifを解釈しないという方針がありそうです。Forthの仕様書によれば処理系の状態はexecution、interpretation, compilationの3つあるそうですが、ifの項目を見ると、ワード定義の間（ここをcompilation modeというらしい…？）でしか使えないことが書かれています。バイナリコードにコンパイルするときに、ジャンプ先を解決してしまい、実行時にはジャンプ命令で済ませてしまう、というのがおそらく本来の実装方法のようです。なので、まずは仕様書を読み込むかLET OVER LAMBDAを読んでそのあたりを勉強してみようと思います。
また、フィボナッチ数列を計算できたけど、もっと実際的なプログラムに使ってみたいので、なにか用途を考えなくてはならないなあと思いました。弾幕STGとか、そういうものの低レベル組み込み言語とかにしてみると楽しいかもしれません。
関係ないけど
wlをVM型にするの、どうしようかなー。必要ないといえば必要ないけど、似非コンパイル（VM機械語とVMのセット）ができそうなのでやりたいとも思っており。なやましいですね。
