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 ;;; Resolve-module.
 150 ;;;
 151
 152 (with-test-prefix "resolve-module"
 153
 154   (pass-if "#:ensure #t by default"
 155     (module? (resolve-module (list (gensym)))))
 156
 157   (pass-if "#:ensure #t explicitly"
 158     (module? (resolve-module (list (gensym)) #:ensure #t)))
 159
 160   (pass-if "#:ensure #f"
 161     (not (resolve-module (list (gensym)) #:ensure #f))))
 162
 163
 164 \f
 165 ;;;
 166 ;;; Observers.
 167 ;;;
 168
 169 (with-test-prefix "observers"
 170
 171   (pass-if "weak observer invoked"
 172     (let* ((m (make-module))
 173            (invoked 0))
 174       (module-observe-weak m (lambda (mod)
 175                                (if (eq? mod m)
 176                                    (set! invoked (+ invoked 1)))))
 177       (module-define! m 'something 2)
 178       (module-define! m 'something-else 1)
 179       (= invoked 2)))
 180
 181   (pass-if "all weak observers invoked"
 182     ;; With the two-argument `module-observe-weak' available in previous
 183     ;; versions, the observer would get unregistered as soon as the observing
 184     ;; closure gets GC'd, making it impossible to use an anonymous lambda as
 185     ;; the observing procedure.
 186
 187     (let* ((m (make-module))
 188            (observer-count 500)
 189            (observer-ids (let loop ((i observer-count)
 190                                     (ids '()))
 191                            (if (= i 0)
 192                                ids
 193                                (loop (- i 1) (cons (make-module) ids)))))
 194            (observers-invoked (make-hash-table observer-count)))
 195
 196       ;; register weak observers
 197       (for-each (lambda (id)
 198                   (module-observe-weak m id
 199                                        (lambda (m)
 200                                          (hashq-set! observers-invoked
 201                                                      id #t))))
 202                 observer-ids)
 203
 204       (gc)
 205
 206       ;; invoke them
 207       (module-call-observers m)
 208
 209       ;; make sure all of them were invoked
 210       (->bool (every (lambda (id)
 211                        (hashq-ref observers-invoked id))
 212                      observer-ids))))
 213
 214   (pass-if "imported bindings updated"
 215     (let ((m (make-module))
 216           (imported (make-module)))
 217       ;; Beautify them, notably adding them a public interface.
 218       (beautify-user-module! m)
 219       (beautify-user-module! imported)
 220
 221       (module-use! m (module-public-interface imported))
 222       (module-define! imported 'imported-binding #t)
 223
 224       ;; At this point, `imported-binding' is local to IMPORTED.
 225       (and (not (module-variable m 'imported-binding))
 226            (begin
 227              ;; Export `imported-binding' from IMPORTED.
 228              (module-export! imported '(imported-binding))
 229
 230              ;; Make sure it is now visible from M.
 231              (module-ref m 'imported-binding))))))
 232
 233
 234 \f
 235 ;;;
 236 ;;; Duplicate bindings handling.
 237 ;;;
 238
 239 (with-test-prefix "duplicate bindings"
 240
 241   (pass-if "simple duplicate handler"
 242     ;; Import the same binding twice.
 243     (let* ((m (make-module))
 244            (import1 (make-module))
 245            (import2 (make-module))
 246            (handler-invoked? #f)
 247            (handler (lambda (module name int1 val1 int2 val2 var val)
 248                       (set! handler-invoked? #t)
 249                       ;; Keep the first binding.
 250                       (or var (module-local-variable int1 name)))))
 251
 252       (set-module-duplicates-handlers! m (list handler))
 253       (module-define! m 'something 'something)
 254       (set-module-name! import1 'imported-module-1)
 255       (set-module-name! import2 'imported-module-2)
 256       (module-define! import1 'imported 'imported-1)
 257       (module-define! import2 'imported 'imported-2)
 258       (module-use! m import1)
 259       (module-use! m import2)
 260       (and (eq? (module-ref m 'imported) 'imported-1)
 261            handler-invoked?))))
 262
 263 \f
 264 ;;;
 265 ;;; Lazy binder.
 266 ;;;
 267
 268 (with-test-prefix "lazy binder"
 269
 270   (pass-if "not invoked"
 271     (let ((m (make-module))
 272           (invoked? #f))
 273       (module-define! m 'something 2)
 274       (set-module-binder! m (lambda args (set! invoked? #t) #f))
 275       (and (module-ref m 'something)
 276            (not invoked?))))
 277
 278   (pass-if "not invoked (module-add!)"
 279     (let ((m (make-module))
 280           (invoked? #f))
 281       (set-module-binder! m (lambda args (set! invoked? #t) #f))
 282       (module-add! m 'something (make-variable 2))
 283       (and (module-ref m 'something)
 284            (not invoked?))))
 285
 286   (pass-if "invoked (module-ref)"
 287     (let ((m (make-module))
 288           (invoked? #f))
 289       (set-module-binder! m (lambda args (set! invoked? #t) #f))
 290       (false-if-exception (module-ref m 'something))
 291       invoked?))
 292
 293   (pass-if "invoked (module-define!)"
 294     (let ((m (make-module))
 295           (invoked? #f))
 296       (set-module-binder! m (lambda args (set! invoked? #t) #f))
 297       (module-define! m 'something 2)
 298       (and invoked?
 299            (eq? (module-ref m 'something) 2))))
 300
 301   (pass-if "honored (ref)"
 302     (let ((m (make-module))
 303           (invoked? #f)
 304           (value (cons 'x 'y)))
 305       (set-module-binder! m
 306                           (lambda (mod sym define?)
 307                             (set! invoked? #t)
 308                             (cond ((not (eq? m mod))
 309                                    (error "invalid module" mod))
 310                                   (define?
 311                                    (error "DEFINE? shouldn't be set"))
 312                                   (else
 313                                    (make-variable value)))))
 314       (and (eq? (module-ref m 'something) value)
 315            invoked?))))
 316
 317
 318 \f
 319 ;;;
 320 ;;; Higher-level features.
 321 ;;;
 322
 323 (with-test-prefix "autoload"
 324
 325   (pass-if "module-autoload!"
 326      (let ((m (make-module)))
 327        (module-autoload! m '(ice-9 q) '(make-q))
 328        (not (not (module-ref m 'make-q)))))
 329
 330   (pass-if "autoloaded"
 331      (catch #t
 332        (lambda ()
 333          ;; Simple autoloading.
 334          (eval '(begin
 335                   (define-module (test-autoload-one)
 336                     :autoload (ice-9 q) (make-q))
 337                   (not (not make-q)))
 338                (current-module)))
 339         (lambda (key . args)
 340           #f)))
 341
 342   ;; In Guile 1.8.0 this failed because the binder in
 343   ;; `make-autoload-interface' would try to remove the autoload interface
 344   ;; from the module's "uses" without making sure it is still part of these
 345   ;; "uses".
 346   ;;
 347   (pass-if "autoloaded+used"
 348      (catch #t
 349        (lambda ()
 350          (eval '(begin
 351                   (define-module (test-autoload-two)
 352                     :autoload (ice-9 q) (make-q)
 353                     :use-module (ice-9 q))
 354                   (not (not make-q)))
 355                (current-module)))
 356         (lambda (key . args)
 357           #f))))
 358
 359 \f
 360 ;;;
 361 ;;; R6RS compatibility
 362 ;;;
 363
 364 (with-test-prefix "module versions"
 365
 366   (pass-if "version-matches? for matching versions"
 367     (version-matches? '(1 2 3) '(1 2 3)))
 368
 369   (pass-if "version-matches? for non-matching versions"
 370     (not (version-matches? '(3 2 1) '(1 2 3))))
 371
 372   (pass-if "version-matches? against more specified version"
 373     (version-matches? '(1 2) '(1 2 3)))
 374
 375   (pass-if "version-matches? against less specified version"
 376     (not (version-matches? '(1 2 3) '(1 2)))))