summaryrefslogtreecommitdiff
path: root/test-suite/tests/modules.test
diff options
context:
space:
mode:
Diffstat (limited to 'test-suite/tests/modules.test')
-rw-r--r--test-suite/tests/modules.test465
1 files changed, 465 insertions, 0 deletions
diff --git a/test-suite/tests/modules.test b/test-suite/tests/modules.test
new file mode 100644
index 000000000..d99b961b3
--- /dev/null
+++ b/test-suite/tests/modules.test
@@ -0,0 +1,465 @@
+;;;; modules.test --- exercise some of guile's module stuff -*- scheme -*-
+
+;;;; Copyright (C) 2006, 2007, 2009-2011, 2014 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 test-modules)
+ #:use-module (srfi srfi-1)
+ #:use-module ((ice-9 streams) #:prefix s:) ; for test purposes
+ #:use-module (test-suite lib))
+
+
+(define (every? . args)
+ (not (not (apply every args))))
+
+
+
+;;;
+;;; Foundations.
+;;;
+
+(with-test-prefix "foundations"
+
+ (pass-if "modules don't remain anonymous"
+ ;; This is a requirement for `psyntax': it stores module names and relies
+ ;; on being able to `resolve-module' them.
+ (let ((m (make-module)))
+ (and (module-name m)
+ (eq? m (resolve-module (module-name m))))))
+
+ (pass-if "module-add!"
+ (let ((m (make-module))
+ (value (cons 'x 'y)))
+ (module-add! m 'something (make-variable value))
+ (eq? (module-ref m 'something) value)))
+
+ (pass-if "module-define!"
+ (let ((m (make-module))
+ (value (cons 'x 'y)))
+ (module-define! m 'something value)
+ (eq? (module-ref m 'something) value)))
+
+ (pass-if "module-use!"
+ (let ((m (make-module))
+ (import (make-module)))
+ (module-define! m 'something 'something)
+ (module-define! import 'imported 'imported)
+ (module-use! m import)
+ (and (eq? (module-ref m 'something) 'something)
+ (eq? (module-ref m 'imported) 'imported)
+ (module-local-variable m 'something)
+ (not (module-local-variable m 'imported))
+ #t)))
+
+ (pass-if "module-use! (duplicates local binding)"
+ ;; Imported bindings can't override locale bindings.
+ (let ((m (make-module))
+ (import (make-module)))
+ (module-define! m 'something 'something)
+ (module-define! import 'something 'imported)
+ (module-use! m import)
+ (eq? (module-ref m 'something) 'something)))
+
+ (pass-if "module-locally-bound?"
+ (let ((m (make-module))
+ (import (make-module)))
+ (module-define! m 'something #t)
+ (module-define! import 'imported #t)
+ (module-use! m import)
+ (and (module-locally-bound? m 'something)
+ (not (module-locally-bound? m 'imported)))))
+
+ (pass-if "module-{local-,}variable"
+ (let ((m (make-module))
+ (import (make-module)))
+ (module-define! m 'local #t)
+ (module-define! import 'imported #t)
+ (module-use! m import)
+ (and (module-local-variable m 'local)
+ (not (module-local-variable m 'imported))
+ (eq? (module-variable m 'local)
+ (module-local-variable m 'local))
+ (eq? (module-local-variable import 'imported)
+ (module-variable m 'imported)))))
+
+ (pass-if "module-import-interface"
+ (and (every? (lambda (sym iface)
+ (eq? (module-import-interface (current-module) sym)
+ iface))
+ '(current-module exception:bad-variable every)
+ (cons the-scm-module
+ (map resolve-interface
+ '((test-suite lib) (srfi srfi-1)))))
+
+ ;; For renamed bindings, a custom interface is used so we can't
+ ;; check for equality with `eq?'.
+ (every? (lambda (sym iface)
+ (let ((import
+ (module-import-interface (current-module) sym)))
+ (equal? (module-name import)
+ (module-name iface))))
+ '(s:make-stream s:stream-car s:stream-cdr)
+ (make-list 3 (resolve-interface '(ice-9 streams))))))
+
+ (pass-if "module-reverse-lookup"
+ (let ((mods '((srfi srfi-1) (test-suite lib) (ice-9 streams)))
+ (syms '(every exception:bad-variable make-stream))
+ (locals '(every exception:bad-variable s:make-stream)))
+ (every? (lambda (var sym)
+ (eq? (module-reverse-lookup (current-module) var)
+ sym))
+ (map module-variable
+ (map resolve-interface mods)
+ syms)
+ 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)))
+
+
+
+;;;
+;;; 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))))))))
+
+
+
+;;;
+;;; 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))))
+
+
+
+;;;
+;;; Observers.
+;;;
+
+(with-test-prefix "observers"
+
+ (pass-if "weak observer invoked"
+ (let* ((m (make-module))
+ (invoked 0))
+ (module-observe-weak m (lambda (mod)
+ (if (eq? mod m)
+ (set! invoked (+ invoked 1)))))
+ (module-define! m 'something 2)
+ (module-define! m 'something-else 1)
+ (= invoked 2)))
+
+ (pass-if "all weak observers invoked"
+ ;; With the two-argument `module-observe-weak' available in previous
+ ;; versions, the observer would get unregistered as soon as the observing
+ ;; closure gets GC'd, making it impossible to use an anonymous lambda as
+ ;; the observing procedure.
+
+ (let* ((m (make-module))
+ (observer-count 500)
+ (observer-ids (let loop ((i observer-count)
+ (ids '()))
+ (if (= i 0)
+ ids
+ (loop (- i 1) (cons (make-module) ids)))))
+ (observers-invoked (make-hash-table observer-count)))
+
+ ;; register weak observers
+ (for-each (lambda (id)
+ (module-observe-weak m id
+ (lambda (m)
+ (hashq-set! observers-invoked
+ id #t))))
+ observer-ids)
+
+ (gc)
+
+ ;; invoke them
+ (module-call-observers m)
+
+ ;; make sure all of them were invoked
+ (->bool (every (lambda (id)
+ (hashq-ref observers-invoked id))
+ observer-ids))))
+
+ (pass-if "imported bindings updated"
+ (let ((m (make-module))
+ (imported (make-module)))
+ ;; Beautify them, notably adding them a public interface.
+ (beautify-user-module! m)
+ (beautify-user-module! imported)
+
+ (module-use! m (module-public-interface imported))
+ (module-define! imported 'imported-binding #t)
+
+ ;; At this point, `imported-binding' is local to IMPORTED.
+ (and (not (module-variable m 'imported-binding))
+ (begin
+ ;; Export `imported-binding' from IMPORTED.
+ (module-export! imported '(imported-binding))
+
+ ;; Make sure it is now visible from M.
+ (module-ref m 'imported-binding))))))
+
+
+
+;;;
+;;; Duplicate bindings handling.
+;;;
+
+(with-test-prefix "duplicate bindings"
+
+ (pass-if "simple duplicate handler"
+ ;; Import the same binding twice.
+ (let* ((m (make-module))
+ (import1 (make-module))
+ (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)))))
+
+ (set-module-duplicates-handlers! m (list handler))
+ (module-define! m 'something 'something)
+ (set-module-name! import1 'imported-module-1)
+ (set-module-name! import2 'imported-module-2)
+ (module-define! import1 'imported 'imported-1)
+ (module-define! import2 'imported 'imported-2)
+ (module-use! m import1)
+ (module-use! m import2)
+ (and (eq? (module-ref m 'imported) 'imported-1)
+ handler-invoked?))))
+
+
+;;;
+;;; Lazy binder.
+;;;
+
+(with-test-prefix "lazy binder"
+
+ (pass-if "not invoked"
+ (let ((m (make-module))
+ (invoked? #f))
+ (module-define! m 'something 2)
+ (set-module-binder! m (lambda args (set! invoked? #t) #f))
+ (and (module-ref m 'something)
+ (not invoked?))))
+
+ (pass-if "not invoked (module-add!)"
+ (let ((m (make-module))
+ (invoked? #f))
+ (set-module-binder! m (lambda args (set! invoked? #t) #f))
+ (module-add! m 'something (make-variable 2))
+ (and (module-ref m 'something)
+ (not invoked?))))
+
+ (pass-if "invoked (module-ref)"
+ (let ((m (make-module))
+ (invoked? #f))
+ (set-module-binder! m (lambda args (set! invoked? #t) #f))
+ (false-if-exception (module-ref m 'something))
+ invoked?))
+
+ (pass-if "invoked (module-define!)"
+ (let ((m (make-module))
+ (invoked? #f))
+ (set-module-binder! m (lambda args (set! invoked? #t) #f))
+ (module-define! m 'something 2)
+ (and invoked?
+ (eqv? (module-ref m 'something) 2))))
+
+ (pass-if "honored (ref)"
+ (let ((m (make-module))
+ (invoked? #f)
+ (value (cons 'x 'y)))
+ (set-module-binder! m
+ (lambda (mod sym define?)
+ (set! invoked? #t)
+ (cond ((not (eq? m mod))
+ (error "invalid module" mod))
+ (define?
+ (error "DEFINE? shouldn't be set"))
+ (else
+ (make-variable value)))))
+ (and (eq? (module-ref m 'something) value)
+ invoked?))))
+
+
+
+;;;
+;;; Higher-level features.
+;;;
+
+(with-test-prefix "autoload"
+
+ (pass-if "module-autoload!"
+ (let ((m (make-module)))
+ (module-autoload! m '(ice-9 q) '(make-q))
+ (not (not (module-ref m 'make-q)))))
+
+ (pass-if "autoloaded"
+ (catch #t
+ (lambda ()
+ ;; Simple autoloading.
+ (eval '(begin
+ (define-module (test-autoload-one)
+ :autoload (ice-9 q) (make-q))
+ (not (not make-q)))
+ (current-module)))
+ (lambda (key . args)
+ #f)))
+
+ ;; In Guile 1.8.0 this failed because the binder in
+ ;; `make-autoload-interface' would try to remove the autoload interface
+ ;; from the module's "uses" without making sure it is still part of these
+ ;; "uses".
+ ;;
+ (pass-if "autoloaded+used"
+ (catch #t
+ (lambda ()
+ (eval '(begin
+ (define-module (test-autoload-two)
+ :autoload (ice-9 q) (make-q)
+ :use-module (ice-9 q))
+ (not (not make-q)))
+ (current-module)))
+ (lambda (key . args)
+ #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)))))
+
+
+(with-test-prefix "circular imports"
+ (pass-if-equal "#:select" 1
+ (begin
+ (eval
+ '(begin
+ (define-module (test-circular-imports))
+ (define (init-module-a)
+ (eval '(begin
+ (define-module (test-circular-imports a)
+ #:use-module (test-circular-imports b)
+ #:export (from-a))
+ (define from-a 1))
+ (current-module)))
+ (define (init-module-b)
+ (eval '(begin
+ (define-module (test-circular-imports b)
+ #:use-module ((test-circular-imports a)
+ #:select (from-a))
+ #:export (from-b))
+ (define from-b 2))
+ (current-module)))
+ (define (submodule-binder mod name)
+ (let ((m (make-module 31)))
+ (set-module-kind! m 'directory)
+ (set-module-name! m (append (module-name mod) (list name)))
+ (module-define-submodule! mod name m)
+ (case name
+ ((a) (init-module-a))
+ ((b) (init-module-b))
+ ((c) #t)
+ (else (error "unreachable")))
+ m))
+ (set-module-submodule-binder! (current-module) submodule-binder))
+ (current-module))
+ (eval '(begin
+ (define-module (test-circular-imports c))
+ (use-modules (test-circular-imports a))
+ from-a)
+ (current-module)))))