Nailgun/GroovyServを使ってClojureの起動を高速化する

JVM上で動作する言語(処理系)にはよくある話だけれど，Clojureの起動は遅い。下の結果は手元の環境で実行した場合の例。

$ repeat 5 time java clojure.main -e '(println "Hello, Clojure!")'
Hello, Clojure!
java clojure.main -e '(println "Hello, Clojure!")'  2.31s user 0.17s system 131% cpu 1.885 total
Hello, Clojure!
java clojure.main -e '(println "Hello, Clojure!")'  2.31s user 0.17s system 131% cpu 1.891 total
Hello, Clojure!
java clojure.main -e '(println "Hello, Clojure!")'  2.26s user 0.16s system 134% cpu 1.798 total
Hello, Clojure!
java clojure.main -e '(println "Hello, Clojure!")'  2.28s user 0.16s system 133% cpu 1.841 total
Hello, Clojure!
java clojure.main -e '(println "Hello, Clojure!")'  2.24s user 0.16s system 128% cpu 1.863 total
$

2秒程度だと大したことはないように思えるが，繰り返し実行するスクリプトのような使い方をしていると，この少しの時間の積み重ねが目についたりする。

JVM上で動くプログラムの起動を高速化するツールがいくつか開発されているようで，以下のようなものがあるらしい。

• Nailgun
• GroovyServ

NailgunはJavaプログラム向け，GroovyServは基本的にはGroovyプログラム向けのようだけど，GroovyからJavaのクラスにアクセスできるので，一般のJavaプログラムで利用できる。どちらもあらかじめJVMプロセス(サーバ)を起動させておいて，Cで書かれたクライアントから処理をディスパッチすることで都度の起動を高速化する仕組み。

インストール方法の説明等は他所へ譲るとして，以下ではNailgun/GroovyServでClojureを実行する方法について書いていく。

Nailgunでの起動

Nailgunのサーバを起動するには，Nailgun付属のJARを呼び出せばいい。

$ java -server -jar nailgun-0.7.1.jar &

-serverオプションはお好みで。ちなみに，Homebrewでインストールしたら ng-server というコマンドが使えるようになっていたが，やってることは上とまったく同じようだ。

サーバを起動したら ng コマンドからClojureを起動すればいいが，その前にクラスパスを指定する。

$ ng ng-cp /path/to/clojure.jar

クラスパスは一度指定するとサーバプロセスが生きている間は有効になっている。
クラスパスの指定ができたらClojureを起動する。

$ ng clojure.main
Clojure 1.2.0
user=> 
$

最初の起動は若干遅いが，二度目以降は高速に起動できる。

$ time ng clojure.main -e '(println "Hello, Clojure")'
Hello, Clojure
ng clojure.main -e '(println "Hello, Clojure")'  0.00s user 0.00s system 7% cpu 0.044 total
$

GroovyServでの起動

GroovyServでは，最初のクライアント呼び出し時にサーバが起動されるため，あらかじめサーバを起動しておく必要はない。
groovyclient コマンドに-eオプションを付けると，実行するGroovyスクリプトを指定できる。GroovyServの小技シリーズ2 scalacを高速化する - uehaj's blogを参考にすると，

$ groovyclient -cp クラスパス -e '実行するクラス.main(args)'

とすると，実行するクラスのmainメソッドを実行できるようだ。

GroovyServでClojureを実行しようとするとここで問題が起きる。Clojureのインタプリタは，clojure.mainクラスのmainメソッドから実行されるが，"clojure.main"というクラス名は最初の一文字が大文字ないため，Groovyからはクラス名として認識されないようだ。
解決策としては，リフレクション経由で呼び出すか，

$ groovyclient -cp /path/to/clojure.jar -e 'Class.forName("clojure.main").getMethod("main", ([String] as Class)).invoke(null, ([args] as Object[]))'
Clojure 1.2.0
user=>

あるいは，単にclojure.main.mainを呼び出すだけのJavaクラスを書いて，それを呼び出すようにする。

public class GSClojure {
    public static void main(String[] args) throws Exception {
        clojure.main.main(args);
    }
}

$ groovyclient -e 'GSClojure.main(args)'
Clojure 1.2.0
user=>

