hira:作ったモノ

hira:作ったモノ

作ったモノ。

再発明してるかもしれません。 同様のものや類似品などありましたら、どんどん参照を張って下さい。

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

  1. findのpredで非偽を返したらその値をそのまま戻り値としたかった
  2. call/cc抜きで実装しようとすると、多値の扱いが面倒だった(無駄が多そうでいや)
  3. ていうかrubyのforみたいな構文があればいいのでは
  4. rubyのforはreceive風だから、名前はreceive-*-forとしよう
  5. return, nextは予約語にしたいからdefine-macroで実装(returnはrubyの引数付きbreak)
  6. undefの扱いが面倒だから、body部の戻り値は無視
  7. 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)
    

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)
     ...)

print-tree

木の整形出力です。文字列連結しまくりで遅そうですが、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/"

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")

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"

#これが出来ないとしたら、とんでもない飢餓感に見舞われるんじゃないかしら。

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ありだったのか。てっきり文法エラーになると思い込んでいました。

#|
    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

「Gauche リファレンスマニュアル」をググる

こんな風に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)

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))

string->glob

glob文字列を正規表現に変換します。RubyのDir.globを参考にしました。

ここではglobにpathを与える場合、directoryを示すpathの末尾が/で終わることを前提としています。

ワイルドカードには以下のものがあります。

(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

試行錯誤しながらコーディングするときに便利なマクロです。 実行例をプリントするときにも便利です。 このページでも使いたくなるときが多々あったのでさらしておきます。

(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

Gauche:ディレクトリを再帰的に処理

parse-opt

Yet Anotherなオプションパーサです。 Gauche標準の2者の短所が私的に致命的だったので書いてみました。

(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:コレクションの実装の簡単な例としてどうぞ。

(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と既存のマクロを組み合わせる方法もありますが、より柔軟さがほしいと思ったのでこれを作ってみました。

(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)しようという拡張です。

;;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)

pretty-expand

マクロを読み易く展開する関数です。

(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
More ...