summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--module/ice-9/session.scm11
-rw-r--r--test-suite/Makefile.am1
-rw-r--r--test-suite/tests/session.test53
3 files changed, 56 insertions, 9 deletions
diff --git a/module/ice-9/session.scm b/module/ice-9/session.scm
index 10ce61396..36aeb999a 100644
--- a/module/ice-9/session.scm
+++ b/module/ice-9/session.scm
@@ -406,15 +406,8 @@ It is an image under the mapping EXTRACT."
(define (root-modules)
(submodules (resolve-module '() #f)))
-(define (submodules m)
- (hash-fold (lambda (name var data)
- (let ((obj (and (variable-bound? var) (variable-ref var))))
- (if (and (module? obj)
- (eq? (module-kind obj) 'directory))
- (cons obj data)
- data)))
- '()
- (module-obarray m)))
+(define (submodules mod)
+ (hash-map->list (lambda (k v) v) (module-submodules mod)))
(define apropos-fold-exported
(make-fold-modules root-modules submodules module-public-interface))
diff --git a/test-suite/Makefile.am b/test-suite/Makefile.am
index 69261493f..c504587d0 100644
--- a/test-suite/Makefile.am
+++ b/test-suite/Makefile.am
@@ -101,6 +101,7 @@ SCM_TESTS = tests/00-initial-env.test \
tests/reader.test \
tests/receive.test \
tests/regexp.test \
+ tests/session.test \
tests/signals.test \
tests/socket.test \
tests/srcprop.test \
diff --git a/test-suite/tests/session.test b/test-suite/tests/session.test
new file mode 100644
index 000000000..169747123
--- /dev/null
+++ b/test-suite/tests/session.test
@@ -0,0 +1,53 @@
+;;;; session.test --- test suite for (ice-9 session) -*- scheme -*-
+;;;; Jose Antonio Ortega Ruiz <jao@gnu.org> -- August 2010
+;;;;
+;;;; Copyright (C) 2010 Free Software Foundation, Inc.
+;;;;
+;;;; This library is free software; you can redistribute it and/or
+;;;; modify it under the terms of the GNU Lesser General Public
+;;;; License as published by the Free Software Foundation; either
+;;;; version 3 of the License, or (at your option) any later version.
+;;;;
+;;;; This library is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;;; Lesser General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+;;;; 02110-1301 USA
+
+(define-module (test-suite session)
+ #:use-module (test-suite lib)
+ #:use-module (ice-9 session))
+
+(define (find-module mod)
+ (call/cc (lambda (k)
+ (apropos-fold-all (lambda (m _)
+ (and (not (module? m)) (k #f))
+ (and (eq? m mod) (k #t)))
+ #f))))
+(define (find-mod-name mod-name)
+ (find-module (resolve-module mod-name #f #:ensure #f)))
+
+
+(with-test-prefix "apropos-fold-all"
+ (pass-if "a root module: ice-9" (find-mod-name '(ice-9)))
+ (pass-if "a child of test-suite" (find-mod-name '(test-suite lib)))
+ (pass-if "a non-module" (not (find-mod-name '(ice-999-0))))
+ (pass-if "a childish non-module" (not (find-mod-name '(ice-9 ice-999-0))))
+ (pass-if "an anonymous module" (find-mod-name (module-name (make-module)))))
+
+(define (find-interface mod-name)
+ (let* ((mod (resolve-module mod-name #f #:ensure #f))
+ (ifc (and mod (module-public-interface mod))))
+ (and ifc
+ (call/cc (lambda (k)
+ (apropos-fold-exported (lambda (i _)
+ (and (eq? i ifc) (k #t)))
+ #f))))))
+
+(with-test-prefix "apropos-fold-exported"
+ (pass-if "a child of test-suite" (find-interface '(test-suite lib)))
+ (pass-if "a child of ice-9" (find-interface '(ice-9 session))))