summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorJose A. Ortega Ruiz <jao@gnu.org>2010-08-31 14:13:43 +0200
committerAndy Wingo <wingo@pobox.com>2010-09-02 21:47:04 -0700
commita148c752ba7adf0d2005cc7bc5928a2dde467609 (patch)
treefc22a12a7ea5ec5e45a6d375c15f3d78c711fe80
parentdcb68c09d03cf9006c8e2c21c726a3f35be026bd (diff)
downloadguile-a148c752ba7adf0d2005cc7bc5928a2dde467609.tar.gz
Fix for `submodules' in (ice-9 session) (closes #30062)
* module/ice-9/session.scm (submodules): replace implementation to use `module-submodules' instead of `module-obarray' (the latter doesn't include submodules anymore). * test-suite/tests/session.test: new test suite for session, checking the exported procedures that use `submodules'. Signed-off-by: Jose A. Ortega Ruiz <jao@gnu.org>
-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))))