2011/06/11

「Scheme修行」献本頂きました!

scheme修�������������� on Twitpic
Scheme修行」は先だって出版された「Scheme手習い」の続編です。
これらは「The Little Schemer」「The Seasoned Schemer」という、Lisp/Schemeの入門書として知られる2冊の翻訳本です。

Scheme修行
Scheme修行
posted with amazlet at 11.06.11
Daniel P. Friedman and Matthias Felleisen
オーム社
売り上げランキング: 66881

目次

訳者まえがき
序文
はじめに

11章 おかえりなさい、ようこそショーへ
12章 避難しましょう
13章 ホップ、スキップ、ジャンプ1
14章 名前をつけましょう
15章 大人と子供の違い……
16章 位置について、セット、バン!
17章 我変わる、ゆえに我あり!
18章 我変わる、ゆえに我同じなり!
19章 宝石泥棒
20章 店には何がある?

後序
索引
すでに「Scheme手習い」を読んだ方はご存知でしょうが、実際はこれがS式で書いてあります(笑)

内容

『Scheme修行』は、カバーの像が牙を生やしていることからわかるように、大人のSchemerを目指すための本。
『Scheme手習い』が副作用のない安全な世界での話だとしたら、『Scheme修行』は代入やジャンプのような危険な世界でちゃんと生き抜く大人の態度を学ぶ話。

Scheme修行」では、代入や継続について学びます。とくに継続(continuation)については、その強力さの一端に触れることになります。今後、継続の真の力を学ぶ上での足がかりになると思います。他にも「Scheme手習い」では出てこなかったif, let, letrecなどの基本的な要素についても学びます。もちろん「Scheme手習い」同様、さりげないやり取りにニヤニヤさせられます。


序盤は「Scheme手習い」で繰り返し繰り返し学んだ再帰の復習といったところでしょうか。ここでletrecが出てきます(letrecの登場シーンでフイタのは私だけじゃないはず)。この辺で出てくる「scramble」という手続きが印象に残っています。
中盤で代入と継続についてじっくり学びます。かなりのページ数が割かれており、ここがメインだと言って良いと思います。letやifもここらで出てきます。ここで再度Y combinator(今回はY!も)出てきます。なぜこうもY combinatorの話が出てくるかというと、こういう話もあるようです。
後半は、CPS(continuation passing style)や、Lispインタプリタの実装もあり、読み応えありです。「Scheme手習い」でも最終章でLispインタプリタを作りましたが、今回も作ります。もちろん今回学んだ継続や代入を取り入れたパワーアップしたインタプリタです。

「序文」と「後序」のGuy L. Steele Jr.の言葉も必見。

私は以前、The Little Schemer同様、原書を読んだのですが、やはり日本語で読む方がよく理解できて大変面白かったです。原書を読んだときには気づかなかったこともたくさんありました。

参考

あなたはまたLispも知る必要がある。
The Little SchemerThe Seasoned Schemerの練習問題を自力ですべて解ければ十分だと思う。

本家っぽいページ(著者の一人 Matthias Felleisen のページ?)に追加のエクササイズがpsファイル(35ページくらい)で置いてあったりします。。

最後に

なりましたが、初めて「献本」というものを頂きました。すごくうれしいです!
今回、オーム社の鹿野さん(@golden_luckyさん)から査読?レビュー?のお話を頂きました。
私は「The Little Schemer」「The Seasoned Schemer」が大好きなので、こういった機会を頂いたことがとてもうれしかったです。
このような機会を与えて頂いたことに感謝いたします。ありがとうございました。

関連

MIT の教科書 "計算機プログラムの構造と解釈" (昔は構造と実行) を読む為の本だったそうである。

Scheme修行

2011/06/05

Gaucheのmoduleとdefine-in-moduleとevalで作るsandbox

まずはモジュールがどういうものか、いくつか確認してみます。
モジュールは、シンボルを束縛へとマップするオブジェクト
モジュールは継承することもできます。 既存のモジュールを継承したモジュールに新しい束縛を足してexportすることにより、 既存のモジュールを拡張することができます。新しいモジュールの内部からは、 継承元のモジュールの束縛が(exportされていないものも含め)全て見えます。 (新しく作られるモジュールはデフォルトでgaucheモジュールを継承しています。 新しいモジュールからgaucheの組込み手続き等が使えるのはそのためです)。
モジュールは実行時データ構造です。実行時に任意の名前のモジュールを 手続き的に作成することができます。

define-moduleはモジュールに名前を付けるが、 Gaucheでは無名のモジュールを作ることもできる。

module

select-moduleによって一度nullやschemeモジュールに 入ると、そこから他のモジュールに移ることはできなくなることに注意してください。 これらのモジュールからは、あらゆるモジュール操作構文が不可視だからです。
らしい。

