Merge remote-tracking branch 'origin/stable-2.0'

[bpt/guile.git] / test-suite / tests / modules.test

diff --git a/test-suite/tests/modules.test b/test-suite/tests/modules.test
index f22cfe9..fb54061 100644 (file)
--- a/test-suite/tests/modules.test
+++ b/test-suite/tests/modules.test
@@ -1,6 +1,6 @@
 ;;;; modules.test --- exercise some of guile's module stuff -*- scheme -*-
 
-;;;; Copyright (C) 2006, 2007, 2009 Free Software Foundation, Inc.
+;;;; Copyright (C) 2006, 2007, 2009, 2010, 2011 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
@@ -17,10 +17,10 @@
 ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
 
 (define-module (test-suite test-modules)
-  :use-module (srfi srfi-1)
-  :use-module ((ice-9 streams)  ;; for test purposes
-               #:renamer (symbol-prefix-proc 's:))
-  :use-module (test-suite lib))
+  #:use-module (srfi srfi-1)
+  #:use-module ((ice-9 streams)  ;; for test purposes
+                #:renamer (symbol-prefix-proc 's:))
+  #:use-module (test-suite lib))
 
 
 (define (every? . args)
@@ -125,7 +125,85 @@
               (map module-variable
                    (map resolve-interface mods)
                    syms)
-              locals))))
+              locals)))
+
+  (pass-if "module-reverse-lookup [pre-module-obarray]"
+    (let ((var (module-variable (current-module) 'string?)))
+      (eq? 'string? (module-reverse-lookup #f var))))
+
+  (pass-if-exception "module-reverse-lookup [wrong-type-arg]"
+    exception:wrong-type-arg
+    (module-reverse-lookup (current-module) 'foo))
+
+  (pass-if "the-root-module"
+    (eq? (module-public-interface the-root-module) the-scm-module))
+
+  (pass-if "the-scm-module"
+    ;; THE-SCM-MODULE is its own public interface.  See
+    ;; <https://savannah.gnu.org/bugs/index.php?30623>.
+    (eq? (module-public-interface the-scm-module) the-scm-module)))
+
+
+\f
+;;;
+;;; module-use! / module-use-interfaces!
+;;;
+(with-test-prefix "module-use"
+  (let ((m (make-module)))
+    (pass-if "no uses initially"
+      (null? (module-uses m)))
+
+    (pass-if "using ice-9 q"
+      (begin
+        (module-use! m (resolve-interface '(ice-9 q)))
+        (equal? (module-uses m)
+                (list (resolve-interface '(ice-9 q))))))
+
+    (pass-if "using ice-9 q again"
+      (begin
+        (module-use! m (resolve-interface '(ice-9 q)))
+        (equal? (module-uses m)
+                (list (resolve-interface '(ice-9 q))))))
+
+    (pass-if "using ice-9 ftw"
+      (begin
+        (module-use-interfaces! m (list (resolve-interface '(ice-9 ftw))))
+        (equal? (module-uses m)
+                (list (resolve-interface '(ice-9 q))
+                      (resolve-interface '(ice-9 ftw))))))
+
+    (pass-if "using ice-9 ftw again"
+      (begin
+        (module-use-interfaces! m (list (resolve-interface '(ice-9 ftw))))
+        (equal? (module-uses m)
+                (list (resolve-interface '(ice-9 q))
+                      (resolve-interface '(ice-9 ftw))))))
+
+    (pass-if "using ice-9 control twice"
+      (begin
+        (module-use-interfaces! m (list (resolve-interface '(ice-9 control))
+                                        (resolve-interface '(ice-9 control))))
+        (equal? (module-uses m)
+                (list (resolve-interface '(ice-9 q))
+                      (resolve-interface '(ice-9 ftw))
+                      (resolve-interface '(ice-9 control))))))))
+
+
+\f
+;;;
+;;; Resolve-module.
+;;;
+
+(with-test-prefix "resolve-module"
+
+  (pass-if "#:ensure #t by default"
+    (module? (resolve-module (list (gensym)))))
+
+  (pass-if "#:ensure #t explicitly"
+    (module? (resolve-module (list (gensym)) #:ensure #t)))
+
+  (pass-if "#:ensure #f"
+    (not (resolve-module (list (gensym)) #:ensure #f))))
 
 
 \f
@@ -212,6 +290,10 @@
            (import2 (make-module))
            (handler-invoked? #f)
            (handler (lambda (module name int1 val1 int2 val2 var val)
+                      ;; We expect both VAR and VAL to be #f, as there
+                      ;; is no previous binding for 'imported in M.
+                      (if var (error "unexpected var" var))
+                      (if val (error "unexpected val" val))
                       (set! handler-invoked? #t)
                       ;; Keep the first binding.
                       (or var (module-local-variable int1 name)))))
@@ -263,7 +345,7 @@
       (set-module-binder! m (lambda args (set! invoked? #t) #f))
       (module-define! m 'something 2)
       (and invoked?
-           (eq? (module-ref m 'something) 2))))
+           (eqv? (module-ref m 'something) 2))))
 
   (pass-if "honored (ref)"
     (let ((m (make-module))
@@ -322,3 +404,22 @@
               (current-module)))
        (lambda (key . args)
          #f))))
+
+\f
+;;;
+;;; R6RS compatibility
+;;;
+
+(with-test-prefix "module versions"
+
+  (pass-if "version-matches? for matching versions"
+    (version-matches? '(1 2 3) '(1 2 3)))
+
+  (pass-if "version-matches? for non-matching versions"
+    (not (version-matches? '(3 2 1) '(1 2 3))))
+
+  (pass-if "version-matches? against more specified version"
+    (version-matches? '(1 2) '(1 2 3)))
+
+  (pass-if "version-matches? against less specified version"
+    (not (version-matches? '(1 2 3) '(1 2)))))