test-suite/tests/modules.test

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