diff --git a/scheme/Makefile.am b/scheme/Makefile.am index 4a49578..cf774f6 100644 --- a/scheme/Makefile.am +++ b/scheme/Makefile.am @@ -29,7 +29,7 @@ EXTRA_DIST=ikarus.boot.4.prebuilt ikarus.boot.8.prebuilt \ ikarus.string-to-number.ss ikarus.compiler.source-optimizer.ss \ ikarus.compiler.tag-annotation-analysis.ss ikarus.ontology.ss \ ikarus.reader.annotated.ss ikarus.pointers.ss ikarus.equal.ss \ - ikarus.symbol-table.ss + ikarus.symbol-table.ss ikarus.apropos.ss all: $(nodist_pkglib_DATA) diff --git a/scheme/Makefile.in b/scheme/Makefile.in index f2a6742..c9a9d3f 100644 --- a/scheme/Makefile.in +++ b/scheme/Makefile.in @@ -184,7 +184,7 @@ EXTRA_DIST = ikarus.boot.4.prebuilt ikarus.boot.8.prebuilt \ ikarus.string-to-number.ss ikarus.compiler.source-optimizer.ss \ ikarus.compiler.tag-annotation-analysis.ss ikarus.ontology.ss \ ikarus.reader.annotated.ss ikarus.pointers.ss ikarus.equal.ss \ - ikarus.symbol-table.ss + ikarus.symbol-table.ss ikarus.apropos.ss revno = "$(shell sed 's/ .*//' ../.bzr/branch/last-revision 2>/dev/null)" sizeofvoidp = $(shell grep SIZEOF_VOID_P ../config.h | sed "s/.*\(.\)/\1/g") diff --git a/scheme/ikarus.apropos.ss b/scheme/ikarus.apropos.ss new file mode 100644 index 0000000..8fa79ff --- /dev/null +++ b/scheme/ikarus.apropos.ss @@ -0,0 +1,59 @@ + +(library (ikarus.apropos) + (export apropos) + (import + (except (ikarus) apropos) + (only (psyntax library-manager) library-subst library-name)) + + (define (compose f g) + (lambda (x) (f (g x)))) + + (define (match-maker s1) + (let ([n1 (string-length s1)]) + (lambda (s2) + (let ([m (fx- (string-length s2) n1)]) + (let f ([i2 0]) + (and (fx<=? i2 m) + (or (let g ([i1 0] [i2 i2]) + (or (fx= i1 n1) + (and (char=? (string-ref s1 i1) + (string-ref s2 i2)) + (g (fx+ i1 1) (fx+ i2 1))))) + (f (fx+ i2 1))))))))) + + (define ($apropos-list name who) + (let ([name + (cond + [(string? name) name] + [(symbol? name) (symbol->string name)] + [else + (die who "not a string or symbol" name)])]) + (let ([libs (installed-libraries)] + [matcher + (compose (match-maker name) + (compose symbol->string car))]) + (fold-right + (lambda (lib rest) + (let ([ls (filter matcher (library-subst lib))]) + (if (null? ls) + rest + (cons (cons (library-name lib) (map car ls)) rest)))) + '() + (list-sort + (lambda (lib1 lib2) + (let f ([ls1 (library-name lib1)] [ls2 (library-name lib2)]) + (and (pair? ls2) + (or (null? ls1) + (let ([s1 (symbol->string (car ls1))] + [s2 (symbol->string (car ls2))]) + (or (string