diff options
-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)))) |