test-suite/tests/modules.test

   1 ;;;; modules.test --- exercise some of guile's module stuff -*- scheme -*-
   2
   3 ;;;; Copyright (C) 2006, 2007 Free Software Foundation, Inc.
   4 ;;;;
   5 ;;;; This library is free software; you can redistribute it and/or
   6 ;;;; modify it under the terms of the GNU Lesser General Public
   7 ;;;; License as published by the Free Software Foundation; either
   8 ;;;; version 2.1 of the License, or (at your option) any later version.
   9 ;;;;
  10 ;;;; This library is distributed in the hope that it will be useful,
  11 ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  12 ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  13 ;;;; Lesser General Public License for more details.
  14 ;;;;
  15 ;;;; You should have received a copy of the GNU Lesser General Public
  16 ;;;; License along with this library; if not, write to the Free Software
  17 ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
  18
  19 (define-module (test-suite test-modules)
  20   :use-module (srfi srfi-1)
  21   :use-module ((ice-9 streams)  ;; for test purposes
  22                #:renamer (symbol-prefix-proc 's:))
  23   :use-module (test-suite lib))
  24
  25
  26 (define (every? . args)
  27   (not (not (apply every args))))
  28
  29
  30 \f
  31 ;;;
  32 ;;; Foundations.
  33 ;;;
  34
  35 (with-test-prefix "foundations"
  36
  37   (pass-if "module-add!"
  38     (let ((m (make-module))
  39           (value (cons 'x 'y)))
  40       (module-add! m 'something (make-variable value))
  41       (eq? (module-ref m 'something) value)))
  42
  43   (pass-if "module-define!"
  44     (let ((m (make-module))
  45           (value (cons 'x 'y)))
  46       (module-define! m 'something value)
  47       (eq? (module-ref m 'something) value)))
  48
  49   (pass-if "module-use!"
  50     (let ((m (make-module))
  51           (import (make-module)))
  52       (module-define! m 'something 'something)
  53       (module-define! import 'imported 'imported)
  54       (module-use! m import)
  55       (and (eq? (module-ref m 'something) 'something)
  56            (eq? (module-ref m 'imported)  'imported)
  57            (module-local-variable m 'something)
  58            (not (module-local-variable m 'imported))
  59            #t)))
  60
  61   (pass-if "module-use! (duplicates local binding)"
  62     ;; Imported bindings can't override locale bindings.
  63     (let ((m (make-module))
  64           (import (make-module)))
  65       (module-define! m 'something 'something)
  66       (module-define! import 'something 'imported)
  67       (module-use! m import)
  68       (eq? (module-ref m 'something) 'something)))
  69
  70   (pass-if "module-locally-bound?"
  71      (let ((m (make-module))
  72            (import (make-module)))
  73        (module-define! m 'something #t)
  74        (module-define! import 'imported #t)
  75        (module-use! m import)
  76        (and (module-locally-bound? m 'something)
  77             (not (module-locally-bound? m 'imported)))))
  78
  79   (pass-if "module-{local-,}variable"
  80      (let ((m (make-module))
  81            (import (make-module)))
  82        (module-define! m 'local #t)
  83        (module-define! import 'imported #t)
  84        (module-use! m import)
  85        (and (module-local-variable m 'local)
  86             (not (module-local-variable m 'imported))
  87             (eq? (module-variable m 'local)
  88                  (module-local-variable m 'local))
  89             (eq? (module-local-variable import 'imported)
  90                  (module-variable m 'imported)))))
  91
  92   (pass-if "module-import-interface"
  93     (and (every? (lambda (sym iface)
  94                    (eq? (module-import-interface (current-module) sym)
  95                         iface))
  96                  '(current-module exception:bad-variable every)
  97                  (cons the-scm-module
  98                        (map resolve-interface
  99                             '((test-suite lib) (srfi srfi-1)))))
 100
 101          ;; For renamed bindings, a custom interface is used so we can't
 102          ;; check for equality with `eq?'.
 103          (every? (lambda (sym iface)
 104                    (let ((import
 105                           (module-import-interface (current-module) sym)))
 106                      (equal? (module-name import)
 107                              (module-name iface))))
 108                  '(s:make-stream s:stream-car s:stream-cdr)
 109                  (make-list 3 (resolve-interface '(ice-9 streams))))))
 110
 111   (pass-if "module-reverse-lookup"
 112     (let ((mods   '((srfi srfi-1) (test-suite lib)      (ice-9 streams)))
 113           (syms   '(every         exception:bad-variable make-stream))
 114           (locals '(every         exception:bad-variable s:make-stream)))
 115       (every? (lambda (var sym)
 116                 (eq? (module-reverse-lookup (current-module) var)
 117                      sym))
 118               (map module-variable
 119                    (map resolve-interface mods)
 120                    syms)
 121               locals))))
 122
 123
 124 \f
 125 ;;;
 126 ;;; Observers.
 127 ;;;
 128
 129 (with-test-prefix "observers"
 130
 131   (pass-if "weak observer invoked"
 132     (let* ((m (make-module))
 133            (invoked 0))
 134       (module-observe-weak m (lambda (mod)
 135                                (if (eq? mod m)
 136                                    (set! invoked (+ invoked 1)))))
 137       (module-define! m 'something 2)
 138       (module-define! m 'something-else 1)
 139       (= invoked 2)))
 140
 141   (pass-if "all weak observers invoked"
 142     ;; With the two-argument `module-observe-weak' available in previous
 143     ;; versions, the observer would get unregistered as soon as the observing
 144     ;; closure gets GC'd, making it impossible to use an anonymous lambda as
 145     ;; the observing procedure.
 146
 147     (let* ((m (make-module))
 148            (observer-count 500)
 149            (observer-ids (let loop ((i observer-count)
 150                                     (ids '()))
 151                            (if (= i 0)
 152                                ids
 153                                (loop (- i 1) (cons (make-module) ids)))))
 154            (observers-invoked (make-hash-table observer-count)))
 155
 156       ;; register weak observers
 157       (for-each (lambda (id)
 158                   (module-observe-weak m id
 159                                        (lambda (m)
 160                                          (hashq-set! observers-invoked
 161                                                      id #t))))
 162                 observer-ids)
 163
 164       (gc)
 165
 166       ;; invoke them
 167       (module-call-observers m)
 168
 169       ;; make sure all of them were invoked
 170       (->bool (every (lambda (id)
 171                        (hashq-ref observers-invoked id))
 172                      observer-ids))))
 173
 174   (pass-if "imported bindings updated"
 175     (let ((m (make-module))
 176           (imported (make-module)))
 177       ;; Beautify them, notably adding them a public interface.
 178       (beautify-user-module! m)
 179       (beautify-user-module! imported)
 180
 181       (module-use! m (module-public-interface imported))
 182       (module-define! imported 'imported-binding #t)
 183
 184       ;; At this point, `imported-binding' is local to IMPORTED.
 185       (and (not (module-variable m 'imported-binding))
 186            (begin
 187              ;; Export `imported-binding' from IMPORTED.
 188              (module-export! imported '(imported-binding))
 189
 190              ;; Make sure it is now visible from M.
 191              (module-ref m 'imported-binding))))))
 192
 193
 194 \f
 195 ;;;
 196 ;;; Duplicate bindings handling.
 197 ;;;
 198
 199 (with-test-prefix "duplicate bindings"
 200
 201   (pass-if "simple duplicate handler"
 202     ;; Import the same binding twice.
 203     (let* ((m (make-module))
 204            (import1 (make-module))
 205            (import2 (make-module))
 206            (handler-invoked? #f)
 207            (handler (lambda (module name int1 val1 int2 val2 var val)
 208                       (set! handler-invoked? #t)
 209                       ;; Keep the first binding.
 210                       (or var (module-local-variable int1 name)))))
 211
 212       (set-module-duplicates-handlers! m (list handler))
 213       (module-define! m 'something 'something)
 214       (set-module-name! import1 'imported-module-1)
 215       (set-module-name! import2 'imported-module-2)
 216       (module-define! import1 'imported 'imported-1)
 217       (module-define! import2 'imported 'imported-2)
 218       (module-use! m import1)
 219       (module-use! m import2)
 220       (and (eq? (module-ref m 'imported) 'imported-1)
 221            handler-invoked?))))
 222
 223 \f
 224 ;;;
 225 ;;; Lazy binder.
 226 ;;;
 227
 228 (with-test-prefix "lazy binder"
 229
 230   (pass-if "not invoked"
 231     (let ((m (make-module))
 232           (invoked? #f))
 233       (module-define! m 'something 2)
 234       (set-module-binder! m (lambda args (set! invoked? #t) #f))
 235       (and (module-ref m 'something)
 236            (not invoked?))))
 237
 238   (pass-if "not invoked (module-add!)"
 239     (let ((m (make-module))
 240           (invoked? #f))
 241       (set-module-binder! m (lambda args (set! invoked? #t) #f))
 242       (module-add! m 'something (make-variable 2))
 243       (and (module-ref m 'something)
 244            (not invoked?))))
 245
 246   (pass-if "invoked (module-ref)"
 247     (let ((m (make-module))
 248           (invoked? #f))
 249       (set-module-binder! m (lambda args (set! invoked? #t) #f))
 250       (false-if-exception (module-ref m 'something))
 251       invoked?))
 252
 253   (pass-if "invoked (module-define!)"
 254     (let ((m (make-module))
 255           (invoked? #f))
 256       (set-module-binder! m (lambda args (set! invoked? #t) #f))
 257       (module-define! m 'something 2)
 258       (and invoked?
 259            (eq? (module-ref m 'something) 2))))
 260
 261   (pass-if "honored (ref)"
 262     (let ((m (make-module))
 263           (invoked? #f)
 264           (value (cons 'x 'y)))
 265       (set-module-binder! m
 266                           (lambda (mod sym define?)
 267                             (set! invoked? #t)
 268                             (cond ((not (eq? m mod))
 269                                    (error "invalid module" mod))
 270                                   (define?
 271                                    (error "DEFINE? shouldn't be set"))
 272                                   (else
 273                                    (make-variable value)))))
 274       (and (eq? (module-ref m 'something) value)
 275            invoked?))))
 276
 277
 278 \f
 279 ;;;
 280 ;;; Higher-level features.
 281 ;;;
 282
 283 (with-test-prefix "autoload"
 284
 285   (pass-if "module-autoload!"
 286      (let ((m (make-module)))
 287        (module-autoload! m '(ice-9 q) '(make-q))
 288        (not (not (module-ref m 'make-q)))))
 289
 290   (pass-if "autoloaded"
 291      (catch #t
 292        (lambda ()
 293          ;; Simple autoloading.
 294          (eval '(begin
 295                   (define-module (test-autoload-one)
 296                     :autoload (ice-9 q) (make-q))
 297                   (not (not make-q)))
 298                (current-module)))
 299         (lambda (key . args)
 300           #f)))
 301
 302   ;; In Guile 1.8.0 this failed because the binder in
 303   ;; `make-autoload-interface' would try to remove the autoload interface
 304   ;; from the module's "uses" without making sure it is still part of these
 305   ;; "uses".
 306   ;;
 307   (pass-if "autoloaded+used"
 308      (catch #t
 309        (lambda ()
 310          (eval '(begin
 311                   (define-module (test-autoload-two)
 312                     :autoload (ice-9 q) (make-q)
 313                     :use-module (ice-9 q))
 314                   (not (not make-q)))
 315                (current-module)))
 316         (lambda (key . args)
 317           #f))))