起動時間はNailgunと比較するとやや遅いが，それでも通常の起動時間より10倍以上速い。

$ time groovyclient -e 'GSClojure.main(args)' -- -e '(println "Hello, Clojure!")'
Hello, Clojure!
groovyclient -e 'GSClojure.main(args)' -- -e '(println "Hello, Clojure!")'  0.00s user 0.00s system 1% cpu 0.168 total
$

NailgunとGroovyの違い

NailgunとGroovyの違いについて，以前GroovyServの開発者の @uehaj さんから教えていただいたので，ツイートを載せておく。

cookieによるセキュリティ、groovyによるカスタム起動コードとかですか。あとシグナルハンドリングが少しかしこいはず。 RT @athos0220: GroovyServ と Nailgun の違いって何なんでしょう？

2011-04-10 10:57:58 via YoruFukurou

あとそうだ、Current Working DirectoryのハンドリングやClassPathの動的反映、環境変数伝播。NaigunではNailをガリガリ書けばできるかも。 RT @athos0220: GroovyServ と Nailgun の違いって何なんでしょう？

2011-04-10 11:00:15 via YoruFukurou

@athos0220 逆にnailgunの面白いところは、aliasを定義できるところとか。

2011-04-10 11:19:54 via YoruFukurou to @athos0220

あとは，Nailgunの方は開発が止まっているのに対して，GroovyServは先日0.7がリリースされる等，開発が活発に行われているということも注意する点として挙げられるかなぁと。

まとめ

Clojureの遅い起動はNailgunやGroovyServで高速化できることが分かった。
これまでClojureの起動が遅いことが理由で避けていた，スクリプトのような使い方もしていけたらなぁと思う。

「ClojureでJavaクラスのコンストラクタをapplyする」をリフレクションで

元ネタは1年前の記事。

• ClojureでJavaクラスのコンストラクタをapplyする - 水底で思うこと
• 解決方法 -> ClojureでJavaクラスのコンストラクタをapplyする - 地獄の猫日記

ClojureからJavaのコンストラクタを呼ぶ場合，

(new Hoge foo bar)

または

(Hoge. foo bar)

のように書く。ところが，これらの構文ではクラス名が静的に決まっている必要があるため，たとえば

(let [c Hoge]
  (new c foo bar))

(let [c Hoge]
  (c. foo bar))

というようには書けない。また，applyを使って

(apply Hoge. [foo bar])

とすることもできない。

インスタンスを生成するクラスを動的に変更したい場合というのはちょくちょくあって，そういう場合には今まで，オブジェクトを生成する関数を引数に渡すようにしてお茶を濁していた。

リンク先の記事では，最終的にevalを使って解決していたけど，それだけのためにevalを呼ぶのはいかにも効率が悪そう。そこで，最近ちょっとずつ弄って遊んでいたJavaのリフレクションの機能を使えば同じことが実現できそうだと思い立って書き直してみた。

ソースコード

apply_ctor.clj

(ns apply-ctor
  (import [java.lang.reflect Constructor]))

(defn- acceptable-types? [ptypes atypes]
  (and (= (count ptypes) (count atypes))
       (every? (fn [[ptype atype]]
                 (or (= ptype atype)
                     ((ancestors atype) ptype)))
               (map vector ptypes atypes))))

(defn apply-ctor [^Class klass args]
  (let [atypes (into-array Class (map class args))
        ctors (for [^Constructor ctor (.getConstructors klass)
                    :let [ptypes (.getParameterTypes ctor)]
                    :when (acceptable-types? ptypes atypes)]
                ctor)]
    (when (empty? ctors)
      (throw (IllegalArgumentException.
              (str "No matching ctor found for " klass))))
    (let [^"[Ljava.lang.Object;" args (into-array Object args)]
      (.newInstance ^Constructor (first ctors) args))))

やってることは単純で，リフレクションを使ってクラスからすべてのコンストラクタを取得して，実引数の型からコンストラクタを選別，コンストラクタを呼ぶ，ということをやっている。無駄なリフレクションが起きないように，極力 type hint をつけるようにして書いている。Object配列のtype hintはややトリッキー？