ということで、nullモジュール内にすでにある束縛を見てみる。
(hash-table-keys (module-table (find-module 'null)))
;; -> (unquote-splicing quasiquote letrec-syntax syntax-rules set! lambda let* begin quote or unquote define case delay if let letrec and let-syntax cond do define-syntax)
確かにモジュール系の手続きや特殊形式が一式存在しない。ということはselect-moduleをnullモジュールに入れてあげれば、またuserモジュールなどに戻れるわけですね。

define-in-module

nullモジュールにselect-module特殊形式を入れてみる。
(define-in-module null select-module select-module)

(hash-table-keys (module-table (find-module 'null)))
;; -> (unquote-splicing quasiquote letrec-syntax syntax-rules set! lambda let* begin quote or unquote define case delay if select-module let letrec and let-syntax cond do define-syntax)
入ったようです。

select-moduleでnullモジュールに入ってみます。
(select-module null)

(module-name (current-module))
;; -> *** ERROR: unbound variable: current-module

(select-module user)

(module-name (current-module))
;; -> user
nullモジュール内にcurrent-moduleは無いのでエラーになってます。でもselect-moduleはあるのでuserモジュールに戻ってくることができました。

他にも追加してみる。
(define-in-module null current-module current-module)

(define-in-module null receive receive)
(define-in-module null values values)

(select-module null)

(current-module)
;; -> #<module null>

(receive (a b)
    (values 1 2)
  (quasiquote ((unquote a)(unquote b))))
;; -> (1 2)

eval

ところで、gaucheのevalの第二引数は(今のところ)モジュールらしいです。
Function: eval expr env
[R5RS] exprを評価します。envは下に述べる手続きにより 返される値でなければなりません。現時点では、それは単なる オブジェクトですが、Gaucheが将来、ファースト クラスの環境オブジェクトを採用する可能性はあります。
(eval '(print #`"Hello, ,(module-name (current-module)) module !!")
      (current-module))
;; Hello, user module !!
;; #<undef>

(eval '(print #`"Hello, ,(module-name (current-module)) module !!")
      (find-module 'gauche))
;; Hello, gauche module !!
;; #<undef>

sandbox

サンドボックス(sandbox)とは、外部から受け取ったプログラムを保護された領域で動作させることによってシステムが不正に操作されるのを防ぐセキュリティモデルのこと。
nullモジュールを継承したモジュールを作れば、許可したい手続きだけを注入したsandboxが作れそうです。
(eval '(begin (define a 10)(define b 5)(print (+ a b)))
      (find-module 'null))
;; -> *** ERROR: unbound variable: +
+がないと怒られました。

+と、きっとprintもないのでnullモジュールに注入します。
(define-in-module null + +)
(define-in-module null print print)

(eval '(begin (define a 10)(define b 5)(print (+ a b)))
      (find-module 'null))
;; 15
;; #<undef>

sandboxを作ってみる。
(define-module sandbox)

(module-parents (find-module 'sandbox))
;; -> (#<module gauche.gf>)
まずdefine-moduleでsandboxモジュールを定義します。sandboxモジュールの親モジュールはgauche.gfモジュールになっているようです。ということは、userモジュールと同じだけの手続きやマクロが使えてしまいそうです。昨日書いてみたall-symbols手続きを少し改造して確認してみます。
(define (all-parents module)
  (let ((parents (module-parents module)))
    (let rec ((parents parents)(acc '()))
      (if (null? parents)
          acc
          (rec (cdr parents)(append (cons (car parents) acc)
                                    (all-parents (car parents))))))))

(define (all-symbols module)
  (map (lambda (m)
         (sort (hash-table-keys (module-table m))
               (lambda (x y)
                 (string<? (symbol->string x)
                           (symbol->string y)))))
       (all-parents module)))

(length (apply append (all-symbols (find-module 'sandbox))))
;; -> 1423
1423個もありました。

これはsandboxとしてはまずそうです。sandboxモジュールはnullモジュールから直接継承してもらいたいので、継承関係をぶち壊すためにextendマクロを使います。
(eval '(extend null) (find-module 'sandbox))

(module-parents (find-module 'sandbox))
;; -> (#<module null>)
希望通りにsandboxモジュールはnullモジュールを直接継承したようです。

ホントに?
(module-parents (find-module 'sandbox))
;; -> (#<module null>)

(hash-table-keys (module-table (find-module 'sandbox)))
;; -> ()

(length (apply append (all-symbols (find-module 'sandbox))))
;; -> 22

(apply append (all-symbols (find-module 'sandbox)))
;; -> (and begin case cond define define-syntax delay do if lambda let let* let-syntax letrec letrec-syntax or quasiquote quote set! syntax-rules unquote unquote-splicing)

(module-parents (find-module 'sandbox))
;; -> (#<module null>)
よさそうです。

define-sandbox

こういう風に書きたいですよね。
(define-sandbox <name>)
これが下記のように展開されるマクロがあれば良さそうです。
(begin
  (define-module <name>)
  (define <name> (find-module (quote <name>)))
  (eval '(extend null) <name>))

書いてみます。
(define-macro (define-sandbox name)
  `(begin
     (define-module ,name)
     (define ,name (find-module (quote ,name)))
     (eval '(extend null) ,name)))

期待通りに展開されるか%macroexpandマクロで確認してみます。
(%macroexpand (define-sandbox hoge))
;; (begin
;;   (define-module hoge)
;;   (define hoge (find-module 'hoge))
;;   (eval '(extend null) hoge))


動作も期待通りでしょうか?
(define-sandbox hoge)

hoge
;; -> #<module hoge>

(module-parents hoge)
;; -> (#<module null>)

(apply append (all-symbols hoge))
;; -> (and begin case cond define define-syntax delay do if lambda let let* let-syntax letrec letrec-syntax or quasiquote quote set! syntax-rules unquote unquote-splicing)
良さそうです。

ですが・・・、sandbox内で使いたい手続きやマクロを全てdefine-in-moduleで定義していくのも結構しんどそうです。define-sandboxで下記のように書けたら嬉しいかもしれません。
(define-sandbox <name>
  (symbol ... ))

展開イメージはこんな感じ。
(begin
  (define-module <name>)
  (define <name> (find-module (quote <name>)))
  (eval '(extend null) <name>)
  (begin
    (define-in-module <name> symbol symbol)
    ... ))

define-sandboxマクロを編集します。
(define-macro (define-sandbox name . symbols)
  `(begin
     (define-module ,name)
     (define ,name (find-module (quote ,name)))
     (eval '(extend null) ,name)
     (begin
       ,@(map (lambda (sym)
                `(define-in-module ,name ,sym ,sym))
              symbols)
       (undefined))))

動作を確認してみます。
(%macroexpand (define-sandbox hoge))
;; (begin
;;   (define-module hoge)
;;   (define hoge (find-module 'hoge))
;;   (eval '(extend null) hoge) (begin))

(%macroexpand (define-sandbox fuga + * - /))
;; (begin
;;   (define-module fuga)
;;   (define fuga (find-module 'fuga))
;;   (eval '(extend null) fuga)
;;   (begin
;;     (define-in-module fuga + +)
;;     (define-in-module fuga * *)
;;     (define-in-module fuga - -)
;;     (define-in-module fuga / /)))

(define-sandbox fuga + * - /)

(hash-table-keys (module-table fuga))
;; -> (/ * - +)

(module-parents fuga)
;; -> (#<module null>)
良さそうですね。

でも、sandbox内で使いたい手続きやマクロを毎度一つずつ追加するのも面倒です。指定したモジュールだけsandbox内でuseできたら便利そうです。
(define-sandbox <name> (using-module ...)
  (symbol ...))

展開イメージはこうでしょうか。
(begin
  (define-module <name>)
  (define <name> (find-module (quote <name>)))
  (eval '(begin (use using-module) ...) <name>)
  (eval '(extend null) <name>)
  (begin
    (define-in-module <name> symbol symbol)
    ... ))

define-sandboxを拡張します。
(define-macro (define-sandbox name modules . symbols)
  `(begin
     (define-module ,name)
     (define ,name (find-module (quote ,name)))
     (eval (quote (begin ,@(map (lambda (m)
                                   `(use ,m))
                                 modules))) ,name)
     (eval '(extend null) ,name)
     (begin
       ,@(map (lambda (sym)
                `(define-in-module ,name ,sym ,sym))
              symbols)
       (undefined))))

%macroexpandしてみます。
(%macroexpand (define-sandbox hoge (srfi-1 util.list gauche.sequence)
                + - * /))
;; (begin
;;   (define-module hoge)
;;   (define hoge (find-module 'hoge))
;;   (eval '(begin (use srfi-1) (use util.list) (use gauche.sequence)) hoge)
;;   (eval '(extend null) hoge)
;;   (begin
;;     (define-in-module hoge + +)
;;     (define-in-module hoge - -)
;;     (define-in-module hoge * *)
;;     (define-in-module hoge / /)
;;     (undefined)))

期待通りの動きをするでしょうか。
(define-sandbox hoge (srfi-1 util.list gauche.sequence)
  + - * /)


(module-parents hoge)
;; -> (#<module null>)

(hash-table-keys (module-table hoge))
;; -> (/ * - +)

(eval 'iota hoge)
;; -> #<closure iota>

(eval 'assoc-ref hoge)
;; -> #<closure assoc-ref>

(eval 'fold-with-index hoge)
;; -> #<generic fold-with-index (3)>

(eval 'list hoge)
;; -> *** ERROR: unbound variable: list

(eval 'map hoge)
;; -> #<generic map (2)>
define-sandbox時に指定したモジュールからexportされている束縛はsandbox内から見えているようです。define-in-moduleで指定されていない束縛であるlistは見えていません。これで良さそうです。

取りあえずこれでdefine-sandboxは完成ということにします。
(define-macro (define-sandbox name modules . symbols)
  `(begin
     (define-module ,name)
     (define ,name (find-module (quote ,name)))
     (eval (quote (begin ,@(map (lambda (m)
                                   `(use ,m))
                                 modules))) ,name)
     (eval '(extend null) ,name)
     (begin
       ,@(map (lambda (sym)
                `(define-in-module ,name ,sym ,sym))
              symbols)
       (undefined))))

あとは、define-sandboxでsandboxを定義した後に束縛を追加したくなったりuseされるモジュールを追加したくなった場合のために、inject-sandbox-symbols, inject-sandbox-modulesのようなマクロがあると便利かもしれません。

これでネットワーク越しに受け取ったS式などを心置きなくevalできますね!

参考

@kikuchan98さんに教えてもらった内容を参考にしました。

追記

探してみたらkahuaにsandbox.scmというものがあった。どうやら上記のsandboxとは違ってブラックリストを指定するタイプみたい。それとmake-moduleを使って無名モジュールを作ってそれをsandboxにしているみたい。

追記

プログラミングGauche

ifをcondで書け

って以外意外と面倒なんだな。。

syntax-rulesで
(define-syntax new-if
  (syntax-rules ()
    ((_ predicate then-clause else-clause)
     (cond (predicate then-clause)
           (else else-clause)))
    ((_ pred then)
     (new-if pred then (undefined)))))

(unwrap-syntax (%macroexpand (new-if #f (print "hoge")(print "fuga"))))
;; -> (cond (#f (print "hoge")) (else (print "fuga")))
(unwrap-syntax (%macroexpand (new-if #t (print "hoge")(print "fuga"))))
;; -> (cond (#t (print "hoge")) (else (print "fuga")))
(unwrap-syntax (%macroexpand (new-if #f (print "hoge"))))
;; -> (cond (#f (print "hoge")) (else (undefined)))
(unwrap-syntax (%macroexpand (new-if #t (print "hoge"))))
;; -> (cond (#t (print "hoge")) (else (undefined)))
(unwrap-syntax (%macroexpand (new-if #t (print "hoge")(print "fuga")(print "?"))))
;; -> *** ERROR: Compile Error: malformed if

define-macroで
(define-macro (new-if predicate then-clause . else-clause)
  `(cond (,predicate ,then-clause)
         ,(cond ((null? else-clause)`(else ,(undefined)))
                ((null? (cdr else-clause))`(else ,@else-clause))
                (else (error "malformed if")))))


(unwrap-syntax (%macroexpand (new-if #f (print "hoge")(print "fuga"))))
;; -> (cond (#f (print "hoge")) (else (print "fuga")))
(unwrap-syntax (%macroexpand (new-if #t (print "hoge")(print "fuga"))))
;; -> (cond (#t (print "hoge")) (else (print "fuga")))
(unwrap-syntax (%macroexpand (new-if #f (print "hoge"))))
;; -> (cond (#f (print "hoge")) (else #<undef>))
(unwrap-syntax (%macroexpand (new-if #t (print "hoge"))))
;; -> (cond (#t (print "hoge")) (else #<undef>))
(unwrap-syntax (%macroexpand (new-if #t (print "hoge")(print "fuga")(print "?"))))
;; -> *** ERROR: Compile Error: malformed if

初期状態で見えているsymbolたち(Gaucheのuserモジュール)


現在のモジュールは
(module-name (current-module))
;; -> user

その親のモジュールは
(module-parents (current-module))
;; -> (#<module gauche.gf>)

現在のモジュールから見えているsymbolは
(hash-table-keys (module-table (current-module)))
;; -> (*program-name* *argv*)

モジュールを継承すると親モジュールの中のsymbolは全て見えるということなので、継承関係を遡って全ての親モジュールを取得する。
(define (all-parents module)
  (let ((parents (module-parents module)))
    (let rec ((parents parents)(acc '()))
      (if (null? parents)
          acc
          (rec (cdr parents)(append (cons (car parents) acc)
                                    (all-parents (car parents))))))))

(all-parents (current-module))
;; ->  (#<module gauche.gf> #<module gauche> #<module scheme> #<module null>)

で、それぞれのモジュール内のsymbol名を取得して集める。
(define (all-symbols module)
  (map (lambda (m)
         (list (module-name m)
               (sort (hash-table-keys (module-table m))
                     (lambda (x y)
                       (string<? (symbol->string x)
                                 (symbol->string y))))))
       (all-parents module)))

(all-symbols (current-module))
;; ((gauche.gf ())
;;  (gauche (%add-load-path %alist-delete %alist-delete! %autoload %bignum-dump %char-set-add! %char-set-add-chars! %char-set-add-range! %char-set-complement! %char-set-dump %char-set-equal? %char-set-predefined %char-set-ranges %char-set<=? %check-class-binding %default-signal-handler %delete %delete! %delete-duplicates %delete-duplicates! %ensure-generic-function %exit %export-all %extend-module %format %gauche-runtime-directory %get-reader-ctor %guard-rec %hash-string %hash-table-iter %let-keywords-rec %macroexpand %macroexpand-1 %make-tree-map %maybe-substring %open-input-file %open-input-file/conv %open-output-file %open-output-file/conv %regexp-dump %regexp-pattern %regmatch-dump %require %sort %sort! %string-pointer-dump %string-replace-body! %string-split-by-char %sys-escape-windows-command-line %tree-map-bound %tree-map-check-consistency %tree-map-dump %tree-map-iter %uvector-ref %vm-make-parameter-slot %vm-parameter-ref %vm-parameter-set! %vm-show-stack-trace &condition &error &i/o-closed-error &i/o-error &i/o-port-error &i/o-read-error &i/o-write-error &message &read-error &serious *. *char-code-max* |+.| |-.| |.$| /. <abandoned-mutex-exception-meta> <abandoned-mutex-exception> <accessor-method> <arity-at-least> <autoload-meta> <autoload> <boolean-meta> <boolean> <char-meta> <char-set-meta> <char-set> <char> <class> <coding-aware-port> <collection> <compiled-code> <complex-meta> <complex> <compound-condition> <condition-meta> <condition> <dictionary> <eof-object> <error> <exception> <f16vector-meta> <f16vector> <f32vector-meta> <f32vector> <f64vector-meta> <f64vector> <foreign-pointer> <generic> <gloc-meta> <gloc> <hash-table-meta> <hash-table> <identifier> <integer-meta> <integer> <io-closed-error> <io-error> <io-read-error> <io-unit-error> <io-write-error> <join-timeout-exception-meta> <join-timeout-exception> <keyword-meta> <keyword> <list-meta> <list> <macro-meta> <macro> <message-condition> <method> <module-meta> <module> <next-method> <null-meta> <null> <number-meta> <number> <object> <ordered-dictionary> <pair-meta> <pair> <port-error> <port> <procedure> <promise-meta> <promise> <rational-meta> <rational> <read-context> <read-error> <read-reference> <real-meta> <real> <regexp-meta> <regexp> <regmatch-meta> <regmatch> <s16vector-meta> <s16vector> <s32vector-meta> <s32vector> <s64vector-meta> <s64vector> <s8vector-meta> <s8vector> <sequence> <serious-compound-condition> <serious-condition> <slot-accessor> <string-meta> <string-pointer-meta> <string-pointer> <string> <symbol-meta> <symbol> <syntactic-closure> <syntax-meta> <syntax-pattern-meta> <syntax-pattern> <syntax-rules-meta> <syntax-rules> <syntax> <sys-fdset> <sys-group> <sys-passwd> <sys-sigset> <sys-stat> <sys-tm> <system-error> <terminated-thread-exception-meta> <terminated-thread-exception> <thread-exception-meta> <thread-exception> <thread-meta> <thread> <time> <top> <tree-map-meta> <tree-map> <u16vector-meta> <u16vector> <u32vector-meta> <u32vector> <u64vector-meta> <u64vector> <u8vector-meta> <u8vector> <uncaught-exception-meta> <uncaught-exception> <undefined-object> <unhandled-signal-error> <unknown> <uvector-meta> <uvector> <vector-meta> <vector> <weak-hash-table-meta> <weak-hash-table> <weak-vector-meta> <weak-vector> E2BIG EACCES EADDRINUSE EADDRNOTAVAIL EADV EAFNOSUPPORT EAGAIN EALREADY EBADE EBADF EBADFD EBADMSG EBADR EBADRQC EBADSLT EBFONT EBUSY ECANCELED ECHILD ECHRNG ECOMM ECONNABORTED ECONNREFUSED ECONNRESET EDEADLK EDEADLOCK EDESTADDRREQ EDOM EDOTDOT EDQUOT EEXIST EFAULT EFBIG EHOSTDOWN EHOSTUNREACH EIDRM EILSEQ EINPROGRESS EINTR EINVAL EIO EISCONN EISDIR EL2HLT EL2NSYNC EL3HLT EL3RST ELIBACC ELIBBAD ELIBEXEC ELIBMAX ELIBSCN ELNRNG ELOOP EMFILE EMLINK EMSGSIZE EMULTIHOP ENAMETOOLONG ENETDOWN ENETRESET ENETUNREACH ENFILE ENOANO ENOBUFS ENOCSI ENODATA ENODEV ENOENT ENOEXEC ENOLCK ENOLINK ENOMEDIUM ENOMEM ENOMSG ENONET ENOPKG ENOPROTOOPT ENOSPC ENOSR ENOSTR ENOSYS ENOTBLK ENOTCONN ENOTDIR ENOTEMPTY ENOTSOCK ENOTTY ENOTUNIQ ENXIO EOPNOTSUPP EOVERFLOW EPERM EPFNOSUPPORT EPIPE EPROTO EPROTONOSUPPORT EPROTOTYPE ERANGE EREMCHG EREMOTE EROFS ESHUTDOWN ESOCKTNOSUPPORT ESPIPE ESRCH ESRMNT ESTALE ESTRPIPE ETIME ETIMEDOUT ETOOMANYREFS ETXTBSY EUNATCH EUSERS EWOULDBLOCK EXDEV EXFULL F_OK LC_ALL LC_COLLATE LC_CTYPE LC_MONETARY LC_NUMERIC LC_TIME RAND_MAX RLIMIT_AS RLIMIT_CORE RLIMIT_CPU RLIMIT_DATA RLIMIT_FSIZE RLIMIT_NOFILE RLIMIT_OFILE RLIMIT_STACK RLIM_INFINITY R_OK SCM_UVECTOR_F16 SCM_UVECTOR_F32 SCM_UVECTOR_F64 SCM_UVECTOR_S16 SCM_UVECTOR_S32 SCM_UVECTOR_S64 SCM_UVECTOR_S8 SCM_UVECTOR_U16 SCM_UVECTOR_U32 SCM_UVECTOR_U64 SCM_UVECTOR_U8 SEEK_CUR SEEK_END SEEK_SET SIGABRT SIGALRM SIGBUS SIGCHLD SIGCONT SIGFPE SIGHUP SIGILL SIGINT SIGIO SIGKILL SIGPIPE SIGPOLL SIGPROF SIGPWR SIGQUIT SIGSEGV SIGSTOP SIGTERM SIGTRAP SIGTSTP SIGTTIN SIGTTOU SIGURG SIGUSR1 SIGUSR2 SIGVTALRM SIGWINCH SIGXCPU SIGXFSZ SIG_BLOCK SIG_SETMASK SIG_UNBLOCK W_OK X_OK ^ ^-generator ^_ ^a ^b ^c ^d ^e ^f ^g ^h ^i ^j ^k ^l ^m ^n ^o ^p ^q ^r ^s ^t ^u ^v ^w ^x ^y ^z acons acosh add-load-path add-method! alist->tree-map all-modules allocate-instance and-let* any any$ any-pred append! apply$ apply-generic apply-method apply-methods arity arity-at-least-value arity-at-least? ash asinh assoc$ atanh autoload begin0 bignum? bit-field boolean byte-ready? byte-substring caaaar caaadr caaar caadar caaddr caadr cadaar cadadr cadar caddar cadddr caddr call-with-input-string call-with-output-string call-with-string-io case-lambda cdaaar cdaadr cdaar cdadar cdaddr cdadr cddaar cddadr cddar cdddar cddddr cdddr ceiling->exact change-class change-object-class char->ucs char-set char-set-contains? char-set-copy char-set? check-arg circular-list? clamp class-direct-methods class-direct-slots class-direct-subclasses class-direct-supers class-name class-of class-precedence-list class-redefinition class-slot-accessor class-slot-bound? class-slot-definition class-slot-ref class-slot-set! class-slots closure-code closure? compare complement compose compute-applicable-methods compute-cpl compute-get-n-set compute-slot-accessor compute-slots cond-expand condition condition-has-type? condition-ref condition-type? condition? copy-bit copy-bit-field copy-port cosh count$ current-class-of current-error-port current-exception-handler current-load-history current-load-next current-load-path current-load-port current-microseconds current-module current-thread current-time cut cute debug-print debug-print-width debug-source-info dec! declare decode-float default-endian define define-^x define-class define-compiler-macro define-condition-type define-constant define-generic define-in-module define-inline define-macro define-method define-module define-reader-ctor define-reader-directive define-values delete$ delete-keyword delete-keyword! delete-keywords delete-keywords! delete-method! digit->integer disasm dolist dotimes dotted-list? dynamic-load eager eof-object eq-hash eqv-hash error errorf eval-when every every$ every-pred exit exit-handler export export-all export-if-defined extend extract-condition file-exists? file-is-directory? file-is-regular? filter$ find find$ find-module find-tail$ finite? fixnum-width fixnum? flonum? floor->exact fluid-let flush flush-all-ports fmod fold fold$ fold-right fold-right$ for-each$ foreign-pointer-attribute-get foreign-pointer-attribute-set foreign-pointer-attributes format format/ss frexp gauche-architecture gauche-architecture-directory gauche-character-encoding gauche-dso-suffix gauche-library-directory gauche-site-architecture-directory gauche-site-library-directory gauche-version gc gc-stat gensym get-keyword get-keyword* get-optional get-output-byte-string get-output-string get-remaining-input-string get-signal-handler get-signal-handler-mask get-signal-handlers get-signal-pending-limit getter-with-setter glob glob-component->regexp glob-fold global-variable-bound? global-variable-ref greatest-fixnum guard has-setter? hash hash-table hash-table-clear! hash-table-copy hash-table-delete! hash-table-exists? hash-table-fold hash-table-for-each hash-table-get hash-table-keys hash-table-map hash-table-num-entries hash-table-pop! hash-table-push! hash-table-put! hash-table-stat hash-table-type hash-table-update! hash-table-values hash-table? identifier->symbol identifier? identity if-let1 import inc! include inexact-/ infinite? initialize inline-stub instance-slot-ref instance-slot-set integer->digit integer-length is-a? keyword->string keyword? lambda last-pair lazy ldexp least-fixnum let-keywords let-keywords* let-optionals* let/cc let1 library-exists? library-fold library-for-each library-has-module? library-map list* list->sys-fdset list-copy load-from-port logand logbit? logcount logior lognot logtest logxor macroexpand macroexpand-1 make make-byte-string make-compound-condition make-condition make-condition-type make-glob-fs-fold make-hash-table make-keyword make-list make-module make-string-pointer make-tree-map make-weak-vector map$ member$ merge merge! method-more-specific? min&max modf module-exports module-imports module-name module-name->path module-parents module-precedence-list module-table module? monotonic-merge nan? native-endian null-list? object-* object-+ object-- object-/ object-apply object-compare object-equal? object-hash open-coding-aware-port open-input-buffered-port open-input-fd-port open-input-string open-output-buffered-port open-output-fd-port open-output-string pa$ partition$ path->module-name peek-byte pop! port->byte-string port->list port->sexp-list port->string port->string-list port-buffering port-case-fold-set! port-closed? port-current-line port-fd-dup! port-file-number port-fold port-fold-right port-for-each port-map port-name port-position-prefix port-seek port-tell port-type print procedure-arity-includes? procedure-info profiler-reset profiler-show profiler-show-load-stats profiler-start profiler-stop program promise-kind promise? proper-list? provide provided? push! quotient&remainder raise read-block read-byte read-char-set read-eval-print-loop read-from-string read-line read-list read-reference-has-value? read-reference-value read-reference? read-with-shared-structure read/ss rec receive redefine-class! reduce$ reduce-right$ ref ref* regexp->string regexp-ast regexp-case-fold? regexp-compile regexp-optimize regexp-parse regexp-quote regexp-replace regexp-replace* regexp-replace-all regexp-replace-all* regexp-unparse regexp? regmatch? remove$ report-error require require-extension reverse! rlet1 round->exact rxmatch rxmatch->string rxmatch-after rxmatch-before rxmatch-case rxmatch-cond rxmatch-end rxmatch-if rxmatch-let rxmatch-num-matches rxmatch-start rxmatch-substring seconds->time select-module set!-values set-signal-handler! set-signal-pending-limit setter |setter of object-apply| |setter of ref| sinh slot-bound-using-accessor? slot-bound-using-class? slot-bound? slot-definition-accessor slot-definition-allocation slot-definition-getter slot-definition-name slot-definition-option slot-definition-options slot-definition-setter slot-exists-using-class? slot-exists? slot-initialize-using-accessor! slot-missing slot-pop! slot-push! slot-ref slot-ref-using-accessor slot-ref-using-class slot-set! slot-set-using-accessor! slot-set-using-class! slot-unbound sort sort! sort-applicable-methods sort-by sort-by! sorted? split-at stable-sort stable-sort! stable-sort-by stable-sort-by! standard-error-port standard-input-port standard-output-port string->regexp string->uninterned-symbol string-byte-ref string-byte-set! string-complete->incomplete string-fill! string-immutable? string-incomplete->complete string-incomplete->complete! string-incomplete? string-interpolate string-join string-pointer-byte-index string-pointer-copy string-pointer-index string-pointer-next! string-pointer-prev! string-pointer-ref string-pointer-set! string-pointer-substring string-pointer? string-scan string-size string-split subr? supported-character-encoding? supported-character-encodings symbol-bound? symbol-interned? symbol-sans-prefix syntax-error syntax-errorf sys-abort sys-access sys-alarm sys-asctime sys-basename sys-chdir sys-chmod sys-chown sys-close sys-ctermid sys-ctime sys-difftime sys-dirname sys-environ sys-environ->alist sys-exec sys-exit sys-fchmod sys-fdset sys-fdset->list sys-fdset-clear! sys-fdset-copy! sys-fdset-max-fd sys-fdset-ref sys-fdset-set! sys-fork sys-fork-and-exec sys-fstat sys-ftruncate sys-getcwd sys-getdomainname sys-getegid sys-getenv sys-geteuid sys-getgid sys-getgrgid sys-getgrnam sys-getgroups sys-gethostname sys-getloadavg sys-getlogin sys-getpgid sys-getpgrp sys-getpid sys-getppid sys-getpwnam sys-getpwuid sys-getrlimit sys-gettimeofday sys-getuid sys-gid->group-name sys-glob sys-gmtime sys-group-name->gid sys-isatty sys-kill sys-lchown sys-link sys-localeconv sys-localtime sys-lstat sys-mkdir sys-mkfifo sys-mkstemp sys-mktime sys-nanosleep sys-normalize-pathname sys-pause sys-pipe sys-putenv sys-random sys-readdir sys-readlink sys-realpath sys-remove sys-rename sys-rmdir sys-select sys-select! sys-setenv sys-setgid sys-setlocale sys-setpgid sys-setrlimit sys-setsid sys-setuid sys-sigmask sys-signal-name sys-sigset sys-sigset-add! sys-sigset-delete! sys-sigset-empty! sys-sigset-fill! sys-sigsuspend sys-sigwait sys-sleep sys-srandom sys-stat sys-stat->atime sys-stat->ctime sys-stat->dev sys-stat->file-type sys-stat->gid sys-stat->ino sys-stat->mode sys-stat->mtime sys-stat->nlink sys-stat->rdev sys-stat->size sys-stat->type sys-stat->uid sys-strerror sys-strftime sys-symlink sys-system sys-time sys-times sys-tm->alist sys-tmpdir sys-tmpnam sys-truncate sys-ttyname sys-uid->user-name sys-umask sys-uname sys-unlink sys-unsetenv sys-user-name->uid sys-utime sys-wait sys-wait-exit-status sys-wait-exited? sys-wait-signaled? sys-wait-stopped? sys-wait-stopsig sys-wait-termsig sys-waitpid tanh time time->seconds time? toplevel-closure? touch-instance! tree-map->alist tree-map-ceiling tree-map-ceiling-key tree-map-ceiling-value tree-map-clear! tree-map-copy tree-map-delete! tree-map-empty? tree-map-exists? tree-map-floor tree-map-floor-key tree-map-floor-value tree-map-fold tree-map-fold-right tree-map-for-each tree-map-get tree-map-keys tree-map-map tree-map-max tree-map-min tree-map-num-entries tree-map-pop! tree-map-pop-max! tree-map-pop-min! tree-map-predecessor tree-map-predecessor-key tree-map-predecessor-value tree-map-push! tree-map-put! tree-map-successor tree-map-successor-key tree-map-successor-value tree-map-update! tree-map-values tree-map? truncate->exact ucs->char undefined undefined? unless until unwind-protect unwrap-syntax update! update-direct-method! update-direct-subclass! use use-version uvector-immutable? uvector-length values-ref vector-copy vm-dump vm-get-stack-trace vm-get-stack-trace-lite vm-set-default-exception-handler warn weak-vector-length weak-vector-ref weak-vector-set! when while with-error-handler with-error-to-port with-exception-handler with-input-from-port with-input-from-string with-module with-output-to-port with-output-to-string with-port-locking with-ports with-signal-handlers with-string-io write* write-byte write-limited write-object write-to-string write-with-shared-structure write/ss x->integer x->number x->string ~))
;;  (scheme (%acos %asin %atan %cos %cosh %exp %expt %gcd %log %sin %sinh %sqrt %tan %tanh * *dynamic-load-path* *load-path* *load-suffixes* + - / < <= = > >= abs acos angle append apply asin assoc assq assv atan boolean? caaaar caaadr caaar caadar caaddr caadr caar cadaar cadadr cadar caddar cadddr caddr cadr call-with-current-continuation call-with-input-file call-with-output-file call-with-values call/cc car cdaaar cdaadr cdaar cdadar cdaddr cdadr cdar cddaar cddadr cddar cdddar cddddr cdddr cddr cdr ceiling char->integer char-alphabetic? char-ci<=? char-ci<? char-ci=? char-ci>=? char-ci>? char-downcase char-lower-case? char-numeric? char-ready? char-upcase char-upper-case? char-whitespace? char<=? char<? char=? char>=? char>? char? close-input-port close-output-port complex? cons cos current-input-port current-output-port denominator display div div-and-mod div0 div0-and-mod0 dynamic-wind eof-object? eq? equal? eqv? eval even? exact exact->inexact exact-integer-sqrt exact? exp expt floor for-each force gcd imag-part inexact inexact->exact inexact? input-port? integer->char integer-valued? integer? interaction-environment lcm length length+ list list->string list->vector list-ref list-tail list? load log magnitude make-polar make-rectangular make-string make-vector map max member memq memv min mod mod0 modulo nearly=? negative? newline not null-environment null? number->string number? numerator odd? open-input-file open-output-file output-port? pair? peek-char port? positive? procedure? quotient rational-valued? rational? read read-char real-part real-valued? real? remainder reverse round scheme-report-environment set-car! set-cdr! sin sqrt string string->list string->number string->symbol string-append string-ci<=? string-ci<? string-ci=? string-ci>=? string-ci>? string-copy string-length string-ref string-set! string<=? string<? string=? string>=? string>? string? substring symbol->string symbol? tan truncate values vector vector->list vector-fill! vector-length vector-ref vector-set! vector? with-input-from-file with-output-to-file write write-char zero?))
;;  (null (and begin case cond define define-syntax delay do if lambda let let* let-syntax letrec letrec-syntax or quasiquote quote set! syntax-rules unquote unquote-splicing)))
思ったよりたくさん出てきてびっくりした。

追記

正確には、「初期状態で見えているsymbolたち(Gaucheのuserモジュール)」ではなく「初期状態で束縛されているsymbolたち(Gaucheのuserモジュール)」か。


プログラミングGauche

twitter apiの日付け

twitter apiの日付け形式って何なの。
"Sat Nov 21 02:20:25 +0000 2009"
Gaucheのrfc.822モジュールにrfc822-date->date手続きがあったので、それに合うようにしてしのいだ。

(use srfi-19) ; date
(use rfc.822) ; rfc822-date->date
(use util.list) ; interspers

(define (twitter-date->date str)
  (define (list-join delim ls)
    (apply string-append (intersperse delim ls)))
  (let* ((ls (string-split str " "))
         (date-string (list-join " " (map (pa$ list-ref ls)
                                          '(0 2 1 5 3 4)))))
    (rfc822-date->date date-string)))
(date->string
 (twitter-date->date "Sat Nov 21 02:20:25 +0000 2009")
 "~Y/~m/~d ~H:~M:~S")
;; -> "2009/11/21 02:20:25"

追記

コメント欄で教えてもらいました!

Scheme手習い

Twitterのお気に入りをランダムに表示して楽しむ



指定したTwitterユーザーのお気に入り(favorite)からランダムに1つ選んで表示するGaucheスクリプトです。

9LISPで作っているquotuneというWebサービス(現在のところ公開していません)の一部としてcgiを書いたのですが、shellからも使えるようにしました。私は
alias fav='/hoge/fuga/favorite.scm'
というようにして使っています。自分がふぁぼったものから見るのも他人のふぁぼりを見るのも結構面白いです。

実は以前、twitter botとして運用していたのですが、いつの間にか動かなくなって放置していました。この際これに置き換えようかと思います。

shell

適当なところに保存して以下のように呼び出します。
./favorite twitter-user-id
例えば
./favorite valvallow

cgi

cgiが動くところに保存して以下のようにアクセスします。
http://example.com/favorite/twitter-user-id

json

twitterのapiから返ってくるjsonをそのまま返すこともできます。
./favorite -j twitter-user-id
http://example.com/favorite/twitter-user-id/json

code

Gauche 0.9.1、CentOS/Cygwinで動作確認しています。


追記

こっちが新しいソース
Scheme手習い