hira:作ったモノ
作ったモノ。
再発明してるかもしれません。 同様のものや類似品などありましたら、どんどん参照を張って下さい。
- A (Assert)
- match?
- receive-*-for
- letn
- print-tree
- treq, trev, tree
- regmatch->list
- Mac,Win,Unixの改行コードをUnix形式に正規化
- InterWikiNameでググル
- ?, ??
- 「Gauche リファレンスマニュアル」をググる
- リストの分配法則
- file-is-symlink?
- string->glob
- dump
- directory-for-each
- parse-opt
- <range>
- 汎用slot操作集
- カレンダー (<date>拡張)
- pretty-expand
- 中置記法の四則演算マクロ
A (Assert)
TDDer養成ギブスに触発されつつ書いたマクロ。テストケースじゃなくても、伝統的なassert習慣は大事にしたいですね。
スタックトレースのunknown location問題はkouさんのところで議論されてました。 Assertマクロでは、エラー発生行番が分からないといまいち役に立たないので、残念なところです。
(define-syntax A ;A-on (syntax-rules () ((_ expr) (if expr #t (errorf "Assertion Failed:\n~s" 'expr))) ((_ expr . msg) (if expr #t (errorf "Assertion Failed: ~s\n~s" `msg 'expr))) )) (define-syntax A-off (syntax-rules () ((_ expr ) #t) ((_ expr . msg) #t))) ;;;実行例 (define a '(123 :456)) (A (= (car a) 1) カーは1でなきゃイヤン。 a = ,a) *** ERROR: Assertion Failed: (|カーは1でなきゃイヤン。| a = (123 :456)) (= (car a) 1) Stack Trace: _______________________________________ 0 (#<id 0x103f2930 user::errorf> "Assertion Failed: ~s\n~s" (#<id 0x ... [unknown location] ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (A (match? a (_ _ _) ('a ...)) 恣意的なテストでスマン) *** ERROR: Assertion Failed: (|恣意的なテストでスマン|) (match? a (_ _ _) ('a |...|)) Stack Trace: _______________________________________ 0 (#<id 0x103f11f0 user::errorf> "Assertion Failed: ~s\n~s" (#<id 0x ... [unknown location]
match?
パターンにマッチしたら#t。最後のパターンは(_ #f)という定型処理を簡単に。
(define-macro (match? ls . pats) `(match ,ls ,@(map (cut list <> #t) pats) (_ #f)))
kou: 単純に最後に(_ #f)を付け足すと,
(match? 1 _)
といった場合に
WARNING: unreachable pattern _ in (match 1 (_ #t) (_ #f))
というようにWARNINGがでるのが嫌だったので,patterns->boolean-match-patternsとかいうのを使って,tuple-match?とかいうのを作ったりしていました.
hira: なるほど。気づきませんでした。こうしておきます。
(define-macro (match? ls . pats) (if (find symbol? pats) #t `(match ,ls ,@(map (cut list <> #t) pats) (_ #f))))
いや、いっそエラーにすべきか。こんなパターン、タイポとしか思えないし・・・。
receive-*-for
- findのpredで非偽を返したらその値をそのまま戻り値としたかった
- call/cc抜きで実装しようとすると、多値の扱いが面倒だった(無駄が多そうでいや)
- ていうかrubyのforみたいな構文があればいいのでは
- rubyのforはreceive風だから、名前はreceive-*-forとしよう
- return, nextは予約語にしたいからdefine-macroで実装(returnはrubyの引数付きbreak)
- undefの扱いが面倒だから、body部の戻り値は無視
- condとの相性を考えて、最後まで行っちゃったら#fを返すようにしよう
(define-macro (receive-list-for vars expr . body) `(let/cc return (let loop ((ls ,expr)) (if (null? ls) #f (begin (let/cc next ,(if (pair? vars) `(apply (lambda ,vars ,@body) (car ls)) `( (lambda (,vars) ,@body) (car ls)))) (loop (cdr ls))))))) (define-macro (receive-alist-for vars expr . body) `(let/cc return (let loop ((ls ,expr)) (if (null? ls) #f (begin (let/cc next ((lambda ,vars ,@body) (caar ls) (cdar ls))) (loop (cdr ls))))))) ;;実行例 (receive-list-for x '(1 2 3) (if (= 2 x) (return (* 10 x)))) ;=> 20 (receive-list-for x '((1 . 2) (3 . 4) (5 . 6)) (if (= 3 (car x)) (return (* 10 (cdr x))))) ;=> 40 (receive-list-for (x y) '((1 2) (3 4) (5 6)) (if (= 3 x) (return (* 10 y)))) ;=> 40 (receive-alist-for (x y) '((1 . 2) (3 . 4) (5 . 6)) (if (= 3 x) (return (* 10 y)))) ;=> 40 ;;nextと多値のテスト (let1 foot-print '() (receive-alist-for (a b) '((1 . 2) (3 . 4) (1 . 2) (5 . 6) (7 . 8)) (if (= 1 a) (next)) (push! foot-print a) (if (= 6 b) (return (* a 10) (reverse foot-print))))) ;=> 50 (3 5)
- Shiro: 多値が扱えなくてよければ、GaucheRefj:anyがあります。
あ、でも今マニュアルを見てみたら記述がわかりにくいですね。
直しておきます。
(any (lambda (x) (and (= 2 x) (* 10 x))) '(1 2 3)) => 20
- hira: どうもです。今回は多値が必要なのでした。でもanyには気づいていませんでした。そうか。and/orの関数版がevery/anyなのか。多値を扱わないのは性能上の問題かしら。
letn
気がついたらこんなコードを大量に書いていました。
(receive (foo bar buz) (apply values (proc args)) ...)
なんかいやんな感じなのでマクロにしたのがこれです。
(define-syntax letn (syntax-rules () ((_ vars expr body ...) (apply (lambda vars body ...) expr))))
するとこんな風に書けます。
(letn (foo bar buz) (proc args) ...)
- Shiro: util.matchを使って、
(match-let1 (foo bar buz) (proc args) ...)
って手もありますね。どっちが速いだろう。 - hira: あああ、どっかで見たことあると思ったらGaucheRefj:match-let1でしたか・・・orz。速さは・・・
;(time (dotimes (i 10000) (letn (a b c) '(1 2 3) (list a b c)))) ; real 0.023 ; user 0.015 ; sys 0.000 ;(time (dotimes (i 10000) (match-let1 (a b c) '(1 2 3) (list a b c)))) ; real 0.047 ; user 0.047 ; sys 0.000
letnのほうが倍くらい速いみたいです。 - hira: どっかで見たことがあると思ったのはScheme:多値のrecieve+でした。全く同じです。ちなみにreceiveは爆速。最適化が効いてるみたい。
;(time (dotimes (i 10000) (receive (a b c) (values 1 2 3) (list a b c)))) ; real 0.006 ; user 0.016 ; sys 0.000 ;(time (dotimes (i 10000) (receive (a b c) (apply values '(1 2 3)) (list ... ; real 0.010 ; user 0.000 ; sys 0.000
print-tree
木の整形出力です。文字列連結しまくりで遅そうですが、util.matchで遊べたし、どうせ開発支援用途だし、遅くてもいいかなーと諦めております。
※リファクタリングしてたらmatchの必要性が無いことに気付いてしまった。tree?はevery版にすげ替え。
- [最終更新] (2004/06/06 19:25:08 PDT)
- [BUGFIX] nullやatomを渡すとエラーになるバグを修正。(2004/06/06 19:25:08 PDT)
(use srfi-1) (define (atom? x) (not (pair? x))) (define (tree? ls) (if (every (lambda (x) (and (pair? x) (atom? (car x)))) ls) (map car ls) #f)) (define (dotp? p) (and (pair? p) (atom? (cdr p)))) (define (print-tree indent ls) (define (max-string ls) (apply max (map string-length (map write-to-string ls)))) (cond ((null? ls) "()") ((atom? ls) (write-to-string ls)) (else (format "(~a)" (let loop ((indent indent) (ls ls)) (define (print-tree-main keys) (define (flat-fmt col val) (format #`"~,|col|s" val)) (format "~a" (let1 cols (max-string keys) (string-join (map (lambda (l k) (format (if (dotp? l) "(~a . ~a)" "(~a ~a)") (flat-fmt cols k) (loop (string-append indent (make-string (+ 2 cols))) (cdr l)))) ls keys) (format "\n~a " indent))))) (cond ((atom? ls) (write-to-string ls)) ((tree? ls) => print-tree-main) (else (string-join (map write-to-string ls) " ")))))))) ;;;実行例 (display ";'") (print (print-tree "; " '((:root (name Simple-Wiki) (block (list (:heading "*") (:ul "-") (:ol "+") (:define-parser "@")) (quot (:block-quote "|")) (tag (:CODE "{{{" "}}}") (:block-quote "<<<" ">>>")) (label (:NOTE "NOTE:")) (indent (:CODE 4))) (inline (tag (:foot-note "((" "*" "))") (:strong "''" "*" "''") (:w-bracket "[[" "*" "]]")) (keyword (:cond "*" "if" "else" "then") (:loop "*" "for" "while")) (prefix (:keyword ":" "[-a-zA-Z0-9]") (:env-var "$" "[_A-Z0-9]")) (postfix (:number "[0-9]" ".") (:define "[-a-zA-Z0-9]" ":")) (match (:uri "[a-z]+:\\/\\/[^\\[\\](){}<> ]+")) (comment (:comment ";;"))) (sep (:hr "-" "*" "*") (:hr-bold "=" "4" "*") (:hr-mid "*" "3" "3"))) (:heading (inline (tag (:category "[" "*" "]")))) (:ul (include :root))))) ;;;実行結果 ;'((:root (name Simple-Wiki) ; (block (list (:heading "*") ; (:ul "-") ; (:ol "+") ; (:define-parser "@")) ; (quot (:block-quote "|")) ; (tag (:CODE "{{{" "}}}") ; (:block-quote "<<<" ">>>")) ; (label (:NOTE "NOTE:")) ; (indent (:CODE 4))) ; (inline (tag (:foot-note "((" "*" "))") ; (:strong "''" "*" "''") ; (:w-bracket "[[" "*" "]]")) ; (keyword (:cond "*" "if" "else" "then") ; (:loop "*" "for" "while")) ; (prefix (:keyword ":" "[-a-zA-Z0-9]") ; (:env-var "$" "[_A-Z0-9]")) ; (postfix (:number "[0-9]" ".") ; (:define "[-a-zA-Z0-9]" ":")) ; (match (:uri "[a-z]+:\\/\\/[^\\[\\](){}<> ]+")) ; (comment (:comment ";;"))) ; (sep (:hr "-" "*" "*") ; (:hr-bold "=" "4" "*") ; (:hr-mid "*" "3" "3"))) ; (:heading (inline (tag (:category "[" "*" "]")))) ; (:ul (include :root))) (write (print-tree "" '())) ;=> "()" (write (print-tree "" #/hoge/)) ;=> "#/hoge/"
treq, trev, tree
木に対するアクセスってみんなどうしてるんだろうか。
(define (%make-tree-accessor pred) (define (tree-accessor tree fallback . path) (if (null? path) tree (let1 p (if (procedure? (car path)) (car path) (lambda (t) (pred (car path) t))) (cond ((p tree) => (lambda (c) (apply tree-accessor (cdr c) fallback (cdr path)))) (else fallback))))) tree-accessor) (define treq (%make-tree-accessor assq )) (define trev (%make-tree-accessor assv )) (define tree (%make-tree-accessor assoc)) ;;;実行例 (define $rule '((:root (name . Simple-Wiki) (block (re (list . #/^(\*|-|@|#)( +[^ ].*)$/) (quot . #/^(\|)(.*)$/) (stag . #/^(\{\{\{|<<<)( *)$/) (etag . #/^(\}\}\}|>>>)( *)$/)) (type (list ("*" . :heading) ("-" . :ul) ("#" . :ol) ("@" . :define-parser)) (quot ("|" . :block-quote)) (stag ("{{{" . :CODE) ("<<<" . :block-quote)) (etag ("}}}" . "{{{") (">>>" . "<<<")))) (inline (re . #/(;;)(.*)|[a-z]+:\/\/[^\[\](){}<> ]+|(\(\()(.*?)(\)\))|('')(.*?)('')|(\[\[)(.*?)(\]\])|(:)([-a-zA-Z0-9]+)|(\$)([_A-Z0-9]+)|([0-9]+)(\.)|([-a-zA-Z0-9]+)(:)/) (type (#/^(;;)(.*)$/ . :comment) (#/^[a-z]+:\/\/[^\[\](){}<> ]+$/ . :uri) (#/^(\(\()(.*?)(\)\))$/ . :foot-note) (#/^('')(.*?)('')$/ . :strong) (#/^(\[\[)(.*?)(\]\])$/ . :w-bracket) (#/^(:)([-a-zA-Z0-9]+)$/ . :keyword) (#/^(\$)([_A-Z0-9]+)$/ . :env-var) (#/^([0-9]+)(\.)$/ . :number) (#/^([-a-zA-Z0-9]+)(:)$/ . :define))) (sep (re . #/^(?:((-){1,})|((=){4,})|((\*){3,3}))( *)/) (type ("-" . :hr) ("=" . :hr-bold) ("*" . :hr-mid)))) (:heading (inline (re . #/(\[)(.*?)(\])/) (type ((#/^(\[)(.*?)(\])$/ . :category)))))) ) (treq $rule 'fail :root 'block 're 'list) ;=> #/^(-|\*|@|#)( *)(.*)$/ (treq $rule 'fail :root 'sep 'type "-") ;=> fail (tree $rule 'fail :root 'sep 'type "-") ;=> :hr (use srfi-1) (define (re-path str) (lambda (t) (find (lambda (c) ((car c) str)) t))) (tree $rule 'fail :root 'inline 'type (re-path "((hoge))")) ;=> :foot-note
regmatch->list
regmatchへのindex参照を相対的にするものです。()の絶対的な位置でアクセスするのではなく、n番目にマッチした()にアクセスしたいときに便利です。
#| 正規表現の()キャプチャリストを返す。#fは除く。 |# (define (regmatch->list regmatch) (let1 len (rxmatch-num-matches regmatch) (let loop ((index 0)) (if (= len index) '() (? (regmatch index) (cons <> (loop (+ index 1))) (loop (+ index 1))))))) (regmatch->list (#/(a)(b)|(a)(c)/ "ac")) ;=> ("ac" "a" "c") (regmatch->list (#/(a)(b(d|e))|(a)(c(d|e))/ "abd")) ;=> ("abd" "a" "bd" "d") (regmatch->list (#/(a)(b(d|e))|(a)(c(d|e))/ "ace")) ;=> ("ace" "a" "ce" "e")
- Shiro: regmatchの長さ(マッチの数)を取るAPIを0.8で追加しました。
- hira: どもっす。反映しておきました。
- 長さが取れるならこういう手も。--teranishi
(use srfi-1) (define (regmatch->list regmatch) (filter-map regmatch (iota (rxmatch-num-matches regmatch))))
- hira: あ、そっちの方が綺麗ですね。GaucheRefj:filter-mapはこういうときに使うとよかったのか。
Mac,Win,Unixの改行コードをUnix形式に正規化
たったこれだけ。正規表現最高ですな。
(define (eol->lf str) (regexp-replace-all #/\r\n?/ str "\n")) ;;;実行例 (eol->lf "Mac\rWin\r\nUnix\nMac\rWin\r\nUnix\n") ;=> "Mac\nWin\nUnix\nMac\nWin\nUnix\n"
#これが出来ないとしたら、とんでもない飢餓感に見舞われるんじゃないかしら。
- #/\r?\n/ ではなく?
- bare \r が改行 == old Mac text を意識しているんだからこれで良い?
- hira:Mac=CR,Win=CRLF,Unix=LFというのを前提にしています。old Macなんて有るんですか?new Macの改行コードは別なのかしら? \r?\nにしなかったのは\n->\n置換がイヤかなと思ったからです。結果は同じでしょうが、正規化済み(Unix)の入力に対して文字列の再構成が発生したらイヤだなと。どんな実装なのかは未確認ですが。
- MacOS X は Mach + OpenSTEP + *BSD userland + .... っていうのを良く聞くんで, 今の Mac だとテキストの行末は \n かなっていう思い込みがあったんです.
- hira:ああ、すいません。結果、同じじゃないですね。\rのみを改行コードとする場合を想定しているので。だから、そう。これでいいんです。仕様が分かりにくかったかしら。タイトルをそのものズバリに変えてみました。
- hira:Mac=CR,Win=CRLF,Unix=LFというのを前提にしています。old Macなんて有るんですか?new Macの改行コードは別なのかしら? \r?\nにしなかったのは\n->\n置換がイヤかなと思ったからです。結果は同じでしょうが、正規化済み(Unix)の入力に対して文字列の再構成が発生したらイヤだなと。どんな実装なのかは未確認ですが。
InterWikiNameでググル
InterWikiNameにRefとManを追加しちゃいました。 RefはGaucheのリファレンスマニュアルを、ManはLinuxのJMプロジェクトを検索します。
?, ??
and-let*するには大げさなときや、ifのelse句に#fを書くのが面倒なとき、list-refのfallbackをassqでもやりたいときなど、こんなマクロがあると便利だなぁと思ったので書いてみました。
※assqにはGaucheRefj:assq-refがあるのを発見。
※あと、Gauche:htmlリファレンスの参照より。
(define (file-part uri) (cond ((string-scan uri "#" 'before)) (else uri))) ;;;実行例 (file-part "hoge#fuga") ;=> "hoge" (file-part "hoge") ;=> "hoge"
こんなcondありだったのか。てっきり文法エラーになると思い込んでいました。
- [最終更新] (2004/04/26 11:49:55 PDT)
#| condの=>とcutをあわせた三項演算子のようなものです。 then句ではexprの結果を<>で参照できます。 else句が省略された場合、#fを返します。 |# (define-macro (? expr then . els) `(cond (,expr => (lambda (<>) ,then)) (else ,(if (null? els) #f (car els))))) #| エラーのときもelsを返すようにします。 |# (define-macro (?? expr then . els) `(with-error-handler (lambda (<>) ,(if (null? els) #f (car els))) (lambda () (? ,expr ,then ,@els)) )) ;;;実行例 (define als '((a . b) (c . d) (e . f) (b . c))) ;;fbがnullのとき、エラーになって#fが返る ;;でも、こう日常的に??を使うと遅くなりそう。 ;;ソケットからの読み込みなどでリードエラーを#fに変換したいときなどに使うのが吉 (define (assq* k als . fb) (? (assq k als) (cdr <>) (?? (car fb) <>))) (assq* 'a als) ;=> b (assq* 'g als) ;=> #f (assq* 'g als 'H) ;=> H (? (assq 'a als) (? (assq (cdr <>) als) (? (assq (cdr <>) als) (cdr <>)) (cdr <>))) ;=> d (define als '((a . b) (c . d) (e . f) (k . c))) (? (assq 'a als) (? (assq (cdr <>) als) (? (assq (cdr <>) als) (cdr <>)) (cdr <>))) ;=> b
- 今では全然使ってないっすねぇ、これ。この手の省略形は色々作ったけれど、すぐに飽きて使わなくなってしまう・・・ --hira(2004/07/12 17:35:33 PDT)
- Arcではifのcondの結果がitにバインドされるそうな--hira(2004/08/02 12:21:08 PDT)
Usually use if, which binds it: (if (a x) (car it))
「Gauche リファレンスマニュアル」をググる
こんな風にsiteとintitleで範囲を限定すると良い感じで検索できます。Googleって素晴らしいですね。
リストの分配法則
string->globの{}サポートに使う予定のモノです。 直感的に「分配法則だ」と思ったのでそう呼んでますが、正しいかどうかは自信無いです。 ちなみに、今まで作ったモノの中で一番難産しました。 こういうリスト処理でつまずくと「俺って根本的にアホなんじゃないか」と思えてくるから危険です。 もっと単純な解などありましたら、ここに貼っちゃって下さい。
- 関連するモノ
- GaucheRefj:cartesian-product
- Scheme:リスト処理 : ここに入れたいのだけど、まだ仕様に自信がないので保留。
- [最終更新] (2004/04/22 23:44:46 PDT)
(use srfi-1) ;fold #| リストの分配法則。 carをcdrに分配する。 (a b c) => ((a b) (a c)) (() a b c) => ((a) (b) (c)) ((a b) c d) => ((a b c) (a c d)) ((() a b) c d) => ((a c) (a d) (b c) (b d)) |# (define (dist ls) (define (d1 h r) (cond ((null? r) '()) ((pair? h) (fold (lambda (h1 knil) (append knil (d2 h1 r))) '() h)) (else (d2 h r)))) (define (d2 h r) (if (null? r) '() (receive (konsp konsa) (cond ((pair? h) (values append (lambda (h v) (append h (list v))))) ((null? h) (values (lambda (h v) v) (lambda (h v) (list v)))) (else (values cons list))) (let1 v (car r) (if (pair? v) (append (map (lambda (x) (konsp h x)) (dist v)) (d2 h (cdr r))) (cons (konsa h v) (d2 h (cdr r)))))))) (if (or (not (pair? ls)) (null? (cdr ls))) ls (let1 h (car ls) (if (pair? h) (d1 (dist h) (cdr ls)) (d1 h (cdr ls)))))) ;;;;実行例 (use gauche.test) ;test* (define-macro T* (lambda (expr expect) `(test* (format "~s" ',expr) ,expect ,expr))) (T* (dist 'a) 'a ) (T* (dist '(a)) '(a) ) (T* (dist '(a b)) '((a b)) ) (T* (dist '((a b) c)) '((a b c)) ) (T* (dist '((a b) c d)) '((a b c) (a b d)) ) (T* (dist '((() x y) a b)) '((x a) (x b) (y a) (y b)) ) (T* (dist '(a b d)) '((a b) (a d)) ) (T* (dist '(a b c d e )) '((a b) (a c) (a d) (a e)) ) (T* (dist '(x (() a b d))) '((x a) (x b) (x d)) ) (T* (dist '(() a b d)) '((a) (b) (d)) ) (T* (dist '(() a b c d e )) '((a) (b) (c) (d) (e)) ) (T* (dist '(() a (() b c d e))) '((a) (b) (c) (d) (e)) ) (T* (dist '(a b (c d))) '((a b) (a c d)) ) (T* (dist '(a b (c d e))) '((a b) (a c d) (a c e)) ) (T* (dist '(a b c (d (e f) g h) i))'((a b) (a c) (a d e f) (a d g) (a d h) (a i))) (T* (dist '((a) b)) '((a b)) ) (T* (dist '((a b) c)) '((a b c)) ) (T* (dist '((a b) c d)) '((a b c) (a b d)) ) (T* (dist '((a b c) d)) '((a b d) (a c d)) ) (T* (dist '((a b c) d e)) '((a b d) (a b e) (a c d) (a c e)) ) (T* (dist '(a (b c d))) '((a b c) (a b d)) ) (T* (dist '((a (b c d)) e f)) '((a b c e) (a b c f) (a b d e) (a b d f))) (T* (dist '((x ((a b c) d)) e f)) '((x a b d e) (x a b d f) (x a c d e) (x a c d f))) (T* (dist '((x ((a b c) d)) e)) '((x a b d e) (x a c d e))) (T* (dist '((x (() a b d) (() a c d)) e f)) '((x a e) (x a f) (x b e) (x b f) (x d e) (x d f) (x a e) (x a f) (x c e) (x c f) (x d e) (x d f))) (T* (dist '((x (a b d) (a c d)) e f)) '((x a b e) (x a b f) (x a d e) (x a d f) (x a c e) (x a c f) (x a d e) (x a d f))) (test-end)
- Shiro(2004/04/23 01:53:57 PDT): うーん、スペックをもう少し整理した方が
綺麗に書けるような気もします。cdrがnullの場合とそうでない場合で
意味が違ったり、最初にアトムと1要素のリストの場合だけ特別扱い
したりするのがなんとなくいやん。
(define (dist obj) (define (listify x) (if (list? x) x (list x))) (define (walk obj) (if (pair? obj) (receive (head tails) (car+cdr obj) (cond ((null? tails) (walk head)) ((null? head) (append-map (cut walk <>) tails)) (else (append-map (lambda (h) (map (lambda (t) (append h (listify t))) (append-map (cut walk <>) tails))) (walk head))))) (list (listify obj)))) (if (or (not (pair? obj)) (null? (cdr obj))) obj (walk obj)))
- hira(2004/04/23 08:17:52 PDT): おお、すごく綺麗ですね。ありがとうございます。とても勉強になりました。スペックについては確かに整理がついてないんですよね。書きながら二転三転しています。 そもそもstring->globの{}対応ならcartesian-productをベースに考るべきだったかもしれません・・・というか正規表現の()は入れ子不可能だと勘違いしていたのが大失敗でした。()の入れ子が可能なら{}は文字列の置換で対応できちゃいます。distやcartesian-productするまでも無かったです。 今回の収穫はappend-mapでした。スプライスしながら再帰する技として応用範囲が広そうです。
file-is-symlink?
symlink判定は面倒です。sys-lstatを使うか、file-typeにfollow-link?を指定しないといけないのですが、つい忘れちゃいます。 このAPIもGauche標準で欲しいと思うのですが、どうでしょう。
(define (file-is-symlink? file) (if (file-exists? file) (eq? (ref (sys-lstat file) 'type) 'symlink) #f))
- Shiro(2004/04/17 04:45:56 PDT):そうですね。file.utilに入れときます。
- hira(2004/04/17 05:36:21 PDT):ども。念のため、現在の私のGaucheのバージョンを残しておきます。
$ gosh -V Gauche scheme interpreter, version 0.7.4.2 [sjis]
string->glob
glob文字列を正規表現に変換します。RubyのDir.globを参考にしました。
ここではglobにpathを与える場合、directoryを示すpathの末尾が/で終わることを前提としています。
- 関連するモノ
- GaucheRefj:sys-glob
- glob->regexp foofさんの実装です。こっちの方は{}もサポートしてるっぽいです。(どうして作った後でこれに気づくんだろう。。。)
- Shiro: glob->regexpは一度、regexpのユーティリティとして標準ライブラリ に入れようと思ったのですが、パス名特有の事情(".", ".."の存在)を考慮せねば ならないために純粋な文字列操作にならないことに気づき、止まっています。 file.util中に入れてしまう手はありますね。
ワイルドカードには以下のものがあります。
- * 空文字列を含む任意の文字列と一致します。
- ? 任意の一文字と一致します。
- [ ] Gaucheの正規表現と同じです。
- { } 未サポートです。
- ** Rubyの**と同じです。以下、引用
ワイルドカード */ の0回以上の繰り返しを意味し、ディレクトリを再帰的にたどってマッチを行います。例えば, foo/**/bar は foo/bar, foo/*/bar, foo/*/*/bar ... (以下無限に続く)に対してそれぞれマッチ判定を行います。
- [最終更新] (2004/04/14 23:19:20 PDT)
- [BUGFIX] **/gaucheがhogegaucheにマッチするバグを修正。(2004/04/14 22:55:00 PDT)
- [BUGFIX] glob文字列内に'.', '..'を許していたバグを修正。(2004/04/14 22:55:00 PDT)
- [BUGFIX] **がディレクトリ以外にマッチするバグを修正。(2004/04/14 22:55:00 PDT)
(use srfi-1) (use srfi-13) (define (string->glob s) (define (compile e ans) (cond ((equal? "" e) ans) ((#/^\*\*$/ e) (push! ans "?\\b.*")) ; ** ((#/^\.\.?$/ e) (error "string->glob:illegal glob:'.' or '..': " s)) ; /./ or /../ (else (set! e (regexp-replace-all #/\./ e "\\\\.")) ; . (set! e (regexp-replace-all #/\?/ e "." )) ; ? (set! e (regexp-replace-all #/\*/ e "[^/]*")) ; * (push! ans e)))) (let1 regstr (string-join (reverse (fold compile '() (string-split s #\/))) "/") (set! regstr (regexp-replace #/^\?\\b\.\*\// regstr ".*/?\\\\b")) (set! regstr (regexp-replace #/\?\\b\.\*$/ regstr "?\\\\b.*/")) (if (and (#/^\// s) (not (#/^\// regstr))) (set! regstr (string-append "/" regstr))) (if (and (#/\/$/ s) (not (#/\/$/ regstr))) (set! regstr (string-append regstr "/"))) (string->regexp (string-append "^" regstr "$")))) ;;;;実行例 (use file.util) ;directory-list resolve-path ;;base-dirは正規化される。 ;;base-dirの末尾に/がなかったら/をつける。 ;;pathはbase-dirからの相対パス。先頭に/はつけない。 ;;pathがdirectoryの場合、末尾に/をつけて渡す。 ;;procはbase-dirとpathの2引数を受け取る (define (directory-for-each proc base-dir) (set! base-dir (resolve-path base-dir)) (let loop ((dir base-dir)) (define (down dir) (if (file-is-directory? dir) (loop dir))) (if (not (#/\/$/ base-dir)) (set! base-dir (string-append base-dir "/"))) (let1 ls (directory-list dir :add-path? #t :children? #t) (for-each (lambda (path) (proc base-dir (if (file-is-directory? path) (string-append path "/") path))) ls) (for-each down ls)))) (define (glober . str-ls) (define globs (map string->glob str-ls)) (print globs) (lambda (base-dir path) (set! path (string-drop path (string-length base-dir))) (any (lambda (g) (if (g path) (print "match:" (regexp->string g) ": " path) #f)) globs))) ;;Gaucheのホームディレクトリの場合 (define base-dir "~/project/gauche/gauche0742_org") (directory-for-each (glober "**/*util.scm" "**/*.m4" "**/ext/**/gauche/**" "**/gauche/*" "**/test*/**") base-dir) ;;;;実行結果 #| (#/^.*/?\b[^/]*util\.scm$/ #/^.*/?\b[^/]*\.m4$/ #/^.*/?\bext/?\b.*/gauche/?$/ #/^.*/?\bgauche/[^/]*$/ #/^.*/?\btest[^/]*/?\b.*/$/) match:^.*/?\b[^/]*\.m4$: acinclude.m4 match:^.*/?\b[^/]*\.m4$: aclocal.m4 match:^.*/?\btest[^/]*/?\b.*/$: test/ match:^.*/?\bext/?\b.*/gauche/?\b.*/$: ext/fcntl/gauche/ match:^.*/?\bgauche/[^/]*$: ext/fcntl/gauche/fcntl.h match:^.*/?\bext/?\b.*/gauche/?\b.*/$: ext/termios/gauche/ match:^.*/?\bgauche/[^/]*$: ext/termios/gauche/termios.h match:^.*/?\bext/?\b.*/gauche/?\b.*/$: ext/uvector/gauche/ match:^.*/?\bgauche/[^/]*$: ext/uvector/gauche/uvector.h match:^.*/?\b[^/]*\.m4$: gc/acinclude.m4 match:^.*/?\b[^/]*\.m4$: gc/aclocal.m4 match:^.*/?\b[^/]*\.m4$: gc/libtool.m4 match:^.*/?\btest[^/]*/?\b.*/$: gc/tests/ match:^.*/?\bgauche/[^/]*$: lib/gauche/ match:^.*/?\b[^/]*util\.scm$: lib/file/util.scm ... match:^.*/?\btest[^/]*/?\b.*/$: test/data/locale/ja/ match:^.*/?\btest[^/]*/?\b.*/$: test/data/locale/en/LC_MESSAGES/ match:^.*/?\btest[^/]*/?\b.*/$: test/data/locale/ja/LC_MESSAGES/ |#
dump
試行錯誤しながらコーディングするときに便利なマクロです。 実行例をプリントするときにも便利です。 このページでも使いたくなるときが多々あったのでさらしておきます。
- 関連するモノ
- GaucheRefj:デバッグの#?=
- GaucheRefj:d
- GGCのtrace
- [最終更新] (2004/04/11 20:17:09 PDT)
(define-syntax dump (syntax-rules () ((_ expr ...) (begin (receive mv expr (let ((e (if (null? mv) '**null-mv** (car mv))) (more (if (null? mv) mv (cdr mv)))) (format #t "~s ;=> ~s\n" 'expr e) (for-each (lambda (v) (format #t " ;-> ~s\n" v)) more) (if (null? more) e (apply values (cons e more))))) ...)))) ;;;;実行例 (dump (define (divrem n m) (values (quotient n m) (remainder n m))) (+ 1 2) (sys-ctime (sys-time)) (divrem 13 5)) ;;;;実行結果 (define (divrem n m) (values (quotient n m) (remainder n m))) ;=> divrem (+ 1 2) ;=> 3 (sys-ctime (sys-time)) ;=> "Fri Apr 2 03:02:28 2004\n" (divrem 13 5) ;=> 2 ;-> 3
directory-for-each
parse-opt
Yet Anotherなオプションパーサです。 Gauche標準の2者の短所が私的に致命的だったので書いてみました。
- parse-opt
- 長所
- Rubyのgetoptlong風。
- だいたいgetoptガイドライン準拠。
- 短所
- getoptガイドラインのオプションの並び替えが良く分からないので未実装。
- 長所
- gauche.parseopt
- 長所
- 直観的で書きやすい。
- 型もあわせてくれる。
- 短所
- 可変長引数が扱えない。(grep -e "hoge" -e "fuga" *.scm みたいなことがやりたかった)。
- と思ったら勘違いでした。下記の議論を参照されたし。--hira (2004/04/11 04:08:31 PDT)
- 長所
- srfi-37
- 長所
- サーフィ。
- getoptガイドライン準拠。
- 短所
- 書きにくい。理解できなかった。
- 長所
- 議論
- Shiro (2004/04/11 01:37:31 PDT): gauche.parseoptは、オプションの処理部分に 任意のScheme式が書けるので、引数を変数にpush!するようにすれば 複数回出現するオプションも扱えますよ。マニュアルに例を入れとくと 良かったかも。
- hira: 0..nって出来ます?1..n or 0しか扱えないように思います。1..nにすると0でエラー。0にするとcallbackに引数が来ないと。
- Shiro (2004/04/11 03:31:02 PDT): うーんと、gosh -e hoge -e fuga のような
場合を扱うならこれでいけます。
(define (main args) (let1 e-opts '() (parse-options (cdr args) (("e=s" (opt) (push! e-opts opt)))) (write e-opts)) 0)
あっでも、いわゆる「オプショナルなオプション引数」は確かに書けませんね。 それはgauche.parseoptに追加してもいいかも。 - hira (2004/04/11 04:15:47 PDT): let-args版はこんな感じでしょうか。んー、これで充分だったなぁ。
(use gauche.parseopt) (define (main args) (let-args (cdr args) (;;引数指定が0の場合はxに何も代入されない。 (verbose "v|verbose" #t => (let1 a '() (lambda x (push! a x) a))) ;;引数指定が0でなければ、push!で1..nを扱える。 (outfile "o|outfile=s" #t => (let1 a '() (lambda x (push! a x) a)))) (print "o:" outfile) (print "v:" verbose)))
- [最終更新] (2004/04/10 23:54:15 PDT)
(use srfi-1) (use srfi-13) (define (parse-opt proc spec-malist args) ;;; internal define (define (short-opt? str) (#/^-[^-]/ str)) (define (long-opt? str) (#/^--[^-]/ str)) (define (get-opt-arg opt) (define (get-short-opt-arg str) (let1 match (#/^-[^-]([^ ]*)/ str) (if (or (not (match)) (equal? "" (match 1))) #f (match 1)))) (define (get-long-opt-arg str) (let1 match (#/^--[^-]+=(.*)/ str) (if match (match 1) #f))) (cond ((short-opt? opt) (get-short-opt-arg opt)) ((long-opt? opt) (get-long-opt-arg opt)) (else #f))) (define (opt? str) (eq? #\- (string-ref str 0))) (define (has-next-arg? args) (not (or (null? args) (opt? (car args))))) (define (massoc key mas) (define (member* obj pair) (let loop ((pair pair)) (if (pair? pair) (if (string-prefix? (car pair) obj) pair (loop (cdr pair))) #f))) (find (cut member* key <>) mas)) (define (last-cdr mas) (cdr (last-pair mas))) (define (normalize-opt opt) (string->symbol ((#/^--?(.*)/ opt) 1))) ;;; main (unless (null? args) (let1 a1 (pop! args) (if (not (opt? a1)) (proc :operand a1) (let1 opt-spec (massoc a1 spec-malist) (if (not opt-spec) (proc :unknown-option a1) (let ((arg-spec (last-cdr opt-spec)) (norm-opt (normalize-opt (car opt-spec)))) (case arg-spec ((optional-argument required-argument) (let1 opt-arg (get-opt-arg a1) (set! opt-arg (if opt-arg opt-arg (if (has-next-arg? args) (pop! args) (eq? arg-spec 'optional-argument)))) (if opt-arg (proc norm-opt opt-arg) (proc :miss norm-opt)))) ((no-argument) (proc norm-opt #t) (and (short-opt? a1) (< 2 (string-length a1)) (push! args (format "-~a" (string-drop a1 2))))) (else (error "something wrong:" arg-spec)))))))) (parse-opt proc spec-malist args))) ;;;;実行例 (define spec '(("--list" "-t" . no-argument) ("--extract" "--get" "-x" . no-argument) ("--create" "-c" . no-argument) ("--file" "-f" . required-argument) ("--gzip" "--ungzip" "-z" . no-argument) ("--verbose" "-v" . no-argument) ("--optimize" "-O" . optional-argument) ("--warning" "-W" . optional-argument) ("-V" "--version" . no-argument) )) (define (test-opt opts) (let1 opt '() (parse-opt(lambda (k v) (push! opt (cons k v))) spec opts) (reverse opt))) ;;;;(正常系) (test-opt '("-tvf" "hoge" "-O" "-Wall" "--gzip" "--file=fuga" "--version")) ;=> ((list . #t) ;=> (verbose . #t) ;=> (file . "hoge") ;=> (optimize . #t) ;=> (warning . "all") ;=> (gzip . #t) ;=> (file . "fuga") ;=> (V . #t)) ;;オプション引数でないなら:operand。 ;;知らないオプションなら:unknown-option。 (test-opt '("--list" "hoge.tar" "fuga.txt" "-V" "--pikaso" "tobide" "-H" "bon")) ;=> ((list . #t) ;=> (:operand . "hoge.tar") ;=> (:operand . "fuga.txt") ;=> (V . #t) ;=> (:unknown-option . "--pikaso") ;=> (:operand . "tobide") ;=> (:unknown-option . "-H") ;=> (:operand . "bon")) ;;;;(異常系) ;;引数が足りないので:missが渡される (test-opt '("-f" "-v" "-f")) ;=> ((:miss . file) ;=> (verbose . #t) ;=> (:miss . file)) ;;tarのfzみたいなパースは受け側で工夫する必要がある (test-opt '("-xvfz" "hoge.tar.gz")) ;=> ((extract . #t) ;=> (verbose . #t) ;=> (file . "z") ;=> (:operand . "hoge.tar.gz"))
<range>
RubyのRangeにあたるものです。 GaucheRefj:iotaをrangeの代わりにしてfindやfor-eachするよりも、lazyな動作にできます。 GaucheRefj:コレクションの実装の簡単な例としてどうぞ。
- [最終更新] (2004/04/07 09:31:58 PDT)
- Shiro: このへんからの一連の議論も参考にどうぞ。
- http://sourceforge.net/mailarchive/message.php?msg_id=6248621
- http://sourceforge.net/mailarchive/message.php?msg_id=6264485
- hira: おお、fuyukiさんがもっとスゴイのを実装してましたね。
- このときは結局、rangeを数列としてみなすべきか範囲の集合として
みなすべきかってところで結論が出なかったんでしたっけ。(どっちも便利なことが
あるけれど、セマンティクスが違って来る)。逆にRubyとかでRangeをばりばり
使ってる人に使い勝手を聞いたほうがいいのかな。
- hira: RubyのRangeに不満を持つことは無かったですね。"Ruby"で考えているので。というか、Rubyは思考の誘導がとても上手です。数列か範囲の集合か、というのはどっちもありだと思います。排他的な問題なのでしょうか?
- Shiro: 数列とみなすなら、単なるsuccやstepだけでなく、自由な数列表記を 許したくなります(e.g. フィボナッチ数列とか)。それらを数の集合とみなして 集合演算を行って、その結果を数列とみなしたい…とか言いはじめると、 ちょっと面倒ですね。そもそもそういう用途なら、lazy comprehensionを使った ジェネレータが作れればいいとも言えます。一方、単に範囲の集合とみなして、 与えられたオブジェクトがその範囲に入っているかどうかを調べる、という 用途も考えられます。それだと、ジェネレータでは困りますよね。また、 連続な範囲も対象に入って来ます。
- 結局、「限定されたlazy generator」にしかならないのだったら、新たな クラスを作る意味はないんじゃないか、ってあたりでひっかかってるのかなあ。 うまいぐあいに両方の性格をもたせられたらいいんですけどね。
- hira: 連続の扱いはRubyではinclude?/member?の使い分けで対処してますね。ジェネレータでは困る場合(連続の場合)include?を使っているし、ジェネレータ的な判定はmember?でやってますね。曲線とか、まれな問題に対してはオプショナルな高階関数で対処すればいいと思います。
- 複数の範囲が欲しい時は無い? 1..3 4..6とか
- hira: succに関して言うなら、これはイテレータを内包するイテレータの問題として考えるべきだと思います。1..3 4..6の場合は、複数の有限集合を直列化する方法によるでしょう。他にも複数の無限集合を直列化する方法や無限個の無限集合(無限集合を要素とする無限集合)を直列化する方法など、色々あるでしょう。include/exclude判定については、方法は一つだと思います。
- stepが欲しいときは無い? <- これはlazyなcomprehensionがあればいいだけだが
- hira: Rubyでstepやりたいときは特定のインスタンスのsuccをオーバーライドして実現するのかなぁ。特異メソッドでしたっけ・・・と思ったら、stepは1.7からありますね。
- 連続的な値の集合として扱いたいことはない? [1.0 ... ∞] とか。
- hira: 無限の住人(数学屋)にとって実数のsuccは有り得ないことでしょうね。ただ、プログラマがやりたいことはstep単位が0.1とか0.01なlazy-iotaでしょう。これも一般解は無いので、デフォルトはエラーでsuccが渡されたらそれを使えばいいと思います。
- あと、'...' をメソッド名に使うと、それを生成するR5RSマクロが書けなくなるので
注意。まあ、srfi-46で可能になりますが。
- hira: これは迂闊でした。他の書き方を考えてた方がよさげですね。
- hira: succの引数は(here . to) として、toをオプショナルにしたいと思いました。これだとモニタの点から点へのsuccにブレゼンハムできるし、MLでfuyukiさんも提案していましたがmin,maxではなくhere . toと-inf,+infのほうが使いやすいと思います。excludeを陽に示せなくなりますが、notと組み合わせればよいでしょう。
- hira: 線上の次点を示すにはhere, toとfromも必要でした。ここでの線とは、有限個の点の集合です。
(.. 30 1) ;30 29 28 ... 1 (.. 1 +inf) ; 1 2 3 ... ∞ (.. +inf -inf) ;startオプションがなければsucc出来ない。startから-infへ。 ;from toの位置が入れ替わってもinclude/exclude判定結果は一緒
※Rubyは(.. 30 1)をイテレートしない。比較演算とsuccを書き換えなきゃ下降できないのかしら。
- hira: 線上の次点を示すにはhere, toとfromも必要でした。ここでの線とは、有限個の点の集合です。
(use gauche.collection) (define-class <range-meta> (<class>) ()) (define-class <range> (<collection>) ((first :init-keyword :first) (last :init-keyword :last) (op :init-keyword :op)) :metaclass <range-meta>) (define-method call-with-iterator ((self <range>) proc . options) (let ((cur (ref self 'first)) (last (ref self 'last )) (op (ref self 'op ))) (define (end?) (op last cur)) (define (next) (begin0 cur (inc! cur))) ;; :startオプションは未実装 (proc end? next))) (define-method .. (first last) (make <range> :first first :last last :op < )) (define-method ... (first last) (make <range> :first first :last last :op <=)) ;;実行例 gosh> (for-each (cut print "[" <> "]") (... 3 5)) [3] [4] #<undef> gosh> (for-each (cut print "<" <> ">") (.. 3 5)) <3> <4> <5> #<undef> gosh> (find (lambda (x) (print "(" x ")") (= x 6)) (... 1 10)) (1) (2) (3) (4) (5) (6) 6
汎用slot操作集
よくありそうなslot操作集です。
同じ事を実現するのにrefと既存のマクロを組み合わせる方法もありますが、より柔軟さがほしいと思ったのでこれを作ってみました。
- 機能
- object->slots: オブジェクトの全スロット名リストを返します
- slot->list, slot->alist: 指定のスロットをlist,alistとして取得します
- list->slot, alist->slot: list,alistから指定のスロットへ代入します
- copy-slot
- slot-update!
- slot-inc!, slot-dec!
- [最終更新] (2004/04/12 23:49:13 PDT)
- [BUGFIX] slot->alistを修正。(2004/04/12 23:49:13 PDT)
(use srfi-1) ;zip ;;{object->slots} ;;{{{ (define-method object->slots (object) (map car (class-slots (class-of object)))) (define (%list->slots src ls) (if (null? ls) (object->slots src) ls)) ;;}}} ;;{slot->[list|alist]} ;;primitive: slot->list (self (slots <list>)) ;;{{{ (define-method slot->list (self (slots <list>)) (map (lambda (slot) (slot-ref self slot) ) (%list->slots self slots))) (define-method slot->list (self . slots) (slot->list self slots)) (define-method slot->alist (self (slots <list>)) (let1 slots (%list->slots self slots) (map cons slots (slot->list self slots)))) (define-method slot->alist (self . slots) (slot->alist self slots)) ;;}}} ;;{[list|alist]->slot} ;;primitive: list->slot (self slot val . more) ;;{{{ (define-method list->slot (self slot val . more) (slot-set! self slot val) (if (null? more) self (apply list->slot self more))) (define-method list->slot (self (ls <list>)) (apply list->slot self ls)) (define-method alist->slot (self . alist) (alist->slot self alist)) (define-method alist->slot (self (alist <list>)) (for-each (lambda (slot) (list->slot self (car slot) (cdr slot))) alist) self) ;;}}} ;;{copy-slot} ;;{{{ (define-method copy-slot (src dst (slots <list>)) (define (copy slot) (slot-set! dst slot (slot-ref src slot))) (for-each copy (%list->slots src slots)) dst) (define-method copy-slot (src dst . slots) (copy-slot src dst slots)) ;;}}} ;;{slot-[update|inc|dec]!} ;;{make-slot-update!} ;;primitive: slot-update! (self slots proc (args <list>)) ;;{{{ (define-method slot-update! (self slots proc (args <list>)) (define %slot-set! (with-module gauche slot-set!)) (define (update slot) (%slot-set! self slot (apply proc (slot-ref self slot) args))) (if (list? slots) (for-each update slots) ( update slots)) self) (define-method slot-update! (self slots proc . args) (slot-update! self slots proc args)) (define-macro (make-slot-update! name class proc default) `(define-method ,name ((self ,class) slots . args) (slot-update! self slots ,proc (if (null? args) ,default args)))) (make-slot-update! slot-inc! <top> + 1) (make-slot-update! slot-dec! <top> - 1) ;;}}} ; vim:set nowrap ts=2 sts=2 sw=2 tw=0 et foldmethod=marker:
カレンダー (<date>拡張)
<date>のスロット更新と同時に正規化(time-utc->date (date->time-utc self)しようという拡張です。
- [最終更新] (2004/04/06 05:12:29 PDT)
- [TODO] <date>のアクセサをフックする。
- Shiro: <sys-tm>の利点はPOSIX互換性なんですが、 2038年以降も扱うなら、最初からsrfi-19を使った方がいいかもしれません。
- hira: <date>のドキュメントを読んでもピンとこなかったのでPOSIXの方を使っていました。改めて<date>を読んでみると、こっちの方が良さげですね。slot操作集とあわせて書き換えてみました。CLOSのスロットアクセスオーバーライドがいまいちよく分からず自作のものを使ってます。(2004/04/06 05:12:29 PDT)
;;slot-update! list->slot copy-slotはslot操作集を参照 (use srfi-19) (define (normalize-date! date) (copy-slot (time-utc->date (date->time-utc date)) date)) (define-method slot-update! ((self <date>) slots proc args) (next-method self slots proc args) (normalize-date! self)) (define-method list->slot ((self <date>) slot val . more) (apply next-method self slot val more) (normalize-date! self)) ;;;実行例 (define date (current-date)) ;=> date (slot-inc! date 'day 1 1 1) ;=> #<date 2004/04/09 20:57:44.636375000 (32400)> (slot-dec! date 'hour 1000) ;=> #<date 2004/02/28 04:57:44.636375000 (32400)> (list->slot date 'year 2003 'month 1 'day 365) ;=> #<date 2003/12/31 04:57:44.636375000 (32400)> (alist->slot date '((year . 2003) (month . 1) (day . 100))) ;=> #<date 2003/04/10 04:57:44.636375000 (32400)> (slot->list date '(zone-offset year month day hour minute second nanosecond)) ;=> (32400 2003 4 10 4 57 44 636375000)
- [NOTE] <sys-tm>を直に編集した場合、不正な値になることがあります。不正な値の場合、strftimeで落ちます。これは<sys-tm>のtipsですね。以下はログです。
- hira: 原因不明のコアダンプが発生しておりますが、Cygwinだからかもしれません。
- Shiro: <sys-tm>オブジェクトはunixのstruct tmそのものなので、 下位にあるlibcがサポートしていない値をセットした場合の動作はlibcに 依存します。多分このケースでは、strftime(3)で文字列に直す時に 月名のアレイの境界を越えてアクセスしているんじゃないでしょうか。
- hira: ビンゴでした。slot-set!してからstrftime(3)したら同様に落ちたのでこれが原因でしょう。
(slot-set! today 'year 104) ;=> #<undef> (slot-set! today 'mon 12) ;=> #<undef> (slot-set! today 'mday 100) ;=> #<undef> (sys-strftime "%c" today) ;=> Segmentation fault (core dumped)
pretty-expand
マクロを読み易く展開する関数です。
- [最終更新] (2004/04/04 11:30:15 PDT)
- [BUGFIX] macroexpandがatomを返したとき、mapでエラーになるバグを修正しました。--hira(2004/03/29 00:13:49 PST)
- [BUG] マクロの展開途中に (let ((hoge fuge)) ...)が出てきたとして、'hoge'というマクロが定義されている場合、hogeが展開されてしまいます。--hira (Shiroさんからのご指摘) (2004/03/29 01:19:52 PST)
- [FIX] letとlambdaの変数束縛に対応しました。
- [FIX] defineに対応しました。あと何があるだろう・・・
- [FIX] let*,letrec,and-let*に対応しました。
- [FIX] doに対応しました。
- [FIX] receiveに対応しました。(2004/04/04 11:30:15 PDT)
- これで全部かなぁと思ってます。うまく展開できない構文があったらお知らせください。
- quoteの中身が展開されてしまいます。--teranishi
- [BUG] マクロが遮蔽されていても展開してしまいます。高階関数を展開するときは注意して下さい。--hira (2004/04/02 03:35:21 PST)
- [FIX] 対応しました。--hira(2004/04/03 06:22:57 PST)
- [FIX] (arg . rest)形式のformalsでマクロの遮蔽が展開されていたバグを修正しました。(2004/04/04 11:30:15 PDT)
- 内部defineによる遮蔽が効きません。--teranishi
- [TODO] マクロ内で割り当てられた変数はid->symbolせずにgensymする。それによって展開後のマクロをコピペで実行できるようにする。
- マクロ内の変数のみでは不十分です。(let ((set! list)) (push! x 1))等。--teranishi
(use srfi-1) (define (pretty-expand macro) (define stack '()) (define (closer expander proc args) (dynamic-wind (lambda () (push! stack '())) (lambda () (expander proc args)) (lambda () (pop! stack)))) (define (bind var) (push! (car stack) var) var) (define (expand-lambda proc x) `(,proc ,(bind (car x)) ,@(map id->symbol (cdr x)))) (define (clause c) (if (null? c) c (let1 h (car c) `((,(bind (car h)) ,@(map id->symbol (cdr h))) ,@(clause (cdr c)))))) (define (expand-let proc x) (if (list? (car x)) `(,proc ,(clause (car x)) ,@(map id->symbol (cdr x))) `(,proc ,(bind (car x)) ,(clause (cadr x)) ,@(map id->symbol (cddr x))))) (define (expand-do proc x) `(,proc ,(clause (car x)) ,@(map id->symbol (cdr x)))) (define (expand-ls proc args) (if (identifier? proc) (set! proc (identifier->symbol proc))) (case proc ((lambda define receive) (closer expand-lambda proc args)) ((let let* letrec and-let*) (closer expand-let proc args)) ((do) (closer expand-do proc args)) (else (map id->symbol (cons proc args))))) (define (expand m) (define (make-eqx x) (define (eqx y) (cond ((list? y) (find eqx y)) ((pair? y) (or (eq? x (car y)) (eq? x (cdr y)))) (else (eq? x y)))) eqx) (unless (and (not (null? m)) (list? m) (find (make-eqx (car m)) stack)) (set! m (macroexpand m))) (if (or (null? m) (not (list? m))) m (expand-ls (car m) (cdr m)))) (define (id->symbol a) (cond ((identifier? a) (identifier->symbol a)) ((list? a) (expand a)) (else a))) (expand macro)) ;;;実行例 gosh> (pretty-expand '(push! a '(a b))) (set! a (cons (quote (a b)) a)) gosh> (pretty-expand '(pop! a)) (let ((val a)) (set! a (cdr val)) (car val)) ;;;実行例(中置記法の四則演算マクロ) gosh> (pretty-expand '(c 1 + 1 + 2 ^ 3 / 2 * 4 ^ 2 - 2 ^ 3)) (- (+ (+ 1 1) (* (/ (^^ 2 3) 2) (^^ 4 2))) (^^ 2 3)) gosh> (pretty-expand '(c 2 ^ 3 ^ 4 - 2 ^ 3)) (- (^^ 2 (^^ 3 4)) (^^ 2 3)) gosh> (pretty-expand '(c 2 ^ (3 ^ 4) - 2 ^ 3)) (- (^^ 2 (^ 3 4)) (^^ 2 3)) gosh> (pretty-expand '(c (2 ^ 3) ^ 4 - 2 ^ 3)) (- (^^ (^ 2 3) 4) (^^ 2 3)) ;;;;実行例 (束縛を展開しないよう修正) (define-syntax dont (syntax-rules () ((_ expr ...) (list "NG" expr ...)))) (define-syntax doit (syntax-rules () ((_ expr ...) (list "OK" expr ...)))) gosh> (pretty-expand '(lambda (dont a b) (doit c) (doit a) (+ 1 2))) (lambda (dont a b) (list "OK" c) (list "OK" a) (+ 1 2)) gosh> (pretty-expand '(let dont ((dont (doit 1)) (a (doit 2))) (doit))) (let dont ((dont (list "OK" 1)) (a (list "OK" 2))) (list "OK")) gosh>(pretty-expand '(let ((dont (doit 1)) (a (doit 2))) (doit))) (let ((dont (list "OK" 1)) (a (list "OK" 2))) (list "OK")) gosh> (pretty-expand '(let1 dont (a 2) (doit))) (let ((dont (a 2))) (list "OK")) gosh> (pretty-expand '(let ((dont +)) (list dont))) (let ((dont +)) (list dont)) ;;;;マクロの遮蔽対応 (pretty-expand '(let1 a 1 (let1 dont + (let1 doit dont (doit 1 2 3) (dont 1 2 3)) (doit 1 2)) (let ((dont 1)) (doit 1 2)) (doit 1 2))) => (let ((a 1)) (let ((dont +)) (let ((doit dont)) (doit 1 2 3) (dont 1 2 3)) (list "OK" 1 2)) (let ((dont 1)) (list "OK" 1 2)) (list "OK" 1 2))
中置記法の四則演算マクロ
こんなん作ってみました。なんか面白かったのでupしときます。 バグってたらツッコミ入れてやって下さい。
- [最終更新] (2004/03/28 06:21:32 PST)
- ^を追加しました。--hira (2004/03/27 22:21:40 PST)
- [BUGFIX] ^の2つ先読みルールを追加しました。--hira (2004/03/28 03:22:21 PST)
- 面白いっすね。ところで関数^はexptじゃだめなのかしらん。--Shiro
- ぐはっ。R5RSレベルでサポートされてましたね。反映しておきました。--hira (2004/03/28 04:13:42 PST)
- [BUG] (c 2 ^ 2 ^ 2 ^ 2 ^ 2 ^ 2)みたいな^が扱えていない。右結合のルールはどう書けばいいのだろう。--hira(2004/03/28 04:42:33 PST)
- [FIX] 右結合対応。これで良いと思うのだけど、どうでしょ。--hira(2004/03/28 06:21:32 PST)
- %を追加しました。--hira(2004/03/28 06:21:32 PST)
(define-syntax pp (syntax-rules () ((_ msg expr) (begin (print msg ":" 'expr ) expr)))) ;(define-syntax pp (syntax-rules () ((_ msg expr) expr))) (define ^ expt) (define ^^ expt) (define % modulo) (define-syntax c (syntax-rules (+ * - / ^ % ^^) ((c v) (pp " __" v)) ((c (pl ^^ pr) ^ r ) (pp "r ^" (c pl ^ (pr ^^ r))) ) ((c (pl ^^ pr) ^^ r ) (pp "r^^" (c pl ^^ (pr ^^ r))) ) ((c (lexpr ...) proc (rexpr ...)) (pp " LL" (proc (c lexpr ...) (c rexpr ...))) ) ((c (lexpr ...) proc r ) (pp " LA" (proc (c lexpr ...) r )) ) ((c l proc (rexpr ...)) (pp " AL" (proc l (c rexpr ...))) ) ((c l proc r ) (pp " AA" (proc l r )) ) ((c l ^ r rest ... ) (pp " ^" (c (l ^^ r) rest ... )) ) ((c l o m ^ r rest ... ) (pp " o^" (c l o (m ^^ r) rest ... )) ) ((c l p n o m ^ r rest ... ) (pp "oo^" (c l p n o (m ^^ r) rest ... )) ) ((c l * r rest ... ) (pp " *" (c (l * r) rest ... )) ) ((c l / r rest ... ) (pp " /" (c (l / r) rest ... )) ) ((c l % r rest ... ) (pp " %" (c (l % r) rest ... )) ) ((c l o m * r rest ... ) (pp " o*" (c l o (m * r) rest ... )) ) ((c l o m / r rest ... ) (pp " o/" (c l o (m / r) rest ... )) ) ((c l o m % r rest ... ) (pp " o%" (c l o (m % r) rest ... )) ) ((c l + r rest ... ) (pp " +" (c (l + r) rest ... )) ) ((c l - r rest ... ) (pp " -" (c (l - r) rest ... )) ) )) ;;;実行例 gosh> (c 1 + 1 + 2 ^ 3 / 2 * 4 ^ 2 - 2 ^ 3) oo^:(c 1 + 1 + (2 ^^ 3) / 2 * 4 ^ 2 - 2 ^ 3) +:(c (1 + 1) + (2 ^^ 3) / 2 * 4 ^ 2 - 2 ^ 3) o/:(c (1 + 1) + ((2 ^^ 3) / 2) * 4 ^ 2 - 2 ^ 3) oo^:(c (1 + 1) + ((2 ^^ 3) / 2) * (4 ^^ 2) - 2 ^ 3) o*:(c (1 + 1) + (((2 ^^ 3) / 2) * (4 ^^ 2)) - 2 ^ 3) oo^:(c (1 + 1) + (((2 ^^ 3) / 2) * (4 ^^ 2)) - (2 ^^ 3)) +:(c ((1 + 1) + (((2 ^^ 3) / 2) * (4 ^^ 2))) - (2 ^^ 3)) LL:(- (c (1 + 1) + (((2 ^^ 3) / 2) * (4 ^^ 2))) (c 2 ^^ 3)) LL:(+ (c 1 + 1) (c ((2 ^^ 3) / 2) * (4 ^^ 2))) AA:(+ 1 1) LL:(* (c (2 ^^ 3) / 2) (c 4 ^^ 2)) LA:(/ (c 2 ^^ 3) 2) AA:(^^ 2 3) AA:(^^ 4 2) AA:(^^ 2 3) 58 ;;;実行例(^の右結合対応) gosh> (c 2 ^ 3 ^ 4 - 2 ^ 3) ^:(c (2 ^^ 3) ^ 4 - 2 ^ 3) ^:(c ((2 ^^ 3) ^^ 4) - 2 ^ 3) o^:(c ((2 ^^ 3) ^^ 4) - (2 ^^ 3)) LL:(- (c (2 ^^ 3) ^^ 4) (c 2 ^^ 3)) r^^:(c 2 ^^ (3 ^^ 4)) AL:(^^ 2 (c 3 ^^ 4)) AA:(^^ 3 4) AA:(^^ 2 3) 2417851639229258349412344 gosh> (c 2 ^ (3 ^ 4) - 2 ^ 3) ^:(c (2 ^^ (3 ^ 4)) - 2 ^ 3) o^:(c (2 ^^ (3 ^ 4)) - (2 ^^ 3)) LL:(- (c 2 ^^ (3 ^ 4)) (c 2 ^^ 3)) AL:(^^ 2 (c 3 ^ 4)) AA:(^ 3 4) AA:(^^ 2 3) 2417851639229258349412344 gosh> (c (2 ^ 3) ^ 4 - 2 ^ 3) ^:(c ((2 ^ 3) ^^ 4) - 2 ^ 3) o^:(c ((2 ^ 3) ^^ 4) - (2 ^^ 3)) LL:(- (c (2 ^ 3) ^^ 4) (c 2 ^^ 3)) LA:(^^ (c 2 ^ 3) 4) AA:(^ 2 3) AA:(^^ 2 3) 4088
code rio