作ったモノ。
再発明してるかもしれません。 同様のものや類似品などありましたら、どんどん参照を張って下さい。
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) カーは１でなきゃイヤン。 a = ,a)
*** ERROR: Assertion Failed: (|カーは１でなきゃイヤン。| 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]
パターンにマッチしたら#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))))
いや、いっそエラーにすべきか。こんなパターン、タイポとしか思えないし・・・。
(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)
(any (lambda (x) (and (= 2 x) (* 10 x))) '(1 2 3)) => 20
気がついたらこんなコードを大量に書いていました。
(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)
...)
(match-let1 (foo bar buz)
(proc args)
...)
って手もありますね。どっちが速いだろう。
;(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.000letnのほうが倍くらい速いみたいです。
;(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
木の整形出力です。文字列連結しまくりで遅そうですが、util.matchで遊べたし、どうせ開発支援用途だし、遅くてもいいかなーと諦めております。
※リファクタリングしてたらmatchの必要性が無いことに気付いてしまった。tree?はevery版にすげ替え。
(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/"
木に対するアクセスってみんなどうしてるんだろうか。
(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への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")
(use srfi-1) (define (regmatch->list regmatch) (filter-map regmatch (iota (rxmatch-num-matches regmatch))))
たったこれだけ。正規表現最高ですな。
(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"
＃これが出来ないとしたら、とんでもない飢餓感に見舞われるんじゃないかしら。
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ありだったのか。てっきり文法エラーになると思い込んでいました。
#|
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
Usually use if, which binds it: (if (a x) (car it))
こんな風にsiteとintitleで範囲を限定すると良い感じで検索できます。Googleって素晴らしいですね。
string->globの{}サポートに使う予定のモノです。 直感的に「分配法則だ」と思ったのでそう呼んでますが、正しいかどうかは自信無いです。 ちなみに、今まで作ったモノの中で一番難産しました。 こういうリスト処理でつまずくと「俺って根本的にアホなんじゃないか」と思えてくるから危険です。 もっと単純な解などありましたら、ここに貼っちゃって下さい。
(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)
(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)))
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))
$ gosh -V Gauche scheme interpreter, version 0.7.4.2 [sjis]
glob文字列を正規表現に変換します。RubyのDir.globを参考にしました。
ここではglobにpathを与える場合、directoryを示すpathの末尾が/で終わることを前提としています。
ワイルドカードには以下のものがあります。
ワイルドカード */ の0回以上の繰り返しを意味し、ディレクトリを再帰的にたどってマッチを行います。例えば, foo/**/bar は foo/bar, foo/*/bar, foo/*/*/bar ... (以下無限に続く)に対してそれぞれマッチ判定を行います。
(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/
|#
試行錯誤しながらコーディングするときに便利なマクロです。 実行例をプリントするときにも便利です。 このページでも使いたくなるときが多々あったのでさらしておきます。
(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
Yet Anotherなオプションパーサです。 Gauche標準の2者の短所が私的に致命的だったので書いてみました。
(define (main args)
(let1 e-opts '()
(parse-options (cdr args)
(("e=s" (opt) (push! e-opts opt))))
(write e-opts))
0)
あっでも、いわゆる「オプショナルなオプション引数」は確かに書けませんね。
それはgauche.parseoptに追加してもいいかも。
(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)))
(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"))
RubyのRangeにあたるものです。 GaucheRefj:iotaをrangeの代わりにしてfindやfor-eachするよりも、lazyな動作にできます。 GaucheRefj:コレクションの実装の簡単な例としてどうぞ。
(.. 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を書き換えなきゃ下降できないのかしら。
(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操作集です。
同じ事を実現するのにrefと既存のマクロを組み合わせる方法もありますが、より柔軟さがほしいと思ったのでこれを作ってみました。
(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>のスロット更新と同時に正規化(time-utc->date (date->time-utc self)しようという拡張です。
;;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)
(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)
マクロを読み易く展開する関数です。
(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しときます。 バグってたらツッコミ入れてやって下さい。
(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