Gauche:モジュールの列挙

yamasushi(2013/04/19 09:23:41 UTC)モジュールを列挙して、exportやclassの列を生成してみます。

• 2013/04/19 09:23:41 UTC Gauche:遅延globから移動。
  
• yamasushi(2013/04/23 22:12:46 UTC) この成果とGauche:マニュアルにアクセスをつかいドキュメントの有無をチェックします。→Gauche:ドキュメントがあるかどうか調べる
  

• モジュールの列挙
• exportの列挙
• クラスの列挙
• applicableの列挙

モジュールの列挙

ライブラリアクセスのための関数library-for-eachのパタンには"**"を指定できないので、全モジュールを列挙するには不便です。そこで、Gauche:遅延globを使い列挙します。

; 下記サイトを参考にした
; Vim+Gaucheでの作業環境の設定 - 再帰の反復
; http://d.hatena.ne.jp/lemniscus/20100308/1268022750
; > Gauche用の補完語ファイルを作るには上の参照先にある
; > http://www.katch.ne.jp/~leque/software/misc/mk_gosh_completions
; > を使えばよいのだけど
; > * gauche.matrix(gauhce.arrayからautoloadされている)を読んだところでエラーが出た。
; > * obsoleteなモジュールを読み込んで注意される。
; > * モジュールを読み込まなくても使える基本的な関数が補完語に含まれない。
; > だったので、いくらか変更した。

; TODO autoloadなファイルを指定できないか？
; TODO コアに組み込まれたのちに互換性のために設けられたモジュールの識別?(util.listなど)
; TODO autoloadの関係を調べる処理？ module間の依存関係。

(define-module gauche-modules
  (use gauche.parameter)
  (use srfi-1)
  (use srfi-13)
  (use file.util)
  (use text.tr)
  (use gauche.generator)
  (use gauche.lazy)
  (use gauche.dictionary)
  (use util.match)
  ;
  (use komono-dict) ; 辞書小物
  (use komono-glob)
  (use komono-combinator)
  (export
    predefined?
    predefined-modules obsoleted-modules
    exclude-path-prefixes
    library-modules-generator library-modules-lseq
    gauche-library-generator gauche-library-lseq gauche-library-for-each
    gauche-modules-generator gauche-modules-lseq gauche-modules-for-each
    predefined-modules-generator predefined-modules-lseq
    module-source
    lazy-gauche-modules
    *lazy-modules-table*
  )
)
(select-module gauche-modules)

