diff options
author | Jose A. Ortega Ruiz <jao@gnu.org> | 2010-08-31 14:13:43 +0200 |
---|---|---|
committer | Andy Wingo <wingo@pobox.com> | 2010-09-02 21:47:04 -0700 |
commit | a148c752ba7adf0d2005cc7bc5928a2dde467609 (patch) | |
tree | fc22a12a7ea5ec5e45a6d375c15f3d78c711fe80 | |
parent | dcb68c09d03cf9006c8e2c21c726a3f35be026bd (diff) | |
download | guile-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.scm | 11 | ||||
-rw-r--r-- | test-suite/Makefile.am | 1 | ||||
-rw-r--r-- | test-suite/tests/session.test | 53 |
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)))) |