kou

GaUnit(GaucheのためのUnit Testing Framework)(また、久しぶりに)はじめました.

旧(一応、まだ使える):

(use test.unit)

(define-test-case "Test case name"
  ("Test name"
    (assert-equal ...)
    ...)
  ("More test"
    ...))

...

新:

(define-module test-your-module
  (use test.unit.test-case) ;; 0.1.5まではuseじゃなくてextendじゃないとダメ
  (use your-module))
(select-module your-module)

(define (test-your-function1) ;; test-はじまりの関数がひとつのテスト
  (assert-equal 29 (your-function1 2 9))
  ...
  #f) ;; スタックトレースを最適化で落とさないようにするため

(define (test-your-function2)
  ...
  #f)

(provide "test-your-module")

benchmarkはじめました.

tsm(Gaucheのためのタプルスペースライブラリ)はじめました.

xsm(GaucheのためのXML関連ライブラリ(現在はXML-RPCライブラリしかないけど))はじめました.

だいぶ使いやすくなって(慣れて)きた気がします.

なにか

socket-status

0.8.6から,返されるシンボルの値が大文字から小文字に変更されていてはまった.

CGI経由でファイルアップロードされたファイル名

IEからアップロードすると,filename中のパス区切り「\」が全部消えてしまう...うーん.

pair-attribute-get

0.8.4からは無くなっていたのか.

GaUnitでスタックトレースが表示できなくなっちゃった. うーん,どうしよう.

file->string

バイナリファイルも扱えるfile->stringがあると便利なのになぁ.

(use file.util)

(define tmp-path "/tmp/a")

(with-output-to-file tmp-path
  (lambda ()
    (display #*"\x89PNG\r\n\x1a\n\0\0\0\rIHDR\0\0\0\xf0")))

(file->string tmp-path)
*** IO-READ-ERROR: encountered EOF in middle of a multibyte character from port #<iport /tmp/a 0x80852e0>
Stack Trace:
_______________________________________
  0  (let loop ((ch (read-char port))) (unless (eof-object? ch) (write- ...
        At line 50 of "/usr/share/gauche/0.8.3/lib/gauche/portutil.scm"
  1  (proc port)
        At line 60 of "/usr/share/gauche/0.8.3/lib/gauche/with.scm"

read-required-block

こんなのもあると嬉しいな.

(define (read-required-block input size timeout eof-handler timeout-handler)
  (define return #f)

  (define (make-reader size)
    (lambda (in)
      (read-block size in)))

  (define (more-read size)
    (read-with-timeout input (make-reader size) timeout
                       (lambda ()
                         (return (timeout-handler)))))
  
  (define (read-more-if-need block)
    (cond ((eof-object? block) (eof-handler))
          ((< (string-size block) size)
           (read-more-if-need
            (string-append block
                           (more-read (- size (string-size block))))))
          (else block)))
    
  (call/cc
   (lambda (cont)
     (set! return cont)
     (read-more-if-need (more-read size)))))

read-with-timeout

こんなのがあると嬉しいな.

(define (read-with-timeout input reader timeout timeout-handler)
  (if (char-ready? input)
    (reader input)
    (let ((result #f)
          (selector (make <selector>)))
      (selector-add! selector
                     input
                     (lambda (in . args)
                       (selector-delete! selector input #f #f)
                       (set! result (reader in)))
                     '(r))
      (if (zero? (selector-select selector timeout))
        (timeout-handler)
        result))))

Gaucheとネットワーク

TCPより上の層のライブラリが少ないような...

GaucheとDebian

独り言...

GaucheのDebianパッケージがもっと充実すると嬉しいなぁ.

Debianパッケージのgoshのバージョンがあがると嬉しいなぁ.

S式とプレゼンテーション

あとで,何か書こう.

関連: 大学生日誌(2004-07-23)とか

parse-uri

ついでにこんなのも組込みであると便利な気がします.

URIを分割して多値で返します.指定されていないものは#fになります(schemeがsymbolで返るのは私の好みです).

(define (parse-uri uri)
  (define (filter-non-empty-string str)
    (and (string? str)
         (not (string-null? str))
         str))

  (define (convert-if-not-false obj converter)
    (and obj (converter obj)))
  
  (receive (scheme specific)
      (uri-scheme&specific uri)
    (receive (authority path query fragment)
        (uri-decompose-hierarchical specific)
      (receive (user-info host port)
          (uri-decompose-authority authority)
        (values (convert-if-not-false scheme string->symbol)
                user-info
                (filter-non-empty-string host)
                (convert-if-not-false port string->number)
                (filter-non-empty-string path)
                query
                fragment)))))

mutex-syncronize

組込みでこんなのがあると便利な気がします.

(define (mutex-synchronize mutex thunk)
  (dynamic-wind
    (lambda () (mutex-lock! mutex))
    thunk
    (lambda () (mutex-unlock! mutex))))

letrec

(letrec ((x 3)
         (y (+ x 1)))
  y)
;; => 4

(letrec ((y (+ x 1))
         (x 3))
  y)
;;  => *** ERROR: operation + is not defined between 1 and #<undef>

どちらも同じ結果(エラー)になって欲しい気がするんですが,こんなものなのでしょうか.

マクロとdefine

0.8だと以下のコードがエラーになるんですが,こういうものですか?

(define-macro (a)
  '(define b #f))

(define (c)
  (a))

Shiro: これは、「マクロ展開後に出現するinternal defineが認識されない」 というバグです。このバグは前からあったのですが、 別のバグによりいままではエラーになっていませんでした。 (トップレベルの環境が置き換わってしまっていました)。

Shiro: そもそも0.8以前でも正しく動いてないので、たとえ直ったとしても 現在の動作と同じにはなりません。 もし現在と同じ動作(トップレベル環境を変更する)をさせたいのなら、 evalを使えば可能です。

 (define-macro (a)
   '(eval '(define b #f) (current-module)))

Shiro(2004/07/13 14:27:33 PDT): マクロ展開後に現れるinternal defineが 正しくinternal defineとして認識されるようになりました (compile.c,v 1.114)。 但し、最初のコードはやはりエラーになります。(c)の展開後のフォームには internal defineしか含まれませんが、空のbodyはR5RSでは許されてないからです。

parameter.c (Scm_ParameterRef)

SCM_ASSERT(0 <= index && index < p->numParameters);

じゃなくて

if (!(0 <= index && index < p->numParameters))
        Scm_Error("bad index: %d", index);

じゃだめですか?

以下のようなthreadとparameterとloadを使うようなときに復帰できないんですけど...

para.scm

(define para (make-parameter 1))
(use gauche.threads)
(use gauche.parameter)

(thread-join!
 (thread-start!
  (make-thread
   (lambda ()
     (load "para")
     (print (para))))))
;; => 1

(thread-join!
 (thread-start!
  (make-thread
   (lambda ()
     (print (para))))))
;; => "parameter.c", line 113 (Scm_ParameterRef): Assertion failed: 0 <= index && index < p->numParameters

スタックトレースの伝搬

以下のa, b, c, dが全部同じスタックトレースを出力して欲しいです.ちなみにdだけ異なります.

(define (a)
  (error "error in a") #f)

(define (b)
  (a))

(define (c)
  (with-error-handler report-error a))


(define (d)
  (report-error (with-error-handler identity a))
  #f)

errorオブジェクトにスタックトレース情報はついていなくてスタックトレースはvmに問い合わせているのでこうなるのだと思いますが,errorオブジェクトにスタックトレースを持たせる予定はありますか?

例外クラスの階層化

優先順位は高いですか?低いですか?

マクロとスタックトレースとquote

`だとスタックトレースの情報が失われるけどそういうもの?

(define-macro (a)
  '(begin (error "hoge") #f))

(define (b)
  (a) #f)

(b)

だと2行目でエラーが起きたのがわかる.

(define-macro (a)
  `(begin (error "hoge") #f))

(define (b)
  (a) #f)

(b)

だと[unknown location]

マクロとスタックトレース

マクロ展開後のコードの中で発生したエラーのスタックトレースにマクロを呼び出している場所の情報も含んでいると嬉しいです.

(define-macro (a)
  '(begin (error "hoge") #f))

(define (b)
  (a) #f)

(b)

(define (a)
  (error "hoge") #f)

(define (b)
  (a) #f)

(b)

と同じようなスタックトレースを持つ感じ.もしかして,マクロにそんなことを期待しちゃいけないのかしら.

generic function & import

(define-module a
  (export x)
  (define-method x ((y <list>)) #f))

(define-module b
  (export x)
  (define-method x ((y <string>)) #f))

(import b)
x ; => #<generic x (1)> for (<string>)

となるのはわかりますが,

(define-module a
  (export x)
  (define-method x ((y <list>)) #f))

(define-module b
  (import a)
  (export x)
  (define-method x ((y <string>)) #f))

(import b)
x ; => *** ERROR: unbound variable: x
(import a)
x ; => #<generic x (2)>

というのは使いづらくないですか?

まぁ,

(define-module c
  (extend a b))

(import c)
x ; => #<generic x (2)>

とでもすればいいんでしょうけど.

あぁ,Gauche:GenericFunctionとModuleに書いていましたね.gauche.gfでいい気がしますが,exportしなくても見えてしまうのは嫌ですね.

gauche.gfではgeneric functionの実体だけをもっていて,名前はつけない.各モジュールではdefine-methodしたりimportしたら名前を付けると...いいのかな?あと(春かなぁ...)でやってみようかなぁ.

evalの代わりにマクロ

ファイルを読み込んでその内容を評価したい.

evalを使う:

(define (eval-file filename)
  (eval (read (open-input-file filename))
        (current-module)))

マクロを使う:

(define-macro (eval-file* filename)
  (read (open-input-file filename)))

違いはこんな感じ.

(eval-file "test.scm")   ; => OK
(eval-file* "test.scm")  ; => OK
(eval-file (string-append "test" ".scm"))  ; => OK
(eval-file* (string-append "test" ".scm")) ; => NG

ここで,

(eval-file* (string-append "test" ".scm"))

を出来るようにしたい場合はどうするんですかねぇ.

  1. 引数をstring-appendしてeval-file*をよびだすマクロを書く
    (define-macro (eval-file** . strings)
      `(eval-file* ,(apply string-append strings)))
    
    を作って
    (eval-file** "test.scm")     ; => OK
    (eval-file** "test" ".scm")  ; => OK
    
    というように使ってもらう.
    • 結局引数には文字列リテラルしか書けないままなので,解決になっていない.
  2. だまってevalする.
    (define-macro (eval-file* filename)
      (read (open-input-file (eval filename (current-module)))))
    
    • first class environmentがないのでletの中とかだとうまくない.
  3. 問題を考え直す.
  4. あきらめる

current-environment

(define x 10)
(let ((x 1))
  (eval 'x (current-environment)))
;; => 1

とするようなcurrent-environmentみたいなのはないのかなぁ.

まぁ、上記の例では

(eval '(let ((x 1)) x) (current-module))

とでもすればいいので、なければなくて大丈夫ですね。

first class environmentがなければ出来ないというわけではないのですが、使用例ということで一つあげておきます。

例えば、

(define (dispatch sym . args)
  (define (foo) ...)
  (define (bar baz) ...)
  ...

  (case sym
   ((foo) (apply foo args))
   ((bar) (apply bar args))
   ...))

というのを

(define (dispatch sym . args)
  (define (foo) ...)
  (define (bar baz) ...)

  (apply (eval sym (current-environment)) args))

と書きたいことがあります。

ま、これもシンボルから手続きが引ければそれでいいわけなので、他に手がありそうなんですけど(わからないんですよねぇ、私には)。

Scm_RegisterFinalizer

Schemeレベルでは使えない?

report-errorの出力形式

ファイル名:行: 何か

という形式になっているとEmacsでエラー箇所にジャンプしやすいのでうれしいです.

Schemeレベルでreport-errorを再定義してもいいんですけど,なんか,スタックトレース出力以外のこともやっていそうなので,Cレベルで.

RCS file: /cvsroot/gauche/Gauche/src/error.c,v
retrieving revision 1.41
diff -u -r1.41 error.c
--- src/error.c 5 Jul 2003 03:29:12 -0000       1.41
+++ src/error.c 20 Nov 2003 03:53:08 -0000
@@ -282,19 +282,19 @@
     SCM_PUTZ("Stack Trace:\n", -1, err);
     SCM_PUTZ("_______________________________________\n", -1, err);
     SCM_FOR_EACH(cp, stack) {
-        Scm_Printf(SCM_PORT(err), "%3d  %66.1S\n", depth++, SCM_CAR(cp));
         if (SCM_PAIRP(SCM_CAR(cp))) {
             ScmObj srci = Scm_PairAttrGet(SCM_PAIR(SCM_CAR(cp)),
                                           SCM_SYM_SOURCE_INFO, SCM_FALSE);
             if (SCM_PAIRP(srci) && SCM_PAIRP(SCM_CDR(srci))) {
-                Scm_Printf(SCM_PORT(err), "        At line %S of %S\n",
-                           SCM_CADR(srci), SCM_CAR(srci));
+                Scm_Printf(SCM_PORT(err), "%A:%S:\n",
+                           SCM_CAR(srci), SCM_CADR(srci));
             } else {
-                Scm_Printf(SCM_PORT(err), "        [unknown location]\n");
+                Scm_Printf(SCM_PORT(err), "[unknown location]:\n");
             }
         } else {
             Scm_Printf(SCM_PORT(err), "\n");
         }
+        Scm_Printf(SCM_PORT(err), " %3d %66.1S\n", depth++, SCM_CAR(cp));
         if (depth >= STACK_DEPTH_LIMIT) {
             Scm_Printf(SCM_PORT(err), "... (more stack dump truncated)\n");
             break;

object-hashのデフォルト動作

以下の様になっているとhash-tableを使うのが楽になると思うんですけどねぇ.

(define-method object-hash (obj)
  (address-of obj))

オブジェクトをアドレスで指定

gosh> (lambda () #f)
#<closure 0x80fbc18()>

0x80fbc18

はオブジェクトのアドレスですよね?

このアドレスを用いてオブジェクトを指定することは出来ませんか?

gosh> (id-ref #x80fbc18)
#<closure 0x80fbc18()>

みたいに.

オブジェクトの転送に使おうと思っていました.

シリアライズできない(writeしたものをreadできない)オブジェクトを転送するのは面倒なので,オブジェクトの参照だけを転送しようと思いました.で,これだけならオブジェクトを一意に特定することが出来るキーがあればいいだけなので,ハッシュでもよさそうですが,

(define-method object-hash (obj)
  ...)

というのが実装されていないので全てのオブジェクトに実装しなければいけません.で,これも面倒だと.

ということで,

(define-method object-hash (obj)
  (address-of obj))

というのはどうですか?

これがあれば,weak-vectorとobject-hashで,同じ様なことが出来そうなのでid-refみたいなのはいりません.

ところで,weak-vectorも(gcされると言う意味では)安全ではないですよね?id-refみたいなものを使ったときの安全ではないという意味には別のことも含まれているのですか?良く分からないですけど,継続がらみとか,スレッドがらみとか...

別にgcされてもいいや,と思っていたので,gcされちゃったよという例外を投げてくれれば,問題ないです,私は.

sendto(2), recvfrom(2)

欲しいなぁ.

WiLiKiの出力するRSSにdescriptionを加える

Index: src/wiliki.scm
===================================================================
RCS file: /cvsroot/wiliki/WiLiKi/src/wiliki.scm,v
retrieving revision 1.94
diff -u -r1.94 wiliki.scm
--- src/wiliki.scm      1 Sep 2003 04:57:49 -0000       1.94
+++ src/wiliki.scm      28 Oct 2003 02:01:39 -0000
@@ -59,7 +59,8 @@
 (autoload wiliki.pasttime how-long-since)
 (autoload wiliki.format  format-page format-footer format-content
                          format-time format-colored-box format-wikiname-anchor
-                         format-wiki-name format-diff-pre format-diff-line)
+                         format-wiki-name format-diff-pre format-diff-line
+                         format-description)
 (autoload wiliki.log     wiliki-log-create wiliki-log-pick
                          wiliki-log-pick-from-file
                          wiliki-log-parse-entry wiliki-log-entries-after
@@ -84,6 +85,7 @@
 (define *recent-changes* " %recent-changes")
 (define *lwp-version* "1.0")            ;''lightweight protocol'' version
 (define $$ gettext)
+(define *description-length* 120)
 
 ;; Parameters
 (define page-format-history (make-parameter '()))
@@ -337,10 +339,14 @@
    (string-append (title-of (wiliki))": "($$ "Recent Changes"))
    (html:table
     (map (lambda (p)
-           (html:tr
-            (html:td (format-time (cdr p)))
-            (html:td "(" (how-long-since (cdr p)) " ago)")
-            (html:td (format-wikiname-anchor (car p)))))
+           ;; for backward compatibility
+           (let ((modified-time (if (pair? (cdr p))
+                                    (cadr p)
+                                    (cdr p))))
+             (html:tr
+              (html:td (format-time modified-time))
+              (html:td "(" (how-long-since modified-time) " ago)")
+              (html:td (format-wikiname-anchor (car p))))))
          (wdb-recent-changes (db))))
    :page-id "c=r"
    :show-edit? #f
Index: src/wiliki/db.scm
===================================================================
RCS file: /cvsroot/wiliki/WiLiKi/src/wiliki/db.scm,v
retrieving revision 1.6
diff -u -r1.6 db.scm
--- src/wiliki/db.scm   1 Sep 2003 04:57:49 -0000       1.6
+++ src/wiliki/db.scm   28 Oct 2003 02:01:39 -0000
@@ -124,8 +124,11 @@
                              (dbm-get db *recent-changes* "()")))
         (dbm-put! db *recent-changes*
                   (write-to-string
-                   (acons key (mtime-of page) (take* r 49))))))
+                   (acons key
+                          (list (mtime-of page)
+                                (format-description page))
+                          (take* r 49))))))
     ))
 
 ;; WDB-DELETE! db key
Index: src/wiliki/format.scm
===================================================================
RCS file: /cvsroot/wiliki/WiLiKi/src/wiliki/format.scm,v
retrieving revision 1.15
diff -u -r1.15 format.scm
--- src/wiliki/format.scm       8 Oct 2003 07:28:26 -0000       1.15
+++ src/wiliki/format.scm       28 Oct 2003 02:01:39 -0000
@@ -48,8 +48,9 @@
           format-wikiname-anchor
           format-wiki-name
           format-diff-pre
-          format-diff-line)
+          format-diff-line
+          format-description)
   )
 (select-module wiliki.format)
 
@@ -553,5 +556,19 @@
        (html:hr)
        content)))
   )
+
+(define (format-description content)
+  (let* ((extracted-string (regexp-replace-all
+                            #/([^<]*)(<[^>]*>)?/
+                            (tree->string (format-content content))
+                            "\\1")))
+    (string-shorten extracted-string *description-length*)))
+
+(define (string-shorten string length)
+  (if (< (string-length string) length)
+      string
+      (tree->string (list (substring string 0 length)
+                          "..."))))
 
 (provide "wiliki/format")
Index: src/wiliki/rss.scm
===================================================================
RCS file: /cvsroot/wiliki/WiLiKi/src/wiliki/rss.scm,v
retrieving revision 1.5
diff -u -r1.5 rss.scm
--- src/wiliki/rss.scm  30 Aug 2003 12:28:00 -0000      1.5
+++ src/wiliki/rss.scm  28 Oct 2003 02:01:40 -0000
@@ -61,10 +61,18 @@
               entries)))
       ,(map (lambda (entry)
               (let1 url (url-full "~a" (cv-out (car entry)))
-                (rdf-item url
-                          (rdf-title (car entry))
-                          (rdf-link url)
-                          (dc-date  (cdr entry)))))
+                    (let* ((new-style (pair? (cdr entry)))
+                           (date (if new-style
+                                     (cadr entry)
+                                     (cdr entry)))
+                           (description (if new-style
+                                            (caddr entry)
+                                            "")))
+                      (rdf-item url
+                                (rdf-title (car entry))
+                                (rdf-link url)
+                                (rdf-description description)
+                                (dc-date date)))))
             entries)
       "</rdf:RDF>\n")))

if

  (if "a" (begin)) ; => "a"

は仕様ですか?

add-load-path

(add-load-path (sys-normalize-pathname "~/local/share/gauche/site/lib"
                                       :expand #t))

ということは出来ないのかなぁ.

string-case

eqv?の代わりにstring=?で比較するcaseがマクロで書けない.

(define (include? key sequence predicate)
  (and (not (null? sequence))
       (if (predicate key (car sequence))
           #t
           (include? key (cdr sequence) predicate))))

(define-syntax string-case
  (syntax-rules (else)
    ((_ key) #f)
    ((_ key (else expr ...)) (begin expr ...))
    ((_ key ((str ...) expr ...))
     (if (include? key '(str ...) string=?)
         (begin expr ...)))
    ((_ key ((str ...) expr ...) clause ...)
     (if (include? key '(str ...) string=?)
         (begin expr ...)
         (string-case key clause ...)))
    ((_ other . more)
     (syntax-error "bad clause in string-case" other))))

とりあえず,

    ((_ key ((str ...) expr ...))
     (if (include? key '(str ...) string=?)
         (begin expr ...)))

はいらないことに気付いたので新版.ついでにexpr ...が無いときはエラーにするようにした.

foo ...というのはfooの0回以上の繰り返しなのか.1回以上だと思っていた.

(define (include? key sequence predicate)
  (and (not (null? sequence))
       (if (predicate key (car sequence))
           #t
           (include? key (cdr sequence) predicate))))

(define-syntax string-case
  (syntax-rules (else)
    ((_ key) #f)
    ((_ key (else expr ...)) (begin expr ...))
    ((_ key ((str ...)) clause ...)
     (syntax-error "expressions are not found in string-case" ((str ...))))
    ((_ key ((str ...) expr ...) clause ...)
     (let ((evaled-key key))
       (if (include? evaled-key '(str ...) string=?)
           (begin expr ...)
           (string-case evaled-key clause ...))))
    ((_ other . more)
     (syntax-error "bad clause in string-case" other))))

なにかだったもの

classに対してmap

classに対してmapとかfoldとか使いたいなら<collection>のサブクラスを作れ

www/cgi.scm

queryの区切り文字として&だけではなくて;も認識される.

Note:

スタックトレース

ということでこんなのを使うようにした.

  (define (print-error e mark)
    (print mark)
    (print (slot-ref e 'message))
    (with-module gauche.vm.debugger
                 (debug-print-stack
                  (cddr (vm-get-stack-trace))
                  *stack-show-depth*))
    (print mark))

Note:

NULL文字にマッチする正規表現を書く

  (string->regexp "\0")

or

  (string->regexp "\x00")

or

  (#/\x00/ "\0")

and so on.

Note:

リストの要素を連結して文字列を返す

Note:

datatype.ss

http://www.cs.indiana.edu/~jsobel/Recycling/datatype.ss をGaucheで実行するにはloadする前に以下を評価しておく.でも,完全にうまくいくわけではない.Cf. SchemeCrossReference:andmap, SchemeCrossReference:error

  (use slib)
  (use srfi-1)
  (define andmap every)
  
  (define char-ready? 
    (let ((bad-char-ready? (with-module gauche char-ready?))) 
      (lambda args 
        (if (null? args) 
            (bad-char-ready? (current-input-port)) 
            (bad-char-ready? (car args))))))
  
  (define (slib:eval-load <pathname> evl)
    (if (not (file-exists? <pathname>))
        (set! <pathname> (string-append <pathname> (scheme-file-suffix))))
    (call-with-input-file <pathname>
      (lambda (port)
        (let ((old-load-pathname *load-pathname*))
          (set! *load-pathname* <pathname>)
          (do ((o (read port) (read port)))
              ((eof-object? o))
            (evl o))
          (set! *load-pathname* old-load-pathname)))))
  
  (require 'syntax-case)
  (require 'repl)
  (repl:top-level macro:eval)
More ...