(define exclude-path-prefixes (make-parameter '("~/gauche")))

(define predefined-modules (make-parameter '(null scheme gauche)))
(define obsoleted-modules  (make-parameter '(gauche.let-opt gauche.validator gauche.singleton)))

;オブジェクトがpredefindかどうか
; TODO util.listのcond-listのようにmacroで再定義しているケースに対応できていない
(define-method predefined? ( (sym <symbol>) obj)
  (let/cc cont
    (for-each
      (^m ;#?=m
        (let1 mod (find-module m)
          (dict-for-each (module-table mod)
            (^[k _ ]
              (and-let* [ [_ (eq? k sym) ]
                          [v (global-variable-ref mod k #f)]
                          [_ (eq? obj v) ] ] (cont #t) ) ) ) ) )
    (predefined-modules) )
    #f ) )

; ここで使う、(modsym . path)にpredefinedもあわせる
(define (predefined-modules-generator)
  ($ x->generator $ map (cut cons <> #f) (predefined-modules) ) )
(define (predefined-modules-lseq)
  ($ x->lseq $ map (cut cons <> #f) (predefined-modules) ) )

; ( name . moduleのパス ) のジェネレータ
; name : ファイルがモジュールを定義していればsymbolにする。
; そうでなければ、文字列 "hoge/foo"のようなまま。
(define (gauche-library-generator)
  (let [[exclude-path-prefixes
            (map (cut sys-normalize-pathname <> :expand #t) (exclude-path-prefixes) ) ]]
    ($ gmap
        (^x (match x
              [ (file . path)
                (if-let1 v (and-let* [[modsym  (path->module-name file)]
                                      [_       (library-has-module? path modsym)] ]
                                    `(,modsym . ,path) )
                  v x ) ] ) )
    $ gconcatenate
    $ gmap
        (^p
          (let1 rxp ($ string->regexp $ format #f "^~a\\/(.*)\\.sc[mi]$" $ regexp-quote p)
            ($ gmap (^s (cons ((rxp s) 1 ) s ) )
              $ gappend
                ($ glob-generator $ build-path p "**" "*.scm")
                ($ glob-generator $ build-path p "**" "*.sci") ) ) )
    $ x->generator
    $ filter
        (^p
          (and (absolute-path? p)
              (not (any (cut string-prefix? <> p) exclude-path-prefixes) ) ) )
        *load-path*)) )

(define (gauche-library-lseq) ($ generator->lseq $ gauche-library-generator ))

; predefined以外のライブラリモジュール
(define (library-modules-generator :optional (exclude-modules '() ) )
  (let1 exclude (append (obsoleted-modules) exclude-modules )
    ($ gfilter
        (every-pred
          ($ symbol? $ car $)
          ($ not $ (cut memq <> exclude ) $ car $) )
    $ gauche-library-generator) ) )

(define (library-modules-lseq . rest)
  ($ generator->lseq $ apply library-modules-generator rest ) )

; predefined + libararyモジュール
(define (gauche-modules-generator . rest )
  (gappend
    (predefined-modules-generator)
    (apply library-modules-generator rest ) ) )

(define (gauche-modules-lseq . rest) ($ generator->lseq $ apply gauche-modules-generator rest ))

; (proc sym path) .... sym : モジュール名のシンボル , path : モジュールのパス
(define (gauche-modules-for-each proc . rest)
  (generator-for-each
    (match-lambda [(modsym . path) (proc modsym path )])
    (apply gauche-modules-generator rest) ) )

(define (gauche-library-for-each proc )
  (generator-for-each
    (match-lambda [(modname . path) (proc modname path )])
    (gauche-library-generator) ) )

; モジュール・ソース対応表
; TODO load順にしたがって1:1になるようにすること。
;
; *lazy-module-table*を参照してロード元を取得
(define-method module-source ( (modsym <symbol>) )
  (dict-get (force *lazy-modules-table*) (symbol->string modsym) #f ) )

(define-method module-source ( (mod <module>) )
  (module-source (module-name mod) ) )

(define-method module-source ( (rx <regexp>) )
  ($ sort!
  $ filter-map (cut dict-get (force *lazy-modules-table*) <> #f)
  $ filter rx $ force lazy-gauche-modules) )

; モジュールは文字列でもつ。
; tree-mapにしておく。(整列される)
(define *lazy-modules-table*
  (lazy-dict
    (make-tree-map string=? string<?)
    (^t
      (gauche-modules-for-each
        (^ (modsym path)
          (let1 modstr (symbol->string modsym)
            (unless (dict-exists? t modstr)
              (dict-put! t modstr path) ) ) ) ) ) ) )

; 全モジュールのリスト
(define lazy-gauche-modules
  (delay
    ($ dict-keys $ force *lazy-modules-table*) ) )

;(gauche-library-for-each ($ format #t "<<< ~s ~s>>>\n" $*) )
;(gauche-modules-for-each ($ format #t "<<< ~s ~s>>>\n" $*) )
;(print (force lazy-gauche-modules))
;(for-each print (library-modules-lseq))

• Shiro(2013/04/23 04:49:51 UTC): library-foldが使えないのは ** によるマッチが効かないからですか? それならこの際入れてしまおうかな。
  
• yamasushi(2013/04/23 07:08:26 UTC)そうです。試しにglobでやってみたというわけです。
  

exportの列挙

(define-module gauche-exports
  (use gauche.parameter)
  (use srfi-1)
  (use util.match)
  (use gauche.lazy)
  (use gauche.dictionary)
  ;
  (use pretty-print)
  (use komono-combinator)
  (use gauche-modules)
  (export
      ; predefinedに登録ずみのオブジェクトを持つモジュール
      ; (maybe autoload)
      default-library-modules
      ; predefinedでないモジュールの、predefinedに登録ずみのオブジェクト
      ; (maybe autoload)
      default-library-objects-lseq

      ; predefinedに登録されていないオブジェクトを持つモジュール
      library-modules
      ; predefinedでないモジュールの、predefinedに登録されていないオブジェクト
      library-objects-lseq

      ; predefinedのオブジェクト
      predefined-objects-lseq

      gauche-export-less-modules
      exclude-modules
      gauche-exports
      predefined-objects-lseq
      gauche-module&export-lseq
      gauche-module&object-lseq
      ;
      whereis
      ) )
(select-module gauche-exports)

; TODO コアに組み込まれたのちに互換性のために設けられたモジュールの識別?(util.listなど)

; 下記サイトを参考にした
; Vim+Gaucheでの作業環境の設定 - 再帰の反復
; http://d.hatena.ne.jp/lemniscus/20100308/1268022750

;Gauche:モジュールの列挙 http://practical-scheme.net/wiliki/wiliki.cgi?Gauche%3a%e3%83%a2%e3%82%b8%e3%83%a5%e3%83%bc%e3%83%ab%e3%81%ae%e5%88%97%e6%8c%99
; Shiro(2013/04/24 01:25:46 UTC): with-moduleおよび、evalに(interaction-environment)
; を指定することで特定のモジュールに読み込ませているようですが、多分意図どおりに動いていないと思います。
;
; (1) with-moduleは「コンパイル時のモジュール」を指定するもので、実行時のモジュールがどうなっているかは関係ありません。
;     evalは実行時に働きます。
;
; (2) interaction-environmentは無条件でuserモジュールを返すので、(eval '(require foo) (interaction-environment))
;     は現在のモジュールとか関係なしに、userモジュールで(require foo)を実行します。
;     つまりuserモジュールにfooが読み込まれることになります。
;
; sandboxとしてモジュールを使いたいなら、実行時に無名のモジュールを作ってそれをevalの第二引数に渡します。
; with-moduleは不要です。
;
; ただ、requireの動作 (一度ロードしたモジュールはロードしないようにする) がどうしても必要なのでなければ、
; evalとrequireを使うのではなくloadを使った方がいいんじゃないかと思います。
; evalが本当に必要な場面って少ないです。
; evalを使いたくなったら、一旦他の方法がないかどうか考えてみると良いと思います。

(define exclude-modules
  (make-parameter
    '(
      gl
      gl.glut
      gl.math3d
      gl.simple-image
      gl.simple.image
      gl.simple.viewer
      graphics.gd
      ) ) )

(define %symbol-list-sort! (cut sort! <>
        (^[x y]
            (string<?
              ($ symbol->string x)
              ($ symbol->string y) ) )))

(define %module-list-sort! (cut sort! <>
        (^[x y]
            (string<?
              ($ symbol->string $ module-name x)
              ($ symbol->string $ module-name y) ) )))

(define (%%load-module modsym path)
  (let1 modpath (module-name->path modsym)
    (unless (provided? modpath)
      (load path :environment (make-module #f) )
      (provide modpath ) )
    ;
    ; 念の為チェックしておく
    (unless (provided?   modpath) (errorf "~aがprovideされていない" modpath) )
    (unless (find-module modsym ) (errorf "~aがみつからない" modsym) )
  ) )

; mod-hashで指定したモジュールを全部requireする。
; all-modulesで得たリストとmod-hashを照合して、共通のモジュール&exportsリストと、
; thunkを実行してその結果と組みにして返す
(define-method gauche-require-modules ( (mod-hash <dictionary>) :optional (thunk (^[] #f) ) )
  (dict-for-each mod-hash
    (^ (modsym path)
      (if path (%%load-module modsym path) ) ) )
  (cons
    ($ map
        (^m (cons m
          (if ($ dict-get mod-hash $ module-name m )
            (case (module-exports m)
              [(#t) ($ dict-keys $ module-table m) ]
              [else => identity ])
            ($ dict-keys $ module-table m) ) ) )
     $ filter ($ dict-exists? mod-hash $ module-name $) (all-modules) )
    (thunk) ) )

; exprortシンボルをリストにして返す
(define (gauche-exports :optional (module-thunk #f))
  ($ %symbol-list-sort!
    $ delete-duplicates!
    $ concatenate!
    $ map cdr
    $ car (gauche-require-modules
            (alist->hash-table
              (if module-thunk (module-thunk) (gauche-modules-lseq (exclude-modules) ) ) ) ) ) )

; exportがないモジュール
(define (gauche-export-less-modules)
    ($ %module-list-sort!
      $ map car
      $ filter! (match-lambda [(m . syms) (null? syms) ] )
      $ car (gauche-require-modules
              ($ alist->hash-table
                $ gauche-modules-lseq (exclude-modules) ) ) ) )

; thunkを指定したとき (thunk-result == (thunk) @ gauche-require-modules )
; mod-pred : thunk-result -> module -> *
; obj-pred : thunk-result -> export-name -> obj -> *
(define (%gauche-module&object-lseq mod-pred obj-pred
                                    :optional (thunk #f) (module-thunk #f) )

    ($ lconcatenate
      $ (match-lambda [( m&sym . t )
          ($ lmap (match-lambda
                    [ (m . syms)
                      ($ lmap (cut cons m <> )
                        $ lfilter
                            (match-lambda
                              [#f #f]
                              [(sym obj) (obj-pred t sym obj) ] )
                        $ lmap
                            (pack$ (^[sym obj] (and obj (list sym obj) ) )
                              identity
                              (cut global-variable-ref m <> #f) )
                        $ x->lseq syms )
                    ] )
            $ lfilter (match-lambda [(m . _ ) (mod-pred t m) ] )
            $ x->lseq m&sym ) ])
        (gauche-require-modules
          (alist->hash-table
            (if module-thunk
              (module-thunk)
              (gauche-modules-lseq (exclude-modules) ) ) )
          (if thunk thunk (^[] #f) ) ) ) )

(define-method gauche-module&object-lseq ((class <class>)
                                            :key
                                              (module-pred (^ _ #t))
                                              (object-pred (^ _ #t))
                                              (module-thunk #f ) )
  (%gauche-module&object-lseq
    module-pred
    (^[ _ sym obj]
      (and (is-a? obj class ) (object-pred sym obj) ) )
    #f module-thunk ) )

(define-method gauche-module&object-lseq ((rx <regexp>)
                                            :key
                                              (module-pred (^ _ #t))
                                              (object-pred (^ _ #t))
                                              (module-thunk #f ) )
  (%gauche-module&object-lseq
    module-pred
    (^[ _ sym obj]
      (and ($ rx $ symbol->string sym) (object-pred sym obj) ) )
    #f module-thunk ) )


(define-method gauche-module&object-lseq (:key (thunk #f)
                                              (module-pred (^ _ #t))
                                              (object-pred (^ _ #t))
                                              (module-thunk #f ) )
  (%gauche-module&object-lseq
    module-pred object-pred thunk module-thunk ) )

; predefined objects
(define (predefined-objects-lseq)
  (gauche-module&object-lseq
    :thunk (^[] #f)
    :module-thunk predefined-modules-lseq) )

; predefinedでないモジュールの、predefinedに登録されていないオブジェクト
; library object (predefineではない。)
(define (library-objects-lseq)
  (gauche-module&object-lseq
    :thunk (^[] #f)
    :object-pred (^(_ sym obj) (not (predefined? sym obj) ) )
    :module-thunk (^[] (library-modules-lseq (exclude-modules) ) ) ) )

; predefinedでないモジュールの、predefinedに登録ずみのオブジェクト
; (maybe autoload)
; library object (predefineに含まれているlibraryオブジェクト )
(define (default-library-objects-lseq)
  (gauche-module&object-lseq
    :thunk (^[] #f)
    :object-pred (^(_ sym obj) (predefined? sym obj) )
    :module-thunk (^[] (library-modules-lseq (exclude-modules) ) ) ) )

; predefinedに登録ずみのオブジェクトを持つモジュール
; (maybe autoload)
(define (default-library-modules)
  ($ %module-list-sort!
  $ delete-duplicates!
  $ lmap (match-lambda [(mod sym obj) mod] )
  $ default-library-objects-lseq) )

; predefinedに登録されていないオブジェクトを持つモジュール
(define (library-modules)
  ($ %module-list-sort!
  $ delete-duplicates!
  $ lmap (match-lambda [(mod sym obj) mod] )
  $ library-objects-lseq) )

; autoloadされるモジュール
(define (autoloaded-modules)
  ($ %module-list-sort!
  $ lset-difference! eq? (default-library-modules) (library-modules) ) )

; whereis exportの定義元を表示
; TODO method は検索できない。
; TODO predefinedのときはどうする？
(define-method whereis ((rx <regexp>))
  ($ sort!
    $ delete-duplicates!
    $ lfilter-map (match-lambda [ (mod _ _) (module-source mod) ] )
    $ gauche-module&object-lseq rx ) )

(define-method whereis ((name <string>))
  ($ whereis $ string->regexp $ format #f "^~a$" $ regexp-quote name) )

;----------------------------

;($ for-each print $ gauche-module&object-lseq #/set!$/ :object-pred (^[_ obj] (is-a? obj <generic>) ) )
;($ for-each print
;  $ gauche-module&object-lseq
;      #/set!$/
;      :object-pred (^[_ obj](is-a? obj <procedure>))
;      :module-thunk predefined-modules-lseq )

;($ for-each print $ gauche-module&object-lseq <class> )
;($ for-each print $ gauche-module&object-lseq <generic> )

;($ for-each (match-lambda [(m sym proc)
;                            (let1 info (slot-ref proc 'info)
;                              (format #t "[~a] ~s (~a)\n" (class-of info) info m ) )])
;  $ gauche-module&object-lseq <procedure> )

;($ for-each print $ gauche-module&object-lseq <macro> )

;(print ($ sort! $ map symbol->string $ gauche-exports) )

;(for-each print (default-library-modules))
;(for-each print (library-modules))
;
;(print "exportの一部がdefaultモジュールに取り込まれているもの")
;(for-each ($ print $ module-name $) (lset-intersection eq? (default-library-modules) (library-modules)) )
;(print "exportのすべてがdefaultモジュールに取り込まれているもの")
;(for-each ($ print $ module-name $) (autoloaded-modules))

;(for-each print (default-library-objects-lseq))
;($ print $ gauche-exports predefined-modules-lseq)

;(let1 predefs (gauche-exports predefined-modules-lseq)
;  ($ for-each (match-lambda [(mod sym obj) (print "[" (module-name mod) "] " sym ) ])
;  $ gauche-module&object-lseq
;    :thunk (^[] #f)
;    :module-pred (^[ _ mod ] ($ null?
;                                $ lset-difference eq? (module-exports mod) predefs ))
;    :object-pred (^(_ sym obj) (not (predefined? sym obj) ) )
;    :module-thunk (^[] (library-modules-lseq (exclude-modules) ) ) ) )

; (for-each ($ print $ (cut take <> 2) $) (library-objects-lseq))

;($ for-each ($ print $ module-name $) $ gauche-export-less-modules)

• Shiro(2013/04/24 01:25:46 UTC): with-moduleおよび、evalに(interaction-environment)を指定することで特定のモジュールに読み込ませているようですが、多分意図どおりに動いていないと思います。
  (1)with-moduleは「コンパイル時のモジュール」を指定するもので、実行時のモジュールがどうなっているかは関係ありません。evalは実行時に働きます。
  (2)interaction-environmentは無条件でuserモジュールを返すので、(eval '(require foo) (interaction-environment)) は現在のモジュールとか関係なしに、userモジュールで(require foo)を実行します。つまりuserモジュールにfooが読み込まれることになります。
  sandboxとしてモジュールを使いたいなら、実行時に無名のモジュールを作ってそれをevalの第二引数に渡します。with-moduleは不要です。
  ただ、requireの動作 (一度ロードしたモジュールはロードしないようにする) がどうしても必要なのでなければ、evalとrequireを使うのではなくloadを使った方がいいんじゃないかと思います。evalが本当に必要な場面って少ないです。evalを使いたくなったら、一旦他の方法がないかどうか考えてみると良いと思います。
• yamasushi(2013/04/24 03:19:49 UTC) なるほど。with-moduleを勘違いしていました。
  でも、loadだとエラーになってしまうのです。requireなら読み込むです。

  WARNING: redefining constant rfc.822::*rfc822-standard-tokenizers*
  WARNING: redefining inlinable gauche.record::record?
  WARNING: redefining inlinable gauche.record::record-rtd
  WARNING: redefining inlinable util.combinations::p/each3
  WARNING: redefining inlinable util.stream::stream?
  WARNING: redefining inlinable util.stream::%make-stream
  WARNING: redefining inlinable util.stream::stream-null?
  WARNING: redefining inlinable util.stream::stream-pair?
  WARNING: redefining inlinable util.stream::stream-car
  WARNING: redefining inlinable util.stream::stream-cdr
  WARNING: redefining inlinable text.parse::char-list-predicate
  WARNING: redefining inlinable text.parse::assert-curr-char
  WARNING: redefining inlinable text.parse::skip-until
  WARNING: redefining inlinable text.parse::skip-until/common
  WARNING: redefining inlinable text.parse::skip-while
  WARNING: redefining inlinable text.parse::skip-while/common
  WARNING: redefining inlinable text.parse::peek-next-char
  WARNING: redefining inlinable text.parse::next-token
  WARNING: redefining inlinable text.parse::next-token/common
  WARNING: redefining inlinable text.parse::next-token-of
  WARNING: redefining inlinable text.parse::next-token-of/common
  WARNING: redefining inlinable control.job::job?
  WARNING: redefining inlinable control.job::job
  WARNING: redefining inlinable control.job::%make-job
  WARNING: redefining inlinable control.job::job-thunk
  WARNING: redefining inlinable control.job::job-specific
  WARNING: redefining inlinable control.job::job-status
  WARNING: redefining inlinable control.job::job-result
  WARNING: redefining inlinable control.job::job-waiter-cv
  WARNING: redefining inlinable control.job::job-waiter-mutex
  WARNING: redefining inlinable control.job::job-depends-on
  WARNING: redefining inlinable control.job::job-acknowledge-time
  WARNING: redefining inlinable control.job::job-start-time
  WARNING: redefining inlinable control.job::job-finish-time
  WARNING: redefining inlinable control.job::job-thunk-set!
  WARNING: redefining inlinable control.job::job-specific-set!
  WARNING: redefining inlinable control.job::job-status-set!
  WARNING: redefining inlinable control.job::job-result-set!
  WARNING: redefining inlinable control.job::job-waiter-cv-set!
  WARNING: redefining inlinable control.job::job-waiter-mutex-set!
  WARNING: redefining inlinable control.job::job-depends-on-set!
  WARNING: redefining inlinable control.job::job-acknowledge-time-set!
  WARNING: redefining inlinable control.job::job-start-time-set!
  WARNING: redefining inlinable control.job::job-finish-time-set!
  WARNING: Class redefinition of #<class <setter-mixin>> is aborted.  The state of the class may be inconsistent
  *** ERROR: Compile Error: Autoloaded symbol char-set-difference is not defined in the file "srfi-14/set"
  "/usr/local/share/gauche-0.9/0.9.4_pre3/lib/www/cgi.scm":40:(define-module www.cgi (use srfi-1)  ...
  
  Stack Trace:
  _______________________________________
    0  (proc k v)
          At line 60 of "/usr/local/share/gauche-0.9/0.9.4_pre3/lib/gauche/hashutil.scm"
    1  (dict-for-each mod-hash (^ (modsym path) (if path (load path) (unl ...
          At line 83 of "/home/shuji/gauche/module/gauche-exports.scm"
    2  (gauche-require-modules (alist->hash-table (if module-thunk (modul ...
          At line 138 of "/home/shuji/gauche/module/gauche-exports.scm"
    3  (gauche-module&object-lseq #/set!$/ :object-pred (cut is-a? <> <ge ...
          [unknown location]
  >Exit code: 70
  

• yamasushi(2013/04/24 04:52:59 UTC)

  (define (%%require-module modsym path)
    ;(print "modsym = " modsym) (flush)
    (unless (find-module modsym)
      (load path :environment (make-module #f) ) )
    ;;
    ; 念の為チェックしておく
    (unless (find-module modsym) (errorf "~aがみつからない" modsym) )
  )
  

  だと、エラーにはなりませんけど、警告は出ます。 requireだと、警告も出ないので、ちょっと落ち着かないです。
• Shiro(2013/04/24 06:25:17 UTC):ああそうか。既にロードされちゃってるものをまたロードしようとするから不都合が起きるわけですね。requireだとそもそも既にロードしてるやつは飛ばすからな。(provided? "gauche/sequence")等とすると既にrequireされたかどうかわかるので、それで#fが返るものだけloadしたらどうでしょう。
  
• yamasushi(2013/04/24 08:03:09 UTC)

  (define (%%load-module modsym path)
    (let1 modpath (module-name->path modsym)
      (unless (provided? modpath)
        (load path :environment (make-module #f) )
        (provide modpath ) )
      ;
      ; 念の為チェックしておく
      (unless (provided?   modpath) (errorf "~aがprovideされていない" modpath) )
      (unless (find-module modsym ) (errorf "~aがみつからない" modsym) )
    ) )
  

  で、動いたようです。ありがとうございました。
  
• yamasushi(2013/04/24 21:49:10 UTC)修正しました。
  

クラスの列挙

(define-module gauche-classes
  (use srfi-1)
  (use util.match)
  (use gauche.lazy)
  ;;
  (use gauche-exports)
  (use komono-combinator)
  (use pretty-print) ; pretty printer
  (export
    gauche-classes-lseq
    gauche-sub-classes-lseq
    gauche-super-classes-lseq
    gauche-classes-for-each
  ) )
(select-module gauche-classes)

; 下記サイトを参考にした

; Vim+Gaucheでの作業環境の設定 - 再帰の反復
; http://d.hatena.ne.jp/lemniscus/20100308/1268022750

; [Gauche] 環境に存在するすべてのクラスを得る - karetta.jp
; http://karetta.jp/article/blog/oneline/008181

; [Gauche] クラス階層図を描く - karetta.jp
; http://karetta.jp/article/blog/oneline/008183

; class
(define (gauche-classes-lseq ) (gauche-module&object-lseq <class> ) )

(define-method gauche-sub-classes-lseq ((super <class>) )
  (gauche-module&object-lseq <class> :object-pred (^[_ obj] (subtype? obj super) ) ) )

(define-method gauche-super-classes-lseq ((sub <class>) )
  (gauche-module&object-lseq <class> :object-pred (^[_ obj] (subtype? sub obj) ) ) )

; proc : <module> -> <symbol> -> <class> -> *
(define (gauche-classes-for-each proc)
  (for-each (pack$ proc car cadr caddr)
      (gauche-classes-lseq) ) )

;(gauche-classes-for-each print)
;(for-each print (gauche-sub-classes-lseq <dictionary> ) )
;(for-each print (gauche-sub-classes-lseq <ordered-dictionary> ) )
;(for-each print (gauche-super-classes-lseq <dictionary> ) )
;(for-each print (gauche-super-classes-lseq <ordered-dictionary> ) )

applicableの列挙

(define-module gauche-applicables
  (use srfi-1)
  (use util.match)
  (use gauche.lazy)
  ;;
  (use gauche-modules)
  (use gauche-exports)
  (use komono-combinator)
  (use pretty-print) ; pretty printer
  (export
    applicable?
    gauche-applicables
    gauche-generics-lseq
    gauche-procedures-lseq
    gauche-methods-lseq
    gauche-applicables-lseq
  ) )
(select-module gauche-applicables)

; yamasushi http://chaton.practical-scheme.net/gauche/a/2013/04/23#entry-5175d115-7eca6
; <procedure>の名前はinfoスロットを見るのだろうと思うのですが、文字列だったりシンボルだったりしているのです。
; 名前を見る方法があるのでしょうか？(また、無名かどうかの判定法など。)
; shiro http://chaton.practical-scheme.net/gauche/a/2013/04/23#entry-5175d55d-e93b1
; procedure-infoの仕様はまだ確定しておらず、将来変更される可能性が高いです。
; 今のところ、
;   SUBR(Cで実装された手続き)だと文字列、
;   Schemeで実装されたトップレベル手続きはシンボル、
;   ネストしている手続きの場合はトップレベルからの名前のリスト、
;   メソッドは名前とspecializerのリスト、
;   case-lambdaの場合はもっと複雑。
;   名前がコンパイラに判定できなかった箇所は#fが入ってます。
; Schemeでは仕様上は全て無名関数ですんで、名前はあくまで参考です
; (最初にトップレベルに束縛された時の名前、等)

; generic
(define (gauche-generics-lseq) (gauche-module&object-lseq <generic> ) )

; method
(define (gauche-methods-lseq) (gauche-module&object-lseq <method> ) )

; procedure
(define (gauche-procedures-lseq) (gauche-module&object-lseq <procedure> ) )

; applicables
; object-applyが新しく定義されるかもしれないので、毎回実行するようにする
(define (gauche-applicables)
  `( ,<procedure>
    ,@($ delete-duplicates
        $ map ($ car $ (cut ~ <> 'specializers ) $)
        $ ~ object-apply 'methods ) ) )

(define-method applicable? ((obj <top>))
  (any (cut subtype? (class-of obj) <> ) (gauche-applicables) ) )

(define (gauche-applicables-lseq . rest)
  (apply gauche-module&object-lseq
    :thunk gauche-applicables
    :object-pred (^( supers sym x) (any (cut is-a? x <> ) supers ) )
    rest ) )

;($ for-each print $ gauche-methods-lseq )
;($ for-each print $ gauche-generics-lseq)
;($ for-each print $ gauche-procedures-lseq )
;($ for-each print $ gauche-applicables-lseq)
;($ for-each print $ gauche-applicables-lseq :module-thunk predefined-modules-lseq )

• Gauche:Module

Tag: Module