Syntax highlighter

2012-08-30

パラメタ

Schemeのparameterはわざわざ評価してやらないと値が取れないから使うのが面倒だ、と常々思っていたのだが、
識別子マクロとパラメタによる大域変数エミュレート
にそれを解消するマクロが紹介されていた。確かに、ぱっと見よさげだなぁと思ったのだが、これってSRFI-39が提供するparameterizeマクロと相性最悪じゃね?と思ってちょっと実験してみた。
(import (rnrs) (srfi :39))
(define-syntax define-identifier-parameter
  (syntax-rules ()
    ((_ var val)
     (begin
       (define t (make-parameter val))
       (define-syntax var
         (make-variable-transformer
          (lambda(x)
            (syntax-case x (set!)
              ((set! _ a) #'(t a))
              (_ #'(t))))))))))
(define-identifier-parameter *variable* 1)
(display *variable*) (newline)
(parameterize ((*variable* 2)) (display *variable*) (newline))
(display *variable*) (newline)
検証はいつもどおり、Sagittarius、YpsilonにMosh。
っで結果:
Sagittarius
Ypsilon
1を3回出力。(parameterizeされてない)
Mosh
&assertion: (1)は関数じゃないと怒られた
ふむ、パラメタはparameterizeと一緒に使われること(というか、僕は常にそれを想定)が多いと思うので、これだと、値が変更できるライブラリ変数という位置づけでしか使えないということだろうか?
面白いけど、使いどころが限定されそうだ。

2012-08-29

{}の扱い

SRFI-105関連なのか、R7RSのGoogle Groupsに以下の投稿があった。

From   John Cowan
I know it's the last minute, but I've just a filed a ticket to add [ ] { }
to the list of delimiters, along  with ( ) " ; | and whitespace.
Implementations do use them for various things (R6RS systems of course
treat brackets as equivalent to parens), but I can't see people using them as
parts of identifiers (though some Schemes do allow it).
R6RSでは「[]」は使われているけど、「{}」ってそうでもないよなぁと思いちょっとテスト。試した処理系はYpsilon、Mosh、Petite Chez SchemeとSagittarius。(なんで自分の処理系もかって?忘れてるからだよ、言わせんな恥ずかしい///)
単発の「{」と「}」に加えて「{-reader」と「}-reader」というシンボルを読ませる。っで、結果。
処理系 { } {-reader }-reader
Ypsilon reader error
Mosh reader error
Petite \x7B; \x7D; unbound variable \x2D;reader
Sagittarius |{| |}| |{-reader| |}-reader|
R6RSのリーダの定義(読めよ)を忘れたのでどれが正しい動作かはよく分からないけど、Ypsilon、Moshはシンボルに「{}」は使えない。Petiteは「{}」はデリミタになるので、事実上使えないっぽい。Sagittariusは特別視していないらしい。
ちなみに、Gaucheでは「{}」もリストを読むのに使えるので、エスケープなしではシンボルとして読まない。

これをシンボルとして読み込んでうれしいことはあまり無い気もするのだが、R7RSの精神がミニマリズムなのであれば、実装者から自由を奪うのは多少その精神から外れる気がする。

追記:
Sagittariusでも#!r6rsをつけるとYpsilon、Moshと同じ動作になる。
R6RS的には「{}」はシンボルに使ってはいけない文字である。(調べた)

2012-08-27

SRFI-105を試してみる。

リーダをいじる系のSRFIを割りと簡単に試すことが出来るのもSagittariusの特徴の一つだと信じているので、早速新SRFIを試してみる。
(自分でも使い方忘れてて、ドキュメントを探したのは内緒だ)
;; From reference implementation

;; Return true if lyst has an even # of parameters, and the (alternating)
;; first parameters are "op".  Used to determine if a longer lyst is infix.
;; If passed empty list, returns true (so recursion works correctly).
(define (even-and-op-prefix? op lyst)
  (cond
   ((null? lyst) #t)
   ((not (pair? lyst)) #f)
   ((not (eq? op (car lyst))) #f) ; fail - operators not the same
   ((not (pair? (cdr lyst)))  #f) ; Wrong # of parameters or improper
   (else (even-and-op-prefix? op (cddr lyst))))) ; recurse.

;; Return true if the lyst is in simple infix format
;; (and thus should be reordered at read time).
(define (simple-infix-list? lyst)
  (and
   (pair? lyst)           ; Must have list;  '() doesn't count.
   (pair? (cdr lyst))     ; Must have a second argument.
   (pair? (cddr lyst))    ; Must have a third argument (we check it
                    ; this way for performance)
   (symbol? (cadr lyst))  ; 2nd parameter must be a symbol.
   (even-and-op-prefix? (cadr lyst) (cdr lyst)))) ; true if rest is simple

;; Return alternating parameters in a list (1st, 3rd, 5th, etc.)
(define (alternating-parameters lyst)
  (if (or (null? lyst) (null? (cdr lyst)))
      lyst
      (cons (car lyst) (alternating-parameters (cddr lyst)))))

;; Not a simple infix list - transform it.  Written as a separate procedure
;; so that future experiments or SRFIs can easily replace just this piece.
(define (transform-mixed-infix lyst)
  (cons 'nfx lyst))

;; Given curly-infix lyst, map it to its final internal format.
(define (process-curly lyst)
  (cond
   ((not (pair? lyst)) lyst) ; E.G., map {} to ().
   ((null? (cdr lyst)) ; Map {a} to a.
    (car lyst))
   ((and (pair? (cdr lyst)) (null? (cddr lyst))) ; Map {a b} to (a b).
    lyst)
   ((simple-infix-list? lyst) ; Map {a OP b [OP c...]} to (OP a b [c...])
    (cons (cadr lyst) (alternating-parameters lyst)))
   (else  (transform-mixed-infix lyst))))

;; set macro characters
(set-macro-character 
 #\{ (lambda (p c) (process-curly (read-delimited-list #\} p))))
(set-macro-character 
 #\} (lambda (p c) (error '|}-reader| "unexpected #\\}")))

;; test
(print '{a + b})
(print '{a * {b + c}})

#|
;; output
(+ a b)
(* a (+ b c))
|#
なんとお手軽。
ポイントは、閉じ括弧もリードマクロとしてマークすること。じゃないとread-delimited-listがnon-termな文字として識別しちゃうので、意味不明のエラーが出て悩む。(ってか、3分くらい悩んだ・・・orz)

これくらいお手軽に試せるからいいけど、そうじゃない処理系はこれを入れる気になるんだろうか?そこまで中置記法にこだわる理由が(もはや)分からない。

2012-08-26

Libraryのルックアップ

ずっと悩んでいる問題の一つ。
SagittariusではR6RSが禁止しているexportされたシンボルの上書きを許している。理由はその方が便利だから。

ただ、これ便利なんだけど、プログラマが重複するシンボルを含むライブラリをimportした際にどちらが使われるのか意識できないと拙い。Sagittariusでは「後からimportしたものが使用される」というルールを作っている。もちろん明にexceptとか使えば問題ない。ただ、スクリプトとして走らせた際がちょっと困って、既にimportされているライブラリがトップレベルにある。

直接exportされているものなら別に問題ないんだけど、問題になるのは間接的にexportされているもの。SRFIライブラリなんかはもろにこれで、
(import (srfi :1))
とかってやると全部間接的に解決される。っで、上記の例でトップレベルでは既に(rnrs)がimportされているので、removeとか使うと、SRFI-1の方を使って欲しいのに、R6RS定義の方が使われて悲しい思いをする。

原因は0.3.5までは、間接解決されたものは解決リストの末尾に追加されているため。これではいろいろまずいので修正した。
修正方法は非常に単純な発想で、直接importの次に間接importを追加してから既にある解決リストを追加するというもの。
今まで不便だなぁと思いつつ放っておいたのだが、重い腰をよっこらせっとあげた。これで今まで明示的に
(import (srfi :1 lists))
と上記の問題を回避するために書いていたのをやらなくても済む、はず。

2012-08-23

スライドを作ってみた

別にどこかで発表するわけでもないのに、スライドを作ってみた。

Sagittarius 0.3.5リリース

Sagittarius Scheme 0.3.5がリリースされました。今回のリリースはメンテナンスリリースです。

修正された不具合
  • format関数が長さを指定した際に空文字を返す不具合が修正されました。
  • EMSA-PSSを用いた検証がときどき失敗する不具合が修正されました。
  • SRFI-13ライブラリにあるxsubstringが&assertionを投げる不具合が修正されました。
新たに追加された機能
  • ライブラリ名に負の数でない正確数が使用可能になりました。R7RS 6th ballot
  • vector-append、bytevector-append (R7RS 6th ballot)、vector-concatenate及びbytevector-concatenateが追加されました。
  • 即値な浮動小数点数がサポートされました。(現状では5の倍数以外には適用されません)
  • (eqv? 0.0 -0.0)が#fを返すように修正されました。(R6RS及びR7RS 6th ballot)
  • port-for-each、port-mapが(util port)に追加されました。
  • drop*が(util list)に追加されました。
改善点
  • utf8->string、string->utf8、bytevector->string及びstring->bytevectorがオプショナル引数startとendを受け取るようになりました。
  • equal?がレコードの中を再帰的に調べるようになりました。
  • (exit #t)が(exit)または(exit 0)と同様の振る舞いをするようになりました。(R7RS 6th ballot)
  • Windows版のバイナリがMSVD*.dllを必要としなくなりました。
  • 正規表現の速度が改善されました。
  • list-sortの速度が改善されました。
新たに追加されたライブラリ
  • RFC 4122 ライブラリ(rfc uuid)が追加されました。
  • RFC 1421 ライブラリ(rfc pem)が追加されました。
新たに追加されたドキュメント
  • (util list)がドキュメント化されました。
  • (sagittarius io)がドキュメント化されました。

2012-08-22

続 正規表現エンジンのチューニング

とりあえず、昨日のコードがGauche(0.9.3)と同程度の速度が出るように改善できた。

やったこと
  1. 疎な配列をエミュレートしていたのだけれど、それに付随していたイテレータの削除
    • 10%程度
  2. 地味にコードのリファクタリング
    • 10%程度
  3. インストラクションコードの2番目がアトムチェックのコードならマッチする場所までチェックする
    • これが効いた、900% 
もともと昨日のコードでは、1000個の'a'と'01:23'という文字列が1000回繰り返して最後に':45'とつくのだけれど、途中の'a'の部分は絶対にマッチしないくせにわざわざキュー操作していたのがまずかったのだ。なら、最初にマッチする場所まで先読みしてやれよかったという話。

現状ではものすごく手抜きな先読みなので、#/(\d\d):\d\d:\d\d/と変更されるだけで遅くなるんだけど。また気になったら直すことにしよう。

2012-08-21

正規表現エンジンのチューニング

SagittariusではRE2(Pike VM?)ベースの正規表現エンジンを積んでいて(実際にはハイブリッドなのだが、今回はこっちのエンジンが対象)、基本的な正規表現ならO(n)で走る。実際にはO(n+α)だったりするが、O(n)でいいだろう。リニアに走るなら速度はそんなに気にしなくてもいいんじゃないかと思うのだが、以下のようなコードを走らせると不満が出るほど遅い。
#< (sagittarius regex) >
(import (time) (srfi :1)
 (text tree)
 (sagittarius control)
 (sagittarius regex)
 (only (sagittarius regex impl) dump-regex))

(define s
  (tree->string `(,(make-list 1000 `(,(make-string 1000 #\a) "01:23")) ":45")))

(define (time-this count thunk)
  (time (dotimes (i count) (thunk))))

(print (time-this 10 (^[] (#/\d\d:\d\d:\d\d/ s))))
以下が実行結果(Cygwin on Windows XP CoreDuo 1.6GHz)
$ sash reg.scm

;;  (dotimes (i count) (thunk))
;;  2.921875 real    2.969000 user    0.000000 sys
#t
ちょっとねぇ・・・とりあえず、本質的な問題を脇に置いておいて、不必要な計算を減らして400ms程度速くしたのだが、やはり枝葉の最適かなので2割程度にしかならない。

何が問題か?エンジンの走り方以外の何者でもないのだが・・・
 PikeVMはバックトラックをしないNFAなエンジンである。っで、バックトラックさせない為に、内部で仮想スレッドとスレッドキューを持っていて、一文字チェックする毎にスレッドキューに次に実行させるインストラクションとマッチした状態を保存したスレッドを溜め込む。文字がマッチしなければキューにあるスレッドは1個なんだけど、例えば4文字までマッチしたスレッドがあるとすると、他にも3スレッド脇で走っていたりする。
以上を踏まえて、上記のコードを見ると、途中で「01:23」と4文字マッチして、捨てられるという処理が1000回ほど必要になる。そのため、内部で回すスレッドの関係でガッツリ遅くなる。のではないかと結論付けている。
現実的にこれほどベンチマークに特化したかのような入力文字列の処理が必要になるかどうかは別にしても、遅いというのは悪であるのでなんとかしたい。しかし、問題の幹の部分はそれこそ正規表現エンジン自体を改善(可能ならDFAにするとか)しないと無理なので、そこまで大掛かりにしたくない(ものぐさ)。
とりあえず、やってみて効果のあったもの。
  • 不要コードの削除
  • キューをクリアするに最小限の要素のみクリア
無駄だったもの
  • 急場のダイレクトスレッドコード
枝葉のチューニングではこの程度が限界だろうか?せめて倍速まで持っていきたいのだが、う~ん。

2012-08-17

Lisp啓蒙活動(?)

自動SQL生成スクリプトを書いているときに、同僚がふと作業風景を覗き込んできた際に発生した会話から。
Colleague: You like Emacs, don't you?
Me: I do.
Colleague: Is it Lisp?
Me: Sort of. (It's Scheme but I think Sagittarius is already sort of 'MY LISP' now...)
Colleague: It's one of the languages I can't understand?
Me: It's not so difficult, you know?
Colleague: It is. I don't think I can accept the parenthesis.
Me: (I wish I could show this site : 本当にLispはカッコが多い?)
これ以外にも、なんだか毛嫌いというか、Lispは近寄りがたいみたいな雰囲気で話すので、なんでだろうなぁ?と思い考えてみた。
そういえば僕も昔はLispを避けていたのだから、似たような考えがあって、何かがきっかけで考えが変わったはずである。っで、避けていた理由を探してみた。
  1. Lisp入門のサイトとかで必ずある「consとリスト」の解説。
    •  正直読んでも、だから何ができるの?という気になった。
    •  更に、なんか面倒だなぁという気にさせられた。
  2. How to become a hackerの悟り体験の話。
    • なんだか小難しい言語ではないのかという錯覚を起こさせた。
  3. 関数型言語と再帰。
    • 手続き型言語から始めると再帰の概念は分かりにくい。(少なくとも僕はそうだった)
  4. 無名関数、クロージャ、高階関数。
    • 手続き型、以下略。
    • これに関しては、言語ごとに(特にクロージャ)定義が違うのも問題な気がする。
  5. lambdaという言葉。 
    • boost::lambdaでlambda = 無名関数 = クロージャみたいな理解したなぁ。(遠い目)
とりあえず、思いついただけではこんな感じ。じゃあ、何がこのとっつきにくさを変えたかという点だけど、これは正直よくわからない・・・SICP読み始めて、処理系作り出して、折角作ってるんだし使い倒さないとと言うのが最初のモチベーションだった気がする。

それではあまりにもと思うので、啓蒙するにはどうすればいいか。
※僕が考える最強の啓蒙活動的な感じです。当てにしないでください
  1. 可能な限りシンプルに、かつC言語とかの最初のステップに合わせる。
    • Hello Worldでもいいし、ファイルを一行処理してとかでもいいと思う。
    • いきなり、consとリストではひく。
  2. エディタの支援を当てにしてもいいということを教える。
    • 括弧の対応とか目視では無理。
    • Emacs最強(これも啓蒙してしまえ!)
    • S式一個切り取って貼り付けとか知ると、Javaとか面倒すぎて編集する気になれなくなるはず。
  3. 再帰を可能な限り隠す。
    • CLならloopで大抵いけると思う。
    • Schemeならnamed letで。
  4. クロージャは単なる関数だとしておく。
    • 名前に臆することもあるよね?
  5. でも、処理系がたくさんあってどれ使えばいいのさ?
    • 入門レベルのCLならどれでもいいはず。
    • Schemeは、Gaucheかなぁ。実績あるし。(自分の処理系を推したいが、名前を横に並べるのもおこがましい気になる・・・)
う~ん、いまいちだな。多分、こんなことしなくてもプログラムが好きな人は自分の好きな言語を見つけるし、いろんな言語を書けるんだよね。毛嫌いする人はどちらかと言えば「ぷろじぇくとまね~じゃ~」とかあんまり自分ではコードを書かない人たちなイメージ。実際、職場の開発者で数人は関数型言語やってる。(ClojureだったりHaskellだったりするけど)
とりあえずリスト作って、後はfor-eachでもmapでもfoldでも使えばいいじゃん、見たいな感覚になると早いと思うんだけど、そこまでが遠いなぁ・・・

2012-08-15

list-sortを書き換え

ふとTwitterで以下のページを言及しているツイートを見つけた。
ソート済みのリストに対する破壊的マージソートの改良
これはlist-sortのパフォーマンス改善に使えると思い、早速実装。この記事書く前に全部置き換えてコミットしてしまったのと元々Sagittariusのlist-sortはYpsilonのものを使っていたので、以下のコード(速度計測)はYpsilonで確認。
(import (rnrs)
        (time)
        (srfi :8)
        (srfi :27)
        (srfi :42))

(define sorted-list (list-ec (: x 100000) x))
(define reverse-sorted-list (reverse sorted-list))
(define nearly-sorted-list1 (list-ec (: x  100000)
                                     (if (zero? (random-integer 1000))
                                         (random-integer 100000)
                                         x)))
(define random-list (list-ec (: x 100000)
                             (random-integer 100000)))

(time (list-sort < sorted-list))
(time (list-sort < reverse-sorted-list))
(time (list-sort < nearly-sorted-list1))
(time (list-sort < random-list))

(define (list-sort2 proc lst)
  (define (merge-list! proc head lst1 lst2 tail)
    (let loop ()
      (cond ((proc (car lst2) (car lst1))
             (set-cdr! tail lst2)
             (set! tail lst2)
             (let ((rest (cdr lst2)))
               (cond ((null? rest)
                      (set-cdr! lst2 lst1)
                      (cdr head))
                     (else
                      (set! lst2 rest)
                      (loop)))))
            (else
             (set-cdr! tail lst1)
             (set! tail lst1)
             (let ((rest (cdr lst1)))
               (cond ((null? rest)
                      (set-cdr! lst1 lst2)
                      (cdr head))
                     (else
                      (set! lst1 rest)
                      (loop))))))))
  (define (fast-merge-list! proc try? head lst1 tail1 lst2 tail2 rest)
    (if try?
        (cond ((not (proc (car lst2) (car tail1)))
               (set-cdr! tail1 lst2)
               (values lst1 tail2 rest))
              ((proc (car tail2) (car lst1))
               (set-cdr! tail2 lst1)
               (values lst2 tail1 rest))
              (else 
               (values (merge-list! proc head lst1 lst2 head)
                       (if (null? (cdr tail1))
                           tail1
                           tail2)
                       rest)))
        (values (merge-list! proc head lst1 lst2 head)
                (if (null? (cdr tail1))
                    tail1
                    tail2)
                rest)))
  (define (do-sort lst size head)
    (define (recur lst size)
      (cond ((= size 1)
             (let ((h (list (car lst))))
               (values h h (cdr lst))))
            ((= size 2)
             (let* ((a (car lst))
                    (ad (cadr lst))
                    (h (if (proc ad a)
                           (list ad a)
                           (list a ad))))
               (values h (cdr h) (cddr lst))))
            (else
             (let ((half (div size 2)))
               (receive (lst1 tail1 rest) (recur lst half)
                 (receive (lst2 tail2 rest) (recur rest (- size half))
                   (fast-merge-list! proc (>= size 8) head
                                           lst1 tail1
                                           lst2 tail2
                                           rest)))))))
      (receive (lst tail size) (recur lst size)
        lst))
    (define (divide lst)
      (let loop ((acc 1) (lst lst))
        (cond ((null? (cdr lst)) (values acc '()))
              (else
               (if (proc (car lst) (cadr lst))
                   (loop (+ acc 1) (cdr lst))
                   (values acc (cdr lst)))))))
    (receive (n lst2) (divide lst)
      (if (null? lst2)
          lst
          (let* ((head (cons '() '()))
                 (r (do-sort lst2 (length lst2) head)))
            (merge-list! proc head (list-head lst n) r head))))))

(newline)
(display 'list-sort2) (newline)
(time (list-sort2 < sorted-list))
(time (list-sort2 < reverse-sorted-list))
(time (list-sort2 < nearly-sorted-list1))
(time (list-sort2 < random-list))

オリジナル(SBCL)のコードはdevide相当のものはないのだけれど、これがあるのと無いのではソート済みのリストが渡された際のパフォーマンスが全然違う(10倍程度)ので入っている。
以下が結果。
% Ypsilon test2.scm

;;  0.006001 real    0.0 user    0.0 sys

;;  0.16501 real    0.327602 user    0.0 sys

;;  0.194012 real    0.374402 user    0.0 sys

;;  0.302017 real    0.624004 user    0.0 sys

list-sort2

;;  0.007 real    0.0 user    0.0 sys

;;  0.116007 real    0.202801 user    0.0 sys

;;  0.16201 real    0.249602 user    0.0 sys

;;  0.254015 real    0.343202 user    0.0 sys
ソート済以外は高速になっているのが分かる。(ソート済みは一緒のはず)。
Sagittariusで検証した際はreversed-sorted-listで倍速、nearly-sorted-list1ではほぼ倍速。random-listは2割程度とYpsilonと同程度の速度改善であった。

どうでもいいのだが、 moshで上記のコードを走らせる(list-headをtakeにする等の変更が必要だが)と劇的に遅くなる。どの処理系でも速度改善になるというわけではないらしい。

どうでもいい追記その2。
moshのlist-sortはスタックを激しく使用するらしく、reversed-sorted-listで45回のスタック拡張が発生した。(ちょっと手を入れて、スタックの拡張が起きるとwarningメッセージ出すようにしてある。)

どうでもいい追記その3.
Ypsilonでもリストの要素数を200万個以上にするとメモリが足らなくなった。オリジナルは末尾再帰じゃないのでしょうがないのか。改善されたのは速度だけではないのもいい感じである。

2012-08-13

Bug of EMSA-PSS

I have just fixed the bug in EMSA-PSS verify. It has been there since version 0.2.x.

The problem was test case for EMSA-PSS verify failed *sometimes*, like once in 100 times or once in a month. It was really annoying and made this procedure unreliable.

Because of this random frequency, I suspected it was random number generator. In the test case, it uses secure random number generator so that it generate different number each time. (well, thank god I used secure random, otherwise I would never notice this bug.)

So first step to fix this bug was create a proper (improper?) state of PRNG. To create it, I made this code;
(import (crypto) (math) (getopt))

(define key-pair (generate-key-pair RSA :size 512 :prng (pseudo-random RC4)))
(define valid-rsa-message (string->utf8 "test message"))

(define prng (pseudo-random RC4))
(with-args (command-line)
    ((c (#\c "count") #t "1"))
  (let ((count (string->number c)))
    (do ((i 0 (+ i 1))
  (r (read-random-bytes prng 100) (read-random-bytes prng 100)))
 ((= i count) r))))

(let* ((rsa-sign-cipher (cipher RSA (keypair-private key-pair)))
       (rsa-verify-cipher (cipher RSA (keypair-public key-pair)))
       (em (sign rsa-sign-cipher valid-rsa-message :prng prng)))
  (verify rsa-verify-cipher valid-rsa-message em))
And this shell script;
#!/bin/sh

for i in `seq 1 $1`
do
    count=`expr $i + 100`
    echo $count
    `sash -Lext/crypto crypto.scm -c $count`
done
Then ran the script and check which number was the key number! After the inspection, the number was 181.

Now, it's time for debug. once I could find the PRNG state, it was really simple to fix. The problem was the signed message's first 2 bytes. RSA operation deletes left most 0's so verify procedure needs to add removed 0's in front of the message. However previous implementation did not add more than 2 zeros. That was the problem.
So I modified to add propert 0's in front of the message, and now it works!

I hope Sagittarius is now a bit more reliable. Even though I have no idea if it was the only problem that causes test case failed.

2012-08-11

Haskell風の$マクロ その2

さすがに前回のはあんまりだよなぁと思い、もう少しだけR6RSっぽくしてみた。
(import (rnrs))
(define-syntax $
  (lambda (x)
    (define (build es)
      (let loop ((es es) (r '()))
        (syntax-case es ($)
          (() (reverse r))
          (($ es ...)
           (append (reverse r) (list (loop #'(es ...) '()))))
          ((e . es)
           (loop #'es (cons #'e r))))))
    (syntax-case x ()
      ((k es ...)
       (build #'(es ...))))))
 
(define (print . args)
  ($ for-each display args) (newline))
 
($ newline)
 
($ for-each print
   $ list 1 2 3)

($ for-each print
   $ map cons '(1 2 3) $ list 4 5 6)
単に自前で分解するのをやめてsyntax-caseに頼っただけとも言う。前回同様、mosh、Ypsilon、Sagittariusで確認。 reverseをreverse!にappendをappend!するときっとメモリ節約。処理系が対応していればだけど。

2012-08-10

Haskell風の$マクロをR6RSで

ChatonのGauche部屋を見ていて、Shiroさんが$を多用しているなぁと思い、流行は$なのだろうかと勘違いして書いてみた。R5RSで動くやつはGaucheにあるので、R6RSのsyntax-caseを使って。
(import (rnrs))
(define-syntax $
  (lambda (x)
    (define (build k es)
      (define $ (datum->syntax k '$))
      (define (build-es es)
 (let loop ((es es) (r '()))
   (cond ((null? es) (reverse r))
  ((and (identifier? (car es))
        (free-identifier=? $ (car es)))
   (append (reverse r) (list (loop (cdr es) '()))))
  (else
   (loop (cdr es) (cons (car es) r))))))
      #`(#,@(build-es es)))
    (syntax-case x ()
      ((k es ...)
       (build #'k #'(es ...))))))

(define (print . args)
  ($ for-each display args) (newline))

($ newline)

($ for-each print
   $ list 1 2 3)
なんというか、syntax-caseを使っているのは単にS式を直接扱いたかっただけという・・・僕の頭ではマクロ展開中に値を貯めてとか、分解してとかが無理だった・・・
動作はmosh、Ypsilon、Sagittariusで確認。恐らく、syntax-caseの動作としては信頼が出来る順に確認してるはず(moshはpsyntax使っているので多分マクロ周りの信頼が高い、はず・・・)

マクロ展開中に式を分解したりするのってどうやって考えれば身につくのだろうか?低レベルのマクロが書けると面倒になってS式そのままいじってしまう・・・

2012-08-07

sxpathメモ その2

XSDをサポートするモジュールを書いていて、名前空間付きのsxmlをsxpathでいじる必要があった。すっかりどうやっているのかを忘れてググッたら自分のページが出てきた。っが、いまいち何がどうなっているのか詳しくなかったので、もう一回書くことにする。
ちなみに、これがその1

以下のコードを実行する。(sample.xsdはXSDで記述されたXMLファイルである)
(import (rnrs)
 (text sxml ssax)
 (text sxml sxpath)
 (sagittarius control)
 (pp))

(define-constant namespace '((xsd . "http://www.w3.org/2001/XMLSchema")))
(call-with-input-file "sample.xsd"
  (^p 
   (and-let* ((sxml (ssax:xml->sxml p namespace))
       (path (sxpath "//xsd:schema" namespace))
       (doc  (path sxml)))
     (pp sxml)
     (pp doc))))
#|
Output:
(*TOP* (@ (*NAMESPACES*
            (xsd "http://www.w3.org/2001/XMLSchema")))
       (*PI* xml
             "version=\"1.0\" encoding=\"ISO-8859-1\" ")
       (xsd:schema
         (xsd:element
           (@ (name "shiporder"))
           (xsd:complexType
             (xsd:sequence
               (xsd:element
                 (@ (type "xs:string") (name "orderperson")))
               (xsd:element
                 (@ (name "shipto"))
                 (xsd:complexType
                   (xsd:sequence
                     (xsd:element
                       (@ (type "xs:string") (name "name")))
                     (xsd:element
                       (@ (type "xs:string") (name "address")))
                     (xsd:element
                       (@ (type "xs:string") (name "city")))
                     (xsd:element
                       (@ (type "xs:string") (name "country"))))))
               (xsd:element
                 (@ (name "item") (maxOccurs "unbounded"))
                 (xsd:complexType
                   (xsd:sequence
                     (xsd:element
                       (@ (type "xs:string") (name "title")))
                     (xsd:element
                       (@ (type "xs:string")
                          (name "note")
                          (minOccurs "0")))
                     (xsd:element
                       (@ (type "xs:positiveInteger") (name "quantity")))
                     (xsd:element
                       (@ (type "xs:decimal") (name "price")))))))
             (xsd:attribute
               (@ (use "required")
                  (type "xs:string")
                  (name "orderid")))))))
()
|#
sxpathに名前空間を渡しているのに、何も返してこない。これに昨日30分くらいはまった。これは指定している名前空間がまずくて、正しくは以下のものを渡さないといけない。
'((xsd . "xsd"))
sxpathに渡される名前空間は、ssaxのそれとは違い、「XPath内にある名前空間の解決」に使われる。つまり、上記のコードで言えば、"//xsd:schema"の部分の"xsd:"である。この部分が、「渡された名前空間のcar部」で、「cdr部は操作するSXMLのエレメントの名前空間」になる。
なので、渡されたSXMLがフルネーム(ここではURIを指す)で修飾されていれば、上記のコードのような名前空間を渡しても問題ない。
この仕様のいいところは、名前空間さえ正しく指定してやればXPathを変更せずに異なる名前空間プリフィックスが処理できること。たとえば、上記のSXMLのプリフィックスがxsとかでも、'((xsd . "xs"))を渡してやれば、XPathの修正は要らない。
嫌なところは、ssaxに名前空間を渡してでパースされたSXMLと非常に相性が悪いこと。
これは、挙動からの推測だが、この名前空間の解決はXPathでのみ発生していて、SXPathでは起きないみたい。なので、"//xsd:schema"の部分を'(// xsd:schema)とすると名前空間なしでも値が返ってくる。この奇妙なチグハグ感もなかなか「トリッキーなライブラリを使ってるぜ!」的な陶酔感をかもし出していていい感じではある。(正直勘弁してほしいが・・・)

その1のページで言及されているメールのリプライに答えというかsxpathにおける名前空間の扱いが書いてあるので、単に蛇足ではあるが。

2012-08-06

R7RSの6th Ballot

ザーッと目を通した。

とりあえず、この辺は変更されないだろうと当たりをつけたもの、もしくは変更されてもあればあった出便利なものを実装。
実装したものは以下:
  • ライブラリ名に数字を使用可能にする
    • ドラフトの6には符号なし正確な整数とあったので、一応Bignumも入れてある
  • (exit #t)でEXIT_SUCCESSを返す。
    • (exit 0)と書くよりは確かに分かりやすい
  • vector-appendを追加
  • bytevector-appendを追加
  • レコード型のequal?
    • 再帰的に中身を見るように変更
    • それに伴ってeqv?もちょっと変更
  • utf8->stringとstring->utf8のオプショナル引数
    • ついでに、string->bytevectorとbytevector->stringにも追加
  • UNICODEを6.1.0にアップデート
  • string->vectorとvector->stringのオプショナル引数
とりあえず、残りというか、include-library-declarationsとかは後回し。正直残り数日の間で消えてほしいなと思ったり・・・