よく知られているように、Schemeの syntax-rules マクロはチューリング完全である。
ということで、 brainf**k の処理系を syntax-rules マクロで書いてみた。
内部表現
数値は0個以上の 1、または0個以上の -1 のみから成るリストとして表現する。例えば、 () は0、 (1 1 1) は3を表し、 (-1 -1) は-2を表現する。0判定を簡単にするため、 (1 1) をデクリメントしたら (1), (-1 -1 -1) をインクリメントしたら (-1 -1), のように演算時に表現を正規化する。
1つのコマンドは1つの文字列で表現する。例えばbrainf**kの < はSchemeの文字列 "<" で表現する。
命令列、データ領域はそれぞれ2本のリストで表現し、1本目のリストはポインタの左側を逆順にしたもの、もう1本のリストは現在ポインタの指している領域とその右側を並べたものにする。例えば ++[>+ という命令列の > の位置にポインタがある場合、それを ("[" "+" "+") （= ++[ を逆順に並べたもの）と (">" "+") （= >+ を正順に並べたもの）の組で表現する。
, で読み込む入力は標準入力等を読むのではなく、マクロの引数としてあらかじめ渡しておく（そもそも syntax-rules マクロで標準入力を読むことはできない）。
. の出力は標準出力に書き出すようなプログラムを出力することで表現する。 , と同様にマクロの引数でもちまわしてもよいが、単純に面倒なのでサボる。
実装
ということで実装は次のようになる
(define-syntax run-bf
(syntax-rules ()
((_ is)
(run-bf is () ()))
((_ is ds input)
(bf () is () ds input))))
run-bf は無指定のとき、空のデータ領域、空の入力で実行を開始するためのエントリポイントで、実装の本体は下の bf, bf-go-left, bf-go-right だ。
(define-syntax bf
(syntax-rules ()
((_ ris () rds ds input)
#f)
;; >
((_ ris (">" . is) rds (d . ds) input)
(bf (">" . ris) is (d . rds) ds input))
((_ ris (">" . is) rds () input)
(bf (">" . ris) is (() . rds) () input))
;; <
((_ ris ("<" . is) (d . rds) ds input)
(bf ("<" . ris) is rds (d . ds) input))
((_ ris ("<" . is) () ds input)
(bf ("<" . ris) is () (() . ds) input))
;; +
((_ ris ("+" . is) rds ((-1 . d) . ds) input)
(bf ("+" . ris) is rds (d . ds) input))
((_ ris ("+" . is) rds (d . ds) input)
(bf ("+" . ris) is rds ((+1 . d) . ds) input))
((_ ris ("+" . is) rds () input)
(bf ("+" . ris) is rds ((+1)) input))
;; -
((_ ris ("-" . is) rds ((+1 . d) . ds) input)
(bf ("-" . ris) is rds (d . ds) input))
((_ ris ("-" . is) rds (d . ds) input)
(bf ("-" . ris) is rds ((-1 . d) . ds) input))
((_ ris ("-" . is) rds (() . ds) input)
(bf ("-" . ris) is rds ((-1) . ds) input))
;; .
((_ ris ("." . is) rds (d . ds) input)
(begin
(write-char (integer->char (+ . d)))
(bf ("." . ris) is rds (d . ds) input)))
((_ ris ("." . is) rds () input)
(begin
(write-char (integer->char (+ . ())))
(bf ("." . ris) is rds () input)))
;; ,
((_ ris ("," . is) rds (d . ds) (i . input))
(bf ("," . ris) is rds (i . ds) input))
((_ ris ("," . is) rds (d . ds) ())
(syntax-error "no input" (bf ris ("," . is) rds (d . ds) ())))
;; [
((_ ris ("[" . is) rds (() . ds) input)
(bf-go-right () ("[" . ris) is (rds (() . ds)) input))
((_ ris ("[" . is) rds () input)
(bf-go-right () ("[" . ris) is (rds ()) input))
((_ ris ("[" . is) rds ds input)
(bf ("[" . ris) is rds ds input))
;; ]
((_ ris ("]" . is) rds (() . ds) input)
(bf ("]" . ris) is rds (() . ds) input))
((_ ris ("]" . is) rds () input)
(bf ("]" . ris) is rds () input))
((_ ris ("]" . is) rds ds input)
(bf-go-left () ris ("]" . is) (rds ds) input))
))
(define-syntax bf-go-right
(syntax-rules ()
((_ () ris ("]" . is) (rds ds) input)
(bf ("]" . ris) is rds ds input))
((_ (_ . stack) ris ("]" . is) ds input)
(bf-go-right stack ("]" . ris) is ds input))
((_ stack ris ("[" . is) ds input)
(bf-go-right (1 . stack) ("[" . ris) is ds input))
((_ stack ris (i . is) ds input)
(bf-go-right stack (i . ris) is ds input))))
(define-syntax bf-go-left
(syntax-rules ()
((_ () ("[" . ris) is (rds ds) input)
(bf ris ("[" . is) rds ds input))
((_ (_ . stack) ("[" . ris) is ds input)
(bf-go-left stack ris ("[" . is) ds input))
((_ stack ("]" . ris) is ds input)
(bf-go-left (1 . stack) ris ("]" . is) ds input))
((_ stack (i . ris) is ds input)
(bf-go-left stack ris (i . is) ds input))
))
これらのマクロは命令列（instructions） ris, is とデータ列 rds, ds, 入力 input を引数に取りながら実行を進める。
1回のマクロ展開がちょうどbf抽象機械の1ステップの簡約に対応していて、操作的意味論を書き出したようになっている。
順に中身を見ていこう。
終了
((_ ris () rds ds input)
#f)
命令列 is がなくなった場合は展開を終了する。
>
> はデータポインタをひとつ右に進める。
;; >
((_ ris (">" . is) rds (d . ds) input)
(bf (">" . ris) is (d . rds) ds input))
((_ ris (">" . is) rds () input)
(bf (">" . ris) is (() . rds) () input))
命令列 is の先頭が ">" の場合、データ列 ds の先頭の要素を左データ列 rds の先頭に移動させる。これは、データポインタをひとつ進めることに相当する。
同様に、読み込んだ命令も is の先頭から ris の先頭に移動させる。
また、データ列が空の場合は暗黙に0が存在するものとして、 () （= 0）を左データ列に追加する。
< については > と同じなので略。
+
+ はデータポインタの指す数値を1インクリメントする。
;; +
((_ ris ("+" . is) rds ((-1 . d) . ds) input)
(bf ("+" . ris) is rds (d . ds) input))
((_ ris ("+" . is) rds (d . ds) input)
(bf ("+" . ris) is rds ((+1 . d) . ds) input))
((_ ris ("+" . is) rds () input)
(bf ("+" . ris) is rds ((+1)) input))
データ列の先頭の数値が負数の場合 -1 を削除し、非負の場合は +1 を追加する。
必要に応じてデータ列に0をおぎない命令列を進めるのは > や < と同じである。
- も + と同じなので略。
.
. はデータポインタの指す数値を出力する。
;; .
((_ ris ("." . is) rds (d . ds) input)
(begin
(write-char (integer->char (+ . d)))
(bf ("." . ris) is rds (d . ds) input)))
((_ ris ("." . is) rds () input)
(begin
(write-char (integer->char (+ . ())))
(bf ("." . ris) is rds () input)))
数値の表現はSchemeの数を並べたものなので、総和をとればSchemeの数値になる。それを文字として標準出力に書き出す。
,
, は入力を1バイト読み込み現在のデータポインタが指している値を置き換える。
;; ,
((_ ris ("," . is) rds (d . ds) (i . input))
(bf ("," . ris) is rds (i . ds) input))
((_ ris ("," . is) rds (d . ds) ())
(syntax-error "no input" (bf ris ("," . is) rds (d . ds) ())))
読んで字の如し。
ただし、データと異なり入力を暗黙におぎなうことはせず、入力が足りなければエラーにする。
[, ]
;; [
((_ ris ("[" . is) rds (() . ds) input)
(bf-go-right () ("[" . ris) is (rds (() . ds)) input))
((_ ris ("[" . is) rds () input)
(bf-go-right () ("[" . ris) is (rds ()) input))
((_ ris ("[" . is) rds ds input)
(bf ("[" . ris) is rds ds input))
;; ]
((_ ris ("]" . is) rds (() . ds) input)
(bf ("]" . ris) is rds (() . ds) input))
((_ ris ("]" . is) rds () input)
(bf ("]" . ris) is rds () input))
((_ ris ("]" . is) rds ds input)
(bf-go-left () ris ("]" . is) (rds ds) input))
入力が0/非0の場合、命令列を右/左に動かして対応する "]", "[" を探すループに入る。
bf-go-left が ris に関して再帰するため、読み込んだ "]" は is の方に戻しておく。
実際に対応する括弧を探す部分は以下の通り。
(define-syntax bf-go-right
(syntax-rules ()
((_ () ris ("]" . is) (rds ds) input)
(bf ("]" . ris) is rds ds input))
((_ (_ . stack) ris ("]" . is) ds input)
(bf-go-right stack ("]" . ris) is ds input))
((_ stack ris ("[" . is) ds input)
(bf-go-right (1 . stack) ("[" . ris) is ds input))
((_ stack ris (i . is) ds input)
(bf-go-right stack (i . ris) is ds input))))
(define-syntax bf-go-left
(syntax-rules ()
((_ () ("[" . ris) is (rds ds) input)
(bf ris ("[" . is) rds ds input))
((_ (_ . stack) ("[" . ris) is ds input)
(bf-go-left stack ris ("[" . is) ds input))
((_ stack ("]" . ris) is ds input)
(bf-go-left (1 . stack) ris ("]" . is) ds input))
((_ stack (i . ris) is ds input)
(bf-go-left stack ris (i . is) ds input))
))
"[", "]" は入れ子になることがあるので、現在の入れ子のレベルを最初の引数で管理する。
右に進む場合は "]" に出会ったらレベルを1つ減らし、現在のレベルが0の場合はループを終了する。 "[" に出会ったらレベルを1つ増やしておく。
左に進む場合も同様である。
Hello, World!
ということで、
(run-bf
("+" "+" "+" "+" "+" "+" "+" "+" "[" ">" "+" "+" "+" "+" "[" ">" "+" "+" ">" "+" "+" "+" ">" "+" "+" "+" ">" "+" "<" "<" "<" "<" "-" "]" ">" "+" ">" "+" ">" "-" ">" ">" "+" "[" "<" "]" "<" "-" "]" ">" ">" "." ">" "-" "-" "-" "." "+" "+" "+" "+" "+" "+" "+" "." "." "+" "+" "+" "." ">" ">" "." "<" "-" "." "<" "." "+" "+" "+" "." "-" "-" "-" "-" "-" "-" "." "-" "-" "-" "-" "-" "-" "-" "-" "." ">" ">" "+" "." ">" "+" "+" "."))
を展開すると
(begin
(write-char (integer->char (+ 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1)))
(begin
(write-char (integer->char (+ 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1)))
(begin
(write-char (integer->char (+ 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1)))
(begin
(write-char (integer->char (+ 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1)))
(begin
(write-char (integer->char (+ 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1)))
(begin
(write-char (integer->char (+ 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1)))
(begin
(write-char (integer->char (+ 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1)))
(begin
(write-char (integer->char (+ 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1)))
(begin
(write-char (integer->char (+ 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1)))
(begin
(write-char (integer->char (+ 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1)))
(begin
(write-char (integer->char (+ 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1)))
(begin
(write-char (integer->char (+ 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1)))
(begin
(write-char (integer->char (+ 1 1 1 1 1 1 1 1 1 1)))
#f)))))))))))))
のようなプログラムが得られ、
Hello World!
が出力される。