実行例

eval版と速度を比較してみると，当然リフレクション版の方が断然速い。

user=> (defn f1 [c args] (eval `(new ~c ~@args)))
#'user/f1
user=> (defn f2 [c args] (apply-ctor c args))
#'user/f2
user=> (time (dotimes [i 10000] (f1 String [(str "hoge" i)])))
"Elapsed time: 9086.514 msecs"
nil
user=> (time (dotimes [i 10000] (f2 String [(str "hoge" i)])))
"Elapsed time: 146.569 msecs"
nil
user=>

ぷよぷよ19連鎖の問題を Clojure で

去年、迷路を最短経路で解く問題を出題していたところが、今年も採用一次試験の問題を公開しているというのでClojureで解いてみた。

問題は以下のとおり。

ゲーム「ぷよぷよ」で、フィールドの状態がテキストで与えられたとき、消える「ぷよ」を消して次のフィールドの状態を出力するプログラムを書け。
たとえば、色をG/Y/Rで表すとき(Green/Yellow/Red)、

GGR
YGG

であればGが消えて

Y R

になります。

また、このプログラムを使って次のフィールドを与えると19連鎖ののちすべてのぷよが消えることを確認し、消える途中の様子をあわせて提出すること。

  GYRR
RYYGYG
GYGYRR
RYGYRG
YGYRYG
GYRYRG
YGYRYR
YGYRYR
YRRGRG
RYGYGG
GRYGYR
GRYGYR
GRYGYR 

人生を書き換える者すらいた。: 人材募集企画 2011年版

ソースコード

puyo.clj

(use '[clojure.contrib.io :only (read-lines)]
     '[clojure.string :only (join)])

(defn value-at [field y x]
  (get-in field [x y]))

(defn nrows [field]
  (count (field 0)))

(defn ncols [field]
  (count field))

(defn entire-block
  ([pos field]
   (entire-block pos field #{}))
  ([[y x :as pos] field visited]
   (reduce (fn [visited* pos*]
             (if (visited* pos*)
               visited*
               (into visited* (entire-block pos* field visited*))))
           (conj visited pos)
           (for [[dy dx] [[0 -1] [1 0] [0 1]]
                 :let [[y* x* :as pos*] [(+ y dy) (+ x dx)]]
                 :when (and (not (visited pos*))
                            (= (value-at field y x)
                               (value-at field y* x*)))]
             pos*))))

(defn all-blocks [field]
  (let [blocks (atom [])]
    (doseq [y (range (nrows field))
            x (range (ncols field))
            :let [pos [y x]]
            :when (and (not= (value-at field y x) \space)
                       (not (some #(% pos) @blocks)))
            :let [block (entire-block pos field)]
            :when (>= (count block) 4)]
      (swap! blocks conj block))
    @blocks))

(defn remove-blocks [field blocks]
  (let [to-be-removed (reduce into blocks)]
    (vec (map (fn [col] (vec (sort (fn [x y] (= x \space)) col)))
              (for [x (range (ncols field))]
                (for [y (range (nrows field))]
                  (if (to-be-removed [y x])
                    \space
                    (value-at field y x))))))))

(defn steps [field]
  (lazy-seq
    (cons field
          (let [blocks (all-blocks field)]
            (if-not (empty? blocks)
              (steps (remove-blocks field blocks)))))))

(defn print-field [field]
  (let [trans (apply map list field)
        color #(str "\033[" (or ({\R 41, \G 44, \Y "1;43"} %) 0) "m" %)
        hline (join (repeat (+ (ncols field) 2) "-"))
        lines `(~hline
                ~@(map #(join `("|" ~@(map color %) "\033[0m|")) trans)
                ~hline)]
    (println (join \newline lines))))

(defn solve [field]
  (doseq [step (steps field)]
    (print "\033[2J")
    (print-field step)
    (Thread/sleep 1000)))

(solve (vec (apply map vector (read-lines *in*))))

実行

標準入力からぷよの配置を問題のフォーマットで読み込み、1秒毎に各時点でのフィールドの状態を表示します。表示は見やすいように色を付けてます。緑はそのままだと黄色との境界が分かりづらかったので青で表示しています。

実行結果は下のような感じになります。

Rubyで末尾再帰最適化をする。

元ネタはPythonで末尾再帰最適化をする。 - wasabizの日記。Pythonのデコレータを使って、末尾再帰で書かれた関数に対して末尾呼び出し最適化(TCO)を行う、というものです(どうやってTCOを実現しているかの詳細についての説明はここでは割愛します)。

さて、元エントリでは「Pythonがすごいからこんなことができるんだ」という感じで書かれていますが、タネさえ分かればいろんな言語でできそうだということが分かったので、他の言語でも試してみることにしました。

まずはじめに、試しにScheme版を書いてみたものの、そもそもSchemeはTCOを勝手にやってくれるのであまり意味のない例になってしまいました。
その後、Scheme版をだいたいそのままRubyに書き直したのが以下のRuby版です。

class Module
  def tco(name)
    continue = []
    first = true
    arguments = nil

    private_name = "private_" + name.to_s
    alias_method private_name, name
    private private_name

    proc = lambda do |*args|
      if first
        first = false
        while true
          result = send(private_name, *args)
          if result.equal? continue
            args = arguments
          else
            first = true
            return result
          end
        end
      else
        arguments = args
        continue
      end
    end
    define_method name, proc
  end
end

ここで定義した tco というクラスマクロを以下のように使います。

class Sum
  def sum1(n, acc=0)
    if n == 0
      acc
    else
      sum1(n-1, acc+n)
    end
  end

  def sum2(n, acc=0)
    if n == 0
      acc
    else
      sum2(n-1, acc+n)
    end
  end
  tco :sum2  # ←コレ
end

sum1メソッドとsum2メソッドは定義が全く同じですが、sum2メソッドにだけ tco をかけています。すると、以下のように、sum1メソッドでスタックオーバーフローになるようなケースでも、sum2メソッドではスタックオーバーフローになりません。TCOがうまく効いているようです。

>> o = Sum.new
=> #
>> o.sum1(100000)
SystemStackError: stack level too deep
        from ./tco.rb:36:in `sum1'
        from ./tco.rb:36:in `sum1'
        from (irb):3
>> o.sum2(100000)
=> 5000050000

実装としては、メソッドの呼び出しを置き換えるのに、Pythonのデコレータの代わりにアラウンドエイリアスを使ってます。アラウンドエイリアスの他にもメタプログラミングRubyで紹介されているテクニックをいくつか使わせてもらいました。メタプログラミングRuby素晴らしい！

メタプログラミングRuby

暗黙の引数 &env を使ってスコープを曲げてみる

昨日に引き続き、Clojureマクロの暗黙の引数&envについて。

&envを通してマクロ呼び出しのフォームを囲む環境が手に入るわけで、これを利用しておもしろいことはできないだろうか。そう考えているうちに、スコープを曲げる - 主題のない日記で出てきた例を思い出した。こんな例だ。

(let ((x 1))
  (let/scope d1
    (let ((x 2))
      (let/scope d2
        (let ((x 3))
          (list (d1 x) (d2 x) x)))))) ;=> (1 2 3)

この例では、Schemeのマクロを使って、本来シャドウイングされて見えないはずの外の環境にアクセスできるようにするlet/scopeを定義している。
これと似たようなことをClojureで実現してみる。

(let [x 1]
  (let-env d1
    (let [x 2]
      (let-env d2
        (let [x 3]
          [(with-env d1 x) (with-env d2 x) x])))))

ここでの肝は、let-env と with-env という2つのマクロだ。

(let-env   ...)

は、現在見えている環境を捕捉し、という名前をつける。その名前は式 ...中に含まれる with-env から参照可能になる。

(with-env   ...)

は、let-envで捕捉したという名前の環境で、式 ...を評価する。ただし、環境に存在しない束縛は、元の環境で評価される。

原理としては、Let Over Lambda の pandoric macroに似た手法を使っていて、let-envの呼び出し箇所で見えている変数を網羅するために&envで渡ってくる環境を使っている。Clojureには代入がないので、値をコピーするだけでいい。

ソースコードは以下のとおり。

local_env.clj

(ns local-env
  (:use [clojure.contrib.def :only (defvar-)])
  (:use [clojure.contrib.macro-utils :only (mexpand-all symbol-macrolet)]))

(defvar- *local-envs* {})

(defmacro let-env [env-name & body]
  (binding [*local-envs* (assoc *local-envs* env-name &env)]
    `(let [~env-name ~(into {} (for [x (keys &env)] `['~x ~x]))]
       ~(mexpand-all `(do ~@body)))))

(defmacro with-env [env-name & body]
  (let [env (*local-envs* env-name)]
    (mexpand-all
      `(symbol-macrolet ~(vec (mapcat (fn [name]
                                        `[~name (~env-name '~name)])
                                      (keys env)))
         ~@body))))

マクロの暗黙の引数 &form と &env

Varの適用

Clojureでは、たとえば

(#'list 1 2 3)

が

(list 1 2 3)

と同じ結果を返す。Varに関数が束縛されている場合には、Varに束縛されている関数がそのまま適用されるようだ。

では、Varにマクロが束縛されている場合にはどうなるだろう？マクロを展開した結果が返ってくるだろうか。whenマクロで試してみると以下のようになった。

user=> (#'when '(= 1 1) '(println 'a) '(println 'b))
(if (println (quote b)) (do))
user=> (#'when '(= 1 1) '(println 'a) '(println 'b) '(println 'c))
(if (println (quote b)) (do (println (quote c))))
user=>

結果を見ると、一見うまくいっているように見えるが、どうも最初の2つの引数が無視されているようだ。

defmacroの定義と暗黙の引数 &form と &env

ここで、マクロがどのように定義されるのかを見てみる。defmacroの定義を確認すると、大雑把には

1. &form と &env という2つの暗黙的な引数を、引数の先頭に追加し、defnを使って通常の関数として定義をする
2. 1. で定義した関数のVarに対してsetMacroを実行する*1

ということをやっている。上のwhenの例で無視されていた引数は、1.で追加される&formと&envではないかと推測できる。試しに以下のようなことをしてみた。

user=> (defn hoge [& args] `'~(vec args))
#'user/hoge
user=> (.setMacro #'hoge)
nil
user=> (hoge 1 (+ 2 3))
[(hoge 1 (+ 2 3)) nil 1 (+ 2 3)]
user=>

すべての引数からなるベクタにquoteを付けて返す関数hogeを、setMacroでマクロにする。hoge を (hoge 1 (+ 2 3)) のように呼び出すと、[(hoge 1 (+ 2 3)) nil 1 (+ 2 3)] が結果として返ってくる。返ってきた値の1つめの要素 (hoge 1 (+ 2 3)) が &form で、2つめの要素 nil が &env、3つめ以降の要素がマクロに渡された引数ということのようだ。

&envの正体は？

&formには、名前が表すように、マクロ呼び出しのフォーム全体が渡ってくるようだが、&envの方はいまいちよく分からない。hogeの呼び出しかたを変えて試してみると、

user=> (let [x 0] (hoge 1 (+ 2 3)))
java.lang.RuntimeException: Can't embed object in code, maybe print-dup not defined: clojure.lang.Compiler$LocalBinding@4548e798 (NO_SOURCE_FILE:29)
user=>

上のようなエラーになる。hogeの展開結果に、コードに埋め込めないオブジェクトが含まれている、ということらしい。

そこで、引数&envに渡ってくる値を単に表示するだけのマクロを定義してみる。

user=> (defmacro fuga [] (println &env) nil)
#'user/fuga
user=> (let [x 0] (fuga))
{x #}
nil
user=> (let [x 0] (let [y 1] (fuga)))
{y #, x #}
nil
user=>

出力結果から、&envにはマクロの呼び出しのフォームを囲む静的環境がMapとして渡ってくるようだ。
Mapのキーが、ローカルな束縛の名前を示すシンボルであることは分かるが、値であるLocalBindingについてはよく分からない。と思って調べていたら、まさに同じ質問がちょうと昨日されていたのを発見した。

Google Groups

It contains a LocalBindings object which the compiler uses internally to
keep track of a local binding.  Note that unlike the keys, the values of
&env are not a stable API, they're implementation details and may well
change.  When he added &env I think Rich said he'd look at giving the
values of &env a proper API as part of the future Clojure in Clojure
compiler. 

LocalBinding自体は今はまだ正式なAPIではないようだが、LocalBindingからは束縛が関数の引数か否かといった情報や、束縛の初期化式等が得られるようになっている。これがマクロを通してユーザから利用できるようになるとすれば、かなり強力な仕組みになるだろう。

まとめ

というわけで、今回はこんなことが分かった。

• defmacroでマクロを定義すると、暗黙の引数 &form と &env が追加される
• &formにはマクロ呼び出しのフォーム全体が、&envにはマクロ呼び出しを囲む静的環境が、それぞれ渡ってくる
• &envで渡ってくるMapの値であるLocalBindingからは、束縛に関する種々の情報を得ることができる
  • ただし、まだ正式なAPIではなく、今後変更される可能性もある

*1:これは、Varのメタデータに[:macro true]を追加する操作に相当する

インライン Brainfuck をモナドっぽいなにかで

タイトルは釣り気味？なんとなくStateモナドのつもりで書いていたけど、これをモナドと呼ぶのかは謎。

メインのアイディアは、Brainfuck の各命令を関数で表し、メモリやポインタといった Brainfuck の実行に必要な状態を引き渡していくというもの。

つまり、こんな Brainfuck のコードを

 + + [ < + + > - ]

こんな感じで表す。

(|]| (- (> (+ (+ (< (|[| (+ (+ 初期状態)))))))))

ちなみに、Scheme では "[", "]", ",", "." といった識別子は普通には使えないので、ここでは "|"(パイプ) で囲って "|[|" のようにして使っている。

ただ、これだとコードの順序が逆になるので、

(define (>> x f)
  (lambda (s)
    (let ([s* (x s)])
      (f s*))))

(define-syntax do
  (syntax-rules ()
    [(_ command) command]
    [(_ command commands ...)
     (>> command (do commands ...))]))

として、

((do + + |[| < + + > - |]|) 初期状態)

と書けるようにしている。

Brainfuck の各命令を関数で表そうと思ったとき、"+" や ">" といった命令は簡単に実装できる。問題となるのは "[" と "]" で、それぞれ別の方法で実現している。

まず、"[" から対応する "]" にジャンプする場合は、ある種のフラグを立てておいて、そのフラグが立っている間は "+" や "<" といった通常の命令は何もせず状態をそのまま受け流すようにする。実際には、"[" や "]" はネストできるので単なるフラグではなくて、ネストの深さも見る必要がある。

"]" から対応する "[" にジャンプする場合には継続を使う。継続を積むためのスタックを状態としてもつようにして、"[" に入るごとに継続を捕捉し、その継続のスタックに捕捉した継続をプッシュする。そうすると、"]" でジャンプするときには、スタックのトップにある継続を呼び出してやるだけでいい。

以下、ソースコード。ポータブルなコードにするために、やや冗長に書いている。

brainfuck.scm

;; delayed tree structure for representing brainfuck's ``memory''
(define (make-tree n)
  (define (rec start n)
    (delay
      (if (= n 1)
        0
        (let* ([n/2 (ceiling (/ n 2))]
               [n-n/2 (- n n/2)])
          (list (- n/2 1) (rec start n/2) (rec (+ start n/2) n-n/2))))))
  (rec 0 n))

(define (get t n)
  (let ([t (force t)])
    (if (list? t)
      (if (<= n (car t))
        (get (cadr t) n)
        (get (caddr t) n))
      t)))

(define (update t n f)
  (delay
    (let ([t (force t)])
      (if (list? t)
        (if (<= n (car t))
          (list (car t) (update (cadr t) n f) (caddr t))
          (list (car t) (cadr t) (update (caddr t) n f)))
        (f t)))))

;; for debug
(define (tree->list t)
  (let ([t (force t)])
    (if (list? t)
      (append (tree->list (cadr t))
              (tree->list (caddr t)))
      (list t))))

(define-syntax receive
  (syntax-rules ()
    [(_ args expr body ...)
     (call-with-values (lambda () expr)
       (lambda args body ...))]))

;; monadic stuffs
(define (>> x f)
  (lambda (m p c d)
    ;(print #`",(tree->list m) ,p ,c ,d")
    (receive (m* p* c* d*) (x m p c d)
      (f m* p* c* d*))))

(define-syntax do
  (syntax-rules ()
    [(_ command) command]
    [(_ command commands ...)
     (>> command (do commands ...))]))

;; driver
(define (run-bf x n)
  (receive (m p c d)
      (x (make-tree n) 0 '() 0)
    (if (or (not (null? c))
            (not (= d 0)))
      (error "unexpected EOF"))
    m))

;; utilities for defining actions
(define (with-depth-checked f)
  (lambda (memory pointer cont depth)
    (if (= depth 0)
      (receive (m p) (f memory pointer)
        (values m p cont depth))
      (values memory pointer cont depth))))

(define (standard-insn f g)
  (with-depth-checked
    (lambda (memory pointer)
      (values (update memory pointer f) (g pointer)))))

(define id (lambda (x) x))

(define (inc n)
  (+ n 1))

(define (dec n)
  (- n 1))

;; definitions of actions
(define >. (standard-insn id inc))
(define <. (standard-insn id dec))
(define +. (standard-insn inc id))
(define -. (standard-insn dec id))

(define |,|
  (with-depth-checked
    (lambda (m p)
      (let ([v (char->integer (read-char))])
        (values (update m p (lambda (_) v)) p)))))

(define |.|
  (with-depth-checked
    (lambda (m p)
      (let ([c (integer->char (get m p))])
        (write-char c)
        (values m p)))))

(define (|[| m p c d)
  (if (= d 0)
    (if (= (get m p) 0)
      (values m p c (inc d))
      (receive (m* p* c*) 
          (call/cc
            (lambda (k)
              (values m p (cons k c))))
        (values m* p* c* d)))
    (values m p c (inc d))))

(define (|]| m p c d)
  (if (null? c)
    (error "extra close bracket"))
  (if (= d 0)
    (if (= (get m p) 0)
      (values m p (cdr c) d)
      ((car c) m p c))
    (values m p c (dec d))))

;; example
(define hello-world!
  (do >. +. +. +. +. +. +. +. +. +.
      |[| <. +. +. +. +. +. +. +. +. >. -. |]|
      <. |.| >. +. +. +. +. +. +. +.
      |[| <. +. +. +. +. >. -. |]| <. +. |.|
      +. +. +. +. +. +. +. |.| |.| +. +. +. |.|
      |[| -. |]| >. +. +. +. +. +. +. +. +.
      |[| <. +. +. +. +. >. -. |]| <. |.|
      >. +. +. +. +. +. +. +. +. +. +. +.
      |[| <. +. +. +. +. +. >. -. |]| <. |.|
      >. +. +. +. +. +. +. +. +.
      |[| <. +. +. +. >. -. |]| <. |.|
      +. +. +. |.| -. -. -. -. -. -. |.|
      -. -. -. -. -. -. -. -. |.|
      |[| -. |]| >. +. +. +. +. +. +. +. +.
      |[| <. +. +. +. +. >. -. |]| <. +. |.|
      |[| -. |]| +. +. +. +. +. +. +. +. +. +. |.|))

ちなみに、"+", "-", ">", "<" という識別子は Scheme としては使えるのだけど、これらを Brainfuck の命令として使うと、組込みの関数を上書きしてしまうことになるため、ここではそれぞれ "+.", "-.", ">.", "<." を使っている(Gauche の場合は、"+." や "-." でも組込み関数を上書きしてしまうことにはなるけど)。

run-bf という関数に Brainfuck のコードと使用するメモリのサイズを渡すと Brainfuck のコードが実行され、終状態でのメモリが返ってくる。

実行例は下のようになる。

gosh> (tree->list (run-bf (do +. >. +. +. >. +. +. +.) 3))
(1 2 3)
gosh> (tree->list (run-bf hello-world! 3))
Hello World!
(10 0 0)
gosh>

というわけで、インラインで Brainfuck が書けるようになったので、次回インラインWhitespaceの実装にご期待下さい(嘘