test-suite/tests/modules.test

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