備忘録とチラシの裏を兼ねる
これは末尾再帰で木を走査で色々調べたときの副産物だけど、Gauche ユーザリファレンスの3.6.2 パフォーマンスに関するヒント曰く、
深い再帰: Gauche の仮想機械(VM)は効率的なローカルフレーム割り当てのためにスタックを使っています。再帰が深くなって(プログラムにもよりますが、大体数百回から千回) スタックがオーバーフローするとスタックの内容をヒープに退避するというオーバーヘッドが生じます。 あるデータ量を越えたところでパフォーマンスの低下が見られたならば、深い再帰がないか調べてみて下さい。
とのこと。マジですかと思って、件のエントリで使った非末尾再帰のcopy-treeに10^6の要素を持つリストを渡してみたら、スタックがあふれることなく普通に動いた。これは便利。
何年か前、Scheme:末尾再帰で木をトラバースを読んだときは何をしてるかさっぱりだったんだけど、今なら分かるんじゃないかなー、と思って暇な時間に考えてたら自分でも書けたので、結果に至る過程を記録。
ちょっとアレンジして、木のコピーを例に考える。まずは、普通の再帰で素直に書いてみる。
;; 素朴な木のコピー
(define (copy-tree tree)
(let loop ((node tree))
(if (pair? node)
(cons (loop (car node)) (loop (cdr node)))
node)))単純で分かりやすい。これをベースに、継続渡しスタイルを利用して末尾再帰のコードに変換してみる。人力CPS変換。
ちなみに、継続渡しスタイルについての詳しい話や、継続渡しスタイルと末尾再帰（末尾呼び出し）の関係についての説明は、ここではしない。他人に色々説明できるほど深く理解をしているわけじゃないので。詳しく知りたい人は、先人の書いた良い文章があると思うから、そちらを読んで欲しい。例えばThe 90 minute Scheme to C compilerとか。
とりあえず、最初に最終的なコードから。
;; 継続渡しスタイルによる末尾再帰な木のコピー
(define (copy-tree tree)
(let loop ((node tree)
(cont values))
(if (pair? node)
(loop (car node)
(lambda (x)
(loop (cdr node)
(lambda (y)
(cont (cons x y))))))
(cont node))))再帰に馴染みがないと、見た瞬間に心理的に3メートルくらい引くと思う。今あらためて見たら、書いた自分でも1メートルくらい引いた。だけど、段階を踏めばそんなに意味不明でもないので、あまり心配しなくても良い。
最初の素直な再帰の例に戻って、
;; 素朴な木のコピー
(define (copy-tree tree)
(let loop ((node tree))
(if (pair? node)
(cons (loop (car node)) (loop (cdr node)))
node)))まず、継続を渡していくための引数が必要になる。ここでは、contという引数を増やす。なお、継続に定番のkとかいう名前を代わりに付けると、そっち方面への馴染みが薄い人への攻撃力をさらに強化できる。継続の中身はまだ考えない。
;; 継続渡しのために引数を増やす
(define (copy-tree tree)
(let loop ((node tree)
(cont ))
(if (pair? node)
(cons (loop (car node)) (loop (cdr node)))
node)))次に、最初にcontに指定する継続を考える。つまり、コピーし終わった木を受け取る、一番最後に実行される継続。copy-treeはコピーした木を返す手続きにしたいので、受け取った値をそのまま返す継続が良い。(lambda (x) x)とかでも良いけど、出来合いで、より省タイプなvaluesを使う。最近はCommon Lispに染まっていたのでidentityを探したが、なかった。
;; 最初に指定する継続はvalues
(define (copy-tree tree)
(let loop ((node tree)
(cont values))
(if (pair? node)
(cons (loop (car node)) (loop (cdr node)))
node)))継続渡しスタイルでは、値を返す代わりに、値を渡して継続を呼ぶので、値を返す部分はすべて継続の呼び出しになる。この例では二ヶ所。
;; 値を返す部分で継続を呼ぶ
(define (copy-tree tree)
(let loop ((node tree)
(cont values))
(if (pair? node)
(cont (cons (loop (car node)) (loop (cdr node))))
(cont node))))そして本題。loopの再帰呼び出しのときに指定する継続について考える。まずは(loop (car node))から。
(loop (car node))の継続、つまり、(loop (car node))が返す値をどうしたいのかという話だけど、ご覧の通り、(loop (cdr node))が返す値とペアを作りたい。そして、それを継続contに渡したい。コードで表現するとこうなる。
;; (loop (car node))の継続
(lambda (x)
(cont (cons x (loop (cdr node)))))継続が分かったので、実際のコードに当てはめてみる。
;; (loop (car node))を継続渡しスタイルに変更
(define (copy-tree tree)
(let loop ((node tree)
(cont values))
(if (pair? node)
(loop (car node)
(lambda (x)
(cont (cons x (loop (cdr node))))))
(cont node))))同じように、次は(loop (cdr node))の継続についても考えてみる。xとペアを作り、contに渡したいので、
;; (loop (cdr node))の継続
(lambda (y)
(cont (cons x y)))となる。これを実際のコードに当てはめると、
;; (loop (cdr node))を継続渡しスタイルに変更
(define (copy-tree tree)
(let loop ((node tree)
(cont values))
(if (pair? node)
(loop (car node)
(lambda (x)
(loop (cdr node)
(lambda (y)
(cont (cons x y))))))
(cont node))))最初に紹介したコードと同じになった。ご覧の通り、二ヶ所ある再帰は両方とも末尾呼び出しになっている。
実際に試してみると、
gosh> (let* ((t1 '(0 1 2))
(t2 (copy-tree t1)))
(values (eq? t1 t2) (equal? t1 t2) t2))
#f
#t
(0 1 2)
gosh> (let* ((t1 '(0 (1 2)))
(t2 (copy-tree t1)))
(values (eq? t1 t2) (equal? t1 t2) t2))
#f
#t
(0 (1 2))
gosh> (let* ((t1 '(0 ((1) 2) 3))
(t2 (copy-tree t1)))
(values (eq? t1 t2) (equal? t1 t2) t2))
#f
#t
(0 ((1) 2) 3)
gosh> 意図した通りの動作をしてる模様。めでたし。
以下おまけ。Common Lispに（中略）ので、constantlyを探したがなかったため、(lambda _ 1)。
;; 共通のwalkerを定義
(define (tree-walk tree leaf-proc inner-proc)
(let loop ((node tree)
(cont values))
(if (pair? node)
(loop (car node)
(lambda (x)
(loop (cdr node)
(lambda (y)
(cont (inner-proc x y))))))
(cont (leaf-proc node)))))
;; 木のコピー
(define (copy-tree tree)
(tree-walk tree values cons))
;; 葉を数える
(define (count-leaf tree)
(tree-walk tree (lambda _ 1) +))
;; 葉を文字列に変換した木を作る
(define (copy-tree/string-node tree)
(tree-walk tree
(lambda (x)
(if (null? x) x (x->string x)))
cons))関数型便利。
Scheme:マクロの効用のリストの構築で、cond-consというマクロが紹介されてるけど、Common Lispで欲しくなったので書いてみた。
(defmacro cond-cons (&rest clauses)
(labels ((rec (clauses)
(if clauses
(let ((clause (car clauses))
(r (rec (cdr clauses))))
`(if ,(car clause) (cons (progn ,@(cdr clause)) ,r) ,r))
nil)))
(rec clauses)))一瞬、rが複数回評価されて、副作用があるとまずいんじゃ、とか思ったけど、考えたらifで分岐するから問題なかった。
マクロなのに末尾再帰版。すみません。大好きです末尾再帰。
(defmacro cond-cons (&rest clauses)
(labels ((rec (clauses fn)
(if clauses
(let ((clause (car clauses)))
(rec (cdr clauses)
(lambda (x)
`(if ,(car clause)
(cons (progn ,@(cdr clause)) ,(funcall fn x))
,(funcall fn x)))))
`(nreverse ,(funcall fn nil)))))
(rec clauses (lambda (x) x))))コンパイル時にしか評価されないので、ほとんど意味がない。末尾再帰じゃないバージョンだとスタックが溢れるくらい、clausesが長いリストだったりするなら多少は意味があるだろうけど、それってどんなだよ。
Paul Grahamも同じ趣旨のことをOn Lispかどこかに書いてたように思うけど、マクロ定義のコードで頑張る意味なんてない。
ちなみに、Gaucheでは、util.listにcond-listという名前で、より高機能なものが収録されている。何でそんなことを書くかというと、以前探したときに、しばらく見付けられなかったからではない。そんなわけはない。
オプション引数の処理がad hocなのは仕様です。
(use gauche.charconv)
(use srfi-1)
(use srfi-13)
(use srfi-19)
(use rfc.822)
(use rfc.http)
(use rfc.uri)
(use sxml.ssax)
(use sxml.sxpath)
(use sxml.tools)
(use util.list)
(define-reader-macro (feed url . args)
(define *item-max* 10)
(define *date-format* "~Y/~m/~d")
(define *item-format* "(~a) ~a")
(define *ns*
'((atom . "http://www.w3.org/2005/Atom")
(openSearch . "http://a9.com/-/spec/opensearchrss/1.0/")
(georss . "http://www.georss.org/georss")
(thr . "http://purl.org/syndication/thread/1.0")
(rss1 . "http://purl.org/rss/1.0/")
(rdf . "http://www.w3.org/1999/02/22-rdf-syntax-ns#")
(content . "http://purl.org/rss/1.0/modules/content/")
(dc . "http://purl.org/dc/elements/1.1/")
(foo . "bar")))
(define (w3cdtf->date str)
(define (df->nano df)
(string->number (string-pad-right (number->string df) 9 #\0)))
(and-let*
((match (#/^(\d\d\d\d)(?:-(\d\d)(?:-(\d\d)(?:T(\d\d):(\d\d)(?::(\d\d)(?:\.(\d+))?)?(?:Z|([+-]\d\d):(\d\d)))?)?)?$/ str)))
(receive (year month day hour minute second df zh zm)
(apply values (map (lambda (i) (x->integer (match i))) (iota 9 1)))
(make-date (df->nano df)
second minute hour day month year
(* (if (negative? zh) -1 1)
(+ (* (abs zh) 3600) (* zm 60)))))))
(define *feed-attributes*
`((atom
(converter
,(sxpath '(// atom:entry atom:title *text*))
,(sxpath '(// atom:entry
(atom:link (@ (equal? (rel "alternate"))))
@ href *text*))
,(sxpath '(// atom:entry atom:published *text*)))
(date-parser . ,w3cdtf->date))
(rss1
(converter
,(sxpath '(// rss1:item rss1:title *text*))
,(sxpath '(// rss1:item rss1:link *text*))
,(sxpath '(// rss1:item dc:date *text*)))
(date-parser . ,w3cdtf->date))
(rss2
(converter
,(sxpath '(// item title *text*))
,(sxpath '(// item link *text*))
,(sxpath '(// item pubDate *text*)))
(date-parser . ,rfc822-date->date))))
(define (feed-attr type field)
(cdr (assoc field (cdr (assoc type *feed-attributes*)))))
(define (decompose-uri url)
(receive (_ specific) (uri-scheme&specific url)
(uri-decompose-hierarchical specific)))
(define (authority&path?query url)
(define (path?query path query)
(with-output-to-string
(lambda ()
(display path)
(when query (format #t "?~a" query)))))
(receive (authority path query _) (decompose-uri url)
(values authority (path?query path query))))
(define (feed-get url)
(receive (authority path?query) (authority&path?query url)
(receive (status header body) (http-get authority path?query)
(unless (equal? status "200")
(error "フィードの読み込みに失敗しました。ステータスコードは~aです。"
status))
(if (or (null? args) (null? (cdr args)))
body
(ces-convert body (cadr args))))))
(define (feed->sxml feed)
(with-input-from-string feed
(cut ssax:xml->sxml (current-input-port) *ns*)))
(define (feed-type-of sxml)
(define root-node ((car-sxpath '(*)) sxml))
(define (rss1?)
(eq? (sxml:name root-node) 'rdf:RDF))
(define (rss2?)
(and (eq? (sxml:name root-node) 'rss)
(equal? (sxml:attr root-node 'version) "2.0")))
(define (atom?)
(eq? (sxml:name root-node) 'atom:feed))
(cond ((rss1?) 'rss1)
((rss2?) 'rss2)
((atom?) 'atom)
(else (error "対応していない種類のフィードです。"))))
(define converter-title car)
(define converter-link cadr)
(define converter-date caddr)
(define (take-item-max nodes)
(let1 n (if (null? args) *item-max* (car args))
(take* nodes n)))
(let* ((feed (feed->sxml (feed-get url)))
(type (feed-type-of feed))
(conv (feed-attr type 'converter))
(proc (feed-attr type 'date-parser))
(title (converter-title conv))
(link (converter-link conv))
(date (converter-date conv)))
`((ul ,@(map (lambda (title link date)
`(li (a (@ (href ,link))
,(format #f *item-format*
(date->string (proc date) *date-format*)
title))))
(take-item-max (title feed))
(take-item-max (link feed))
(take-item-max (date feed)))))))WiLiKiのrssmix.scmを参考に、W3C-DTFの文字列をSRFI 19の日付オブジェクトに変換する関数を書いた。
(use srfi-1)
(use srfi-13)
(use srfi-19)
(define (w3cdtf->date str)
(define (df->nano df)
(string->number (string-pad-right (number->string df) 9 #\0)))
(and-let*
((match (#/^(\d\d\d\d)(?:-(\d\d)(?:-(\d\d)(?:T(\d\d):(\d\d)(?::(\d\d)(?:\.(\d+))?)?(?:Z|([+-]\d\d):(\d\d)))?)?)?$/ str)))
(receive (year month day hour minute second df zh zm)
(apply values (map (lambda (i) (x->integer (match i))) (iota 9 1)))
(make-date (df->nano df)
second minute hour day month year
(* (if (negative? zh) -1 1)
(+ (* (abs zh) 3600) (* zm 60)))))))Gauche 0.8.14をSun Studio Express November 2008でビルドできるか？ 結論から言えば、できる。でもやる価値があるとは思えない。ただし、調べた内容を捨てるのも勿体無いので、大筋だけ記録しておく。詳細は省く。
configureしてからmakeすると、libgauche.soが生成されずにエラーになる。これは、Gaucheのconfigureの問題。SHLIB_SO_LDFLAGSの-hを-oに置き換えてやれば、処理が進むようになる。
次に、いくつかのシンボルが定義されていないというエラーが出る。これはBoehm GCの問題。SunのCコンパイラでビルドする場合にIA-32がサポートされていないのが原因。ただし、抜け道を使える。AO_USE_PTHREAD_DEFSマクロを定義してビルドすれば、本来の処理をPOSIXスレッドのロックでエミュレートしてくれるので、それを使う。加えて、強制的にSPARC向けのアセンブリコードを使うようになっているので、configureの該当する部分をコメントアウト。need_atomic_ops_asmがtrueでなければ、アセンブリコードは使われない。
以上の修正で、最後までビルドできる。ただ、Boehm GCがIA-32のSun Studioをサポートしていないのは変わらないし、AO_USE_PTHREAD_DEFSは遅いとドキュメントにも書かれている。GCCを使えば、こんな手間は必要ないんだから、余程の理由がない限り、GCCを使う方が良いだろう。
使ってて思ったこと。
モナド的な何かに向かってを見て、when-bindみたいなマクロなら、Gaucheにもありそうだと思って探したところ、やっぱりあった。
(let ((the-value (func-which-returns-useful-value-or-#f)))
(if the-value
(do-something-based-on the-value)))こういう処理を、
(and-let* ((the-value (func-which-returns-useful-value-or-#f)))
(do-something-based-on the-value))こう書ける。条件式が減らせて見通しも良くなる。
なお、束縛する変数がひとつの場合、例によって、if-let1というGauche独自のマクロがあり、
(if-let1 the-value (func-which-returns-useful-value-or-#f)
(do-something-based-on the-value))のように書ける。
ただ、and-let*にしても、if-let1にしても、変数への束縛がある分、参照元の>>=より冗長になってしまうので、そういうパターンがかなりの頻度で現われるなら、束縛まで省略できる手続きを自分で定義した方が良いかもしれない。Haskellを知らない自分としては、>>=だと分かりづらいから、and-composeとかだろうか。
(use gauche.process)
(define current-code-page
(let1 cp #f
(lambda ()
(unless cp
(set! cp ((#/: (\d+)$/ (process-output->string '(chcp))) 1)))
cp)));; pathに不完全文字列になるエントリがあるとエラー
(directory-list path)
;; 低レベルならエラーになる処理は含まれない
(sys-readdir path)Gaucheのfile.utilは0.8.14の現時点では、パスがASCII以外でエンコードされているケースを考慮してないので、CP932などでエンコードされたパスを処理する場合、エラーになることがある。具体的には、パスにGaucheの内部エンコードで許されないバイト表現が含まれる場合。パスは不完全文字列として処理されるけど、不完全文字列には許されない処理をfile.utilの各関数内部でしているため、エラーになる。
他の人が原因を見つけてそうだな、と思いながらも、コードを読んで原因を見つけたところで、やっぱり他の人が原因を見つけていたのを知った。Gauche-devel-jpメーリングリストの「パス名での不完全文字列の扱い」というメールに詳しい。徒労だ。
正確に言うとAutoconf 2.61の問題なんだけど、GCCを使っていても、CCの値が（/opt/pkgsrc/bin/gccのように）パスを含む場合、configureスクリプトが使っているコンパイラを誤判定する。これにより、リンカに間違ったオプションが渡され、libgauche.soのリンクに失敗してしまう。
このくらい良きに計らってくれよ、と目眩がする思いだが、現時点の最新版のAutoconf 2.62では直っているのだろうか。
もう一度詳しく調べたところ、Gauche 0.8.13のconfigure.acに問題があった。Autoconf関係者の方々、ごめんなさい。