mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-04-30 20:00:19 +02:00
317 lines
10 KiB
Scheme
317 lines
10 KiB
Scheme
;;;; modules.test --- exercise some of guile's module stuff -*- scheme -*-
|
||
|
||
;;;; Copyright (C) 2006, 2007 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 2.1 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) ;; for test purposes
|
||
#:renamer (symbol-prefix-proc 's:))
|
||
:use-module (test-suite lib))
|
||
|
||
|
||
(define (every? . args)
|
||
(not (not (apply every args))))
|
||
|
||
|
||
|
||
;;;
|
||
;;; Foundations.
|
||
;;;
|
||
|
||
(with-test-prefix "foundations"
|
||
|
||
(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))))
|
||
|
||
|
||
|
||
;;;
|
||
;;; 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)
|
||
(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?
|
||
(eq? (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))))
|