test-suite/tests/modules.test

   1 ;;;; modules.test --- exercise some of guile's module stuff -*- scheme -*-
   2
   3 ;;;; Copyright (C) 2006, 2007, 2009, 2010, 2011 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 3 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 "modules don't remain anonymous"
  38     ;; This is a requirement for `psyntax': it stores module names and relies
  39     ;; on being able to `resolve-module' them.
  40     (let ((m (make-module)))
  41       (and (module-name m)
  42            (eq? m (resolve-module (module-name m))))))
  43
  44   (pass-if "module-add!"
  45     (let ((m (make-module))
  46           (value (cons 'x 'y)))
  47       (module-add! m 'something (make-variable value))
  48       (eq? (module-ref m 'something) value)))
  49
  50   (pass-if "module-define!"
  51     (let ((m (make-module))
  52           (value (cons 'x 'y)))
  53       (module-define! m 'something value)
  54       (eq? (module-ref m 'something) value)))
  55
  56   (pass-if "module-use!"
  57     (let ((m (make-module))
  58           (import (make-module)))
  59       (module-define! m 'something 'something)
  60       (module-define! import 'imported 'imported)
  61       (module-use! m import)
  62       (and (eq? (module-ref m 'something) 'something)
  63            (eq? (module-ref m 'imported)  'imported)
  64            (module-local-variable m 'something)
  65            (not (module-local-variable m 'imported))
  66            #t)))
  67
  68   (pass-if "module-use! (duplicates local binding)"
  69     ;; Imported bindings can't override locale bindings.
  70     (let ((m (make-module))
  71           (import (make-module)))
  72       (module-define! m 'something 'something)
  73       (module-define! import 'something 'imported)
  74       (module-use! m import)
  75       (eq? (module-ref m 'something) 'something)))
  76
  77   (pass-if "module-locally-bound?"
  78      (let ((m (make-module))
  79            (import (make-module)))
  80        (module-define! m 'something #t)
  81        (module-define! import 'imported #t)
  82        (module-use! m import)
  83        (and (module-locally-bound? m 'something)
  84             (not (module-locally-bound? m 'imported)))))
  85
  86   (pass-if "module-{local-,}variable"
  87      (let ((m (make-module))
  88            (import (make-module)))
  89        (module-define! m 'local #t)
  90        (module-define! import 'imported #t)
  91        (module-use! m import)
  92        (and (module-local-variable m 'local)
  93             (not (module-local-variable m 'imported))
  94             (eq? (module-variable m 'local)
  95                  (module-local-variable m 'local))
  96             (eq? (module-local-variable import 'imported)
  97                  (module-variable m 'imported)))))
  98
  99   (pass-if "module-import-interface"
 100     (and (every? (lambda (sym iface)
 101                    (eq? (module-import-interface (current-module) sym)
 102                         iface))
 103                  '(current-module exception:bad-variable every)
 104                  (cons the-scm-module
 105                        (map resolve-interface
 106                             '((test-suite lib) (srfi srfi-1)))))
 107
 108          ;; For renamed bindings, a custom interface is used so we can't
 109          ;; check for equality with `eq?'.
 110          (every? (lambda (sym iface)
 111                    (let ((import
 112                           (module-import-interface (current-module) sym)))
 113                      (equal? (module-name import)
 114                              (module-name iface))))
 115                  '(s:make-stream s:stream-car s:stream-cdr)
 116                  (make-list 3 (resolve-interface '(ice-9 streams))))))
 117
 118   (pass-if "module-reverse-lookup"
 119     (let ((mods   '((srfi srfi-1) (test-suite lib)      (ice-9 streams)))
 120           (syms   '(every         exception:bad-variable make-stream))
 121           (locals '(every         exception:bad-variable s:make-stream)))
 122       (every? (lambda (var sym)
 123                 (eq? (module-reverse-lookup (current-module) var)
 124                      sym))
 125               (map module-variable
 126                    (map resolve-interface mods)
 127                    syms)
 128               locals)))
 129
 130   (pass-if "module-reverse-lookup [pre-module-obarray]"
 131     (let ((var (module-variable (current-module) 'string?)))
 132       (eq? 'string? (module-reverse-lookup #f var))))
 133
 134   (pass-if-exception "module-reverse-lookup [wrong-type-arg]"
 135     exception:wrong-type-arg
 136     (module-reverse-lookup (current-module) 'foo))
 137
 138   (pass-if "the-root-module"
 139     (eq? (module-public-interface the-root-module) the-scm-module))
 140
 141   (pass-if "the-scm-module"
 142     ;; THE-SCM-MODULE is its own public interface.  See
 143     ;; <https://savannah.gnu.org/bugs/index.php?30623>.
 144     (eq? (module-public-interface the-scm-module) the-scm-module)))
 145
 146
 147 \f
 148 ;;;
 149 ;;; module-use! / module-use-interfaces!
 150 ;;;
 151 (with-test-prefix "module-use"
 152   (let ((m (make-module)))
 153     (pass-if "no uses initially"
 154       (null? (module-uses m)))
 155
 156     (pass-if "using ice-9 q"
 157       (begin
 158         (module-use! m (resolve-interface '(ice-9 q)))
 159         (equal? (module-uses m)
 160                 (list (resolve-interface '(ice-9 q))))))
 161
 162     (pass-if "using ice-9 q again"
 163       (begin
 164         (module-use! m (resolve-interface '(ice-9 q)))
 165         (equal? (module-uses m)
 166                 (list (resolve-interface '(ice-9 q))))))
 167
 168     (pass-if "using ice-9 ftw"
 169       (begin
 170         (module-use-interfaces! m (list (resolve-interface '(ice-9 ftw))))
 171         (equal? (module-uses m)
 172                 (list (resolve-interface '(ice-9 q))
 173                       (resolve-interface '(ice-9 ftw))))))
 174
 175     (pass-if "using ice-9 ftw again"
 176       (begin
 177         (module-use-interfaces! m (list (resolve-interface '(ice-9 ftw))))
 178         (equal? (module-uses m)
 179                 (list (resolve-interface '(ice-9 q))
 180                       (resolve-interface '(ice-9 ftw))))))
 181
 182     (pass-if "using ice-9 control twice"
 183       (begin
 184         (module-use-interfaces! m (list (resolve-interface '(ice-9 control))
 185                                         (resolve-interface '(ice-9 control))))
 186         (equal? (module-uses m)
 187                 (list (resolve-interface '(ice-9 q))
 188                       (resolve-interface '(ice-9 ftw))
 189                       (resolve-interface '(ice-9 control))))))))
 190
 191
 192 \f
 193 ;;;
 194 ;;; Resolve-module.
 195 ;;;
 196
 197 (with-test-prefix "resolve-module"
 198
 199   (pass-if "#:ensure #t by default"
 200     (module? (resolve-module (list (gensym)))))
 201
 202   (pass-if "#:ensure #t explicitly"
 203     (module? (resolve-module (list (gensym)) #:ensure #t)))
 204
 205   (pass-if "#:ensure #f"
 206     (not (resolve-module (list (gensym)) #:ensure #f))))
 207
 208
 209 \f
 210 ;;;
 211 ;;; Observers.
 212 ;;;
 213
 214 (with-test-prefix "observers"
 215
 216   (pass-if "weak observer invoked"
 217     (let* ((m (make-module))
 218            (invoked 0))
 219       (module-observe-weak m (lambda (mod)
 220                                (if (eq? mod m)
 221                                    (set! invoked (+ invoked 1)))))
 222       (module-define! m 'something 2)
 223       (module-define! m 'something-else 1)
 224       (= invoked 2)))
 225
 226   (pass-if "all weak observers invoked"
 227     ;; With the two-argument `module-observe-weak' available in previous
 228     ;; versions, the observer would get unregistered as soon as the observing
 229     ;; closure gets GC'd, making it impossible to use an anonymous lambda as
 230     ;; the observing procedure.
 231
 232     (let* ((m (make-module))
 233            (observer-count 500)
 234            (observer-ids (let loop ((i observer-count)
 235                                     (ids '()))
 236                            (if (= i 0)
 237                                ids
 238                                (loop (- i 1) (cons (make-module) ids)))))
 239            (observers-invoked (make-hash-table observer-count)))
 240
 241       ;; register weak observers
 242       (for-each (lambda (id)
 243                   (module-observe-weak m id
 244                                        (lambda (m)
 245                                          (hashq-set! observers-invoked
 246                                                      id #t))))
 247                 observer-ids)
 248
 249       (gc)
 250
 251       ;; invoke them
 252       (module-call-observers m)
 253
 254       ;; make sure all of them were invoked
 255       (->bool (every (lambda (id)
 256                        (hashq-ref observers-invoked id))
 257                      observer-ids))))
 258
 259   (pass-if "imported bindings updated"
 260     (let ((m (make-module))
 261           (imported (make-module)))
 262       ;; Beautify them, notably adding them a public interface.
 263       (beautify-user-module! m)
 264       (beautify-user-module! imported)
 265
 266       (module-use! m (module-public-interface imported))
 267       (module-define! imported 'imported-binding #t)
 268
 269       ;; At this point, `imported-binding' is local to IMPORTED.
 270       (and (not (module-variable m 'imported-binding))
 271            (begin
 272              ;; Export `imported-binding' from IMPORTED.
 273              (module-export! imported '(imported-binding))
 274
 275              ;; Make sure it is now visible from M.
 276              (module-ref m 'imported-binding))))))
 277
 278
 279 \f
 280 ;;;
 281 ;;; Duplicate bindings handling.
 282 ;;;
 283
 284 (with-test-prefix "duplicate bindings"
 285
 286   (pass-if "simple duplicate handler"
 287     ;; Import the same binding twice.
 288     (let* ((m (make-module))
 289            (import1 (make-module))
 290            (import2 (make-module))
 291            (handler-invoked? #f)
 292            (handler (lambda (module name int1 val1 int2 val2 var val)
 293                       ;; We expect both VAR and VAL to be #f, as there
 294                       ;; is no previous binding for 'imported in M.
 295                       (if var (error "unexpected var" var))
 296                       (if val (error "unexpected val" val))
 297                       (set! handler-invoked? #t)
 298                       ;; Keep the first binding.
 299                       (or var (module-local-variable int1 name)))))
 300
 301       (set-module-duplicates-handlers! m (list handler))
 302       (module-define! m 'something 'something)
 303       (set-module-name! import1 'imported-module-1)
 304       (set-module-name! import2 'imported-module-2)
 305       (module-define! import1 'imported 'imported-1)
 306       (module-define! import2 'imported 'imported-2)
 307       (module-use! m import1)
 308       (module-use! m import2)
 309       (and (eq? (module-ref m 'imported) 'imported-1)
 310            handler-invoked?))))
 311
 312 \f
 313 ;;;
 314 ;;; Lazy binder.
 315 ;;;
 316
 317 (with-test-prefix "lazy binder"
 318
 319   (pass-if "not invoked"
 320     (let ((m (make-module))
 321           (invoked? #f))
 322       (module-define! m 'something 2)
 323       (set-module-binder! m (lambda args (set! invoked? #t) #f))
 324       (and (module-ref m 'something)
 325            (not invoked?))))
 326
 327   (pass-if "not invoked (module-add!)"
 328     (let ((m (make-module))
 329           (invoked? #f))
 330       (set-module-binder! m (lambda args (set! invoked? #t) #f))
 331       (module-add! m 'something (make-variable 2))
 332       (and (module-ref m 'something)
 333            (not invoked?))))
 334
 335   (pass-if "invoked (module-ref)"
 336     (let ((m (make-module))
 337           (invoked? #f))
 338       (set-module-binder! m (lambda args (set! invoked? #t) #f))
 339       (false-if-exception (module-ref m 'something))
 340       invoked?))
 341
 342   (pass-if "invoked (module-define!)"
 343     (let ((m (make-module))
 344           (invoked? #f))
 345       (set-module-binder! m (lambda args (set! invoked? #t) #f))
 346       (module-define! m 'something 2)
 347       (and invoked?
 348            (eqv? (module-ref m 'something) 2))))
 349
 350   (pass-if "honored (ref)"
 351     (let ((m (make-module))
 352           (invoked? #f)
 353           (value (cons 'x 'y)))
 354       (set-module-binder! m
 355                           (lambda (mod sym define?)
 356                             (set! invoked? #t)
 357                             (cond ((not (eq? m mod))
 358                                    (error "invalid module" mod))
 359                                   (define?
 360                                    (error "DEFINE? shouldn't be set"))
 361                                   (else
 362                                    (make-variable value)))))
 363       (and (eq? (module-ref m 'something) value)
 364            invoked?))))
 365
 366
 367 \f
 368 ;;;
 369 ;;; Higher-level features.
 370 ;;;
 371
 372 (with-test-prefix "autoload"
 373
 374   (pass-if "module-autoload!"
 375      (let ((m (make-module)))
 376        (module-autoload! m '(ice-9 q) '(make-q))
 377        (not (not (module-ref m 'make-q)))))
 378
 379   (pass-if "autoloaded"
 380      (catch #t
 381        (lambda ()
 382          ;; Simple autoloading.
 383          (eval '(begin
 384                   (define-module (test-autoload-one)
 385                     :autoload (ice-9 q) (make-q))
 386                   (not (not make-q)))
 387                (current-module)))
 388         (lambda (key . args)
 389           #f)))
 390
 391   ;; In Guile 1.8.0 this failed because the binder in
 392   ;; `make-autoload-interface' would try to remove the autoload interface
 393   ;; from the module's "uses" without making sure it is still part of these
 394   ;; "uses".
 395   ;;
 396   (pass-if "autoloaded+used"
 397      (catch #t
 398        (lambda ()
 399          (eval '(begin
 400                   (define-module (test-autoload-two)
 401                     :autoload (ice-9 q) (make-q)
 402                     :use-module (ice-9 q))
 403                   (not (not make-q)))
 404                (current-module)))
 405         (lambda (key . args)
 406           #f))))
 407
 408 \f
 409 ;;;
 410 ;;; R6RS compatibility
 411 ;;;
 412
 413 (with-test-prefix "module versions"
 414
 415   (pass-if "version-matches? for matching versions"
 416     (version-matches? '(1 2 3) '(1 2 3)))
 417
 418   (pass-if "version-matches? for non-matching versions"
 419     (not (version-matches? '(3 2 1) '(1 2 3))))
 420
 421   (pass-if "version-matches? against more specified version"
 422     (version-matches? '(1 2) '(1 2 3)))
 423
 424   (pass-if "version-matches? against less specified version"
 425     (not (version-matches? '(1 2 3) '(1 2)))))