test-suite/tests/rnrs-libraries.test

   1 ;;;; rnrs-libraries.test --- test library and import forms    -*- scheme -*-
   2 ;;;; Copyright (C) 2010, 2012 Free Software Foundation, Inc.
   3 ;;;;
   4 ;;;; This library is free software; you can redistribute it and/or
   5 ;;;; modify it under the terms of the GNU Lesser General Public
   6 ;;;; License as published by the Free Software Foundation; either
   7 ;;;; version 3 of the License, or (at your option) any later version.
   8 ;;;;
   9 ;;;; This library is distributed in the hope that it will be useful,
  10 ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  11 ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  12 ;;;; Lesser General Public License for more details.
  13 ;;;;
  14 ;;;; You should have received a copy of the GNU Lesser General Public
  15 ;;;; License along with this library; if not, write to the Free Software
  16 ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
  17
  18 (define-module (tests rnrs-libraries)
  19   #:use-module (test-suite lib))
  20
  21 ;; First, check that Guile modules are r6rs modules.
  22 ;;
  23 (with-test-prefix "ice-9 receive"
  24   (define iface #f)
  25
  26   (pass-if "import"
  27     (eval '(begin
  28              (import (ice-9 receive))
  29              #t)
  30           (current-module)))
  31
  32   (pass-if "resolve-interface"
  33     (module? (resolve-interface '(ice-9 receive))))
  34
  35   (set! iface (resolve-interface '(ice-9 receive)))
  36
  37   (pass-if "resolve-r6rs-interface"
  38     (eq? iface (resolve-r6rs-interface '(ice-9 receive))))
  39
  40   (pass-if "resolve-r6rs-interface (2)"
  41     (eq? iface (resolve-r6rs-interface '(library (ice-9 receive)))))
  42
  43   (pass-if "module uses"
  44     (and (memq iface (module-uses (current-module))) #t))
  45
  46   (pass-if "interface contents"
  47     (equal? '(receive)
  48             (hash-map->list (lambda (sym var) sym) (module-obarray iface))))
  49
  50   (pass-if "interface uses"
  51     (null? (module-uses iface)))
  52
  53   (pass-if "version"
  54     (or (not (module-version iface))
  55         (null? (module-version iface))))
  56
  57   (pass-if "calling receive from current env"
  58     (equal? (eval '(receive (a b) (values 10 32)
  59                      (+ a b))
  60                   (current-module))
  61             42)))
  62
  63
  64 ;; And check that r6rs modules are guile modules.
  65 ;;
  66 (with-test-prefix "rnrs-test-a"
  67   (define iface #f)
  68
  69   (pass-if "no double"
  70     (not (module-local-variable (current-module) 'double)))
  71
  72   (pass-if "import"
  73     (eval '(begin
  74              (import (tests rnrs-test-a))
  75              #t)
  76           (current-module)))
  77
  78   (pass-if "still no double"
  79     (not (module-local-variable (current-module) 'double)))
  80
  81   (pass-if "resolve-interface"
  82     (module? (resolve-interface '(tests rnrs-test-a))))
  83
  84   (set! iface (resolve-interface '(tests rnrs-test-a)))
  85
  86   (pass-if "resolve-interface (2)"
  87     (eq? iface (resolve-interface '(tests rnrs-test-a))))
  88
  89   (pass-if "resolve-r6rs-interface"
  90     (eq? iface (resolve-r6rs-interface '(tests rnrs-test-a))))
  91
  92   (pass-if "resolve-r6rs-interface (2)"
  93     (eq? iface (resolve-r6rs-interface '(library (tests rnrs-test-a)))))
  94
  95   (pass-if "module uses"
  96     (and (memq iface (module-uses (current-module))) #t))
  97
  98   (pass-if "interface contents"
  99     (equal? '(double)
 100             (hash-map->list (lambda (sym var) sym) (module-obarray iface))))
 101
 102   (pass-if "interface uses"
 103     (null? (module-uses iface)))
 104
 105   (pass-if "version"
 106     (or (not (module-version iface))
 107         (null? (module-version iface))))
 108
 109   (pass-if "calling double"
 110     (equal? ((module-ref iface 'double) 10)
 111             20))
 112
 113   (pass-if "calling double from current env"
 114     (equal? (eval '(double 20) (current-module))
 115             40)))
 116
 117 ;; Guile should ignore explicit phase specifications
 118 ;;
 119 (with-test-prefix "implicit phasing"
 120   (with-test-prefix "in library form"
 121     (pass-if "explicit phasing ignored"
 122       (import (for (guile) (meta -1))) #t))
 123
 124   (with-test-prefix "in library form"
 125     (pass-if "explicit phasing ignored"
 126       (save-module-excursion
 127        (lambda ()
 128          (library (test)
 129            (export)
 130            (import (for (guile) (meta -1))))
 131          #t)))))
 132
 133 ;; Now import features.
 134 ;;
 135 (with-test-prefix "import features"
 136   (define iface #f)
 137
 138   (with-test-prefix "only"
 139     (pass-if "contents"
 140       (equal? '(+)
 141               (hash-map->list
 142                (lambda (sym var) sym)
 143                (module-obarray (resolve-r6rs-interface '(only (guile) +)))))))
 144
 145   (with-test-prefix "except"
 146     (let ((bindings (hash-map->list
 147                      (lambda (sym var) sym)
 148                      (module-obarray
 149                       (resolve-r6rs-interface '(except (guile) +))))))
 150       (pass-if "contains"
 151         (equal? (length bindings)
 152                 (1- (hash-fold
 153                      (lambda (sym var n) (1+ n))
 154                      0
 155                      (module-obarray (resolve-interface '(guile)))))))
 156       (pass-if "does not contain"
 157         (not (memq '+ bindings)))))
 158
 159   (with-test-prefix "prefix"
 160     (let ((iface (resolve-r6rs-interface '(prefix (ice-9 q) q:))))
 161       (pass-if "contains"
 162         ((module-ref iface 'q:q?) ((module-ref iface 'q:make-q))))
 163       (pass-if "does not contain"
 164         (not (module-local-variable iface 'make-q)))))
 165
 166   (with-test-prefix "rename"
 167     (let ((iface (resolve-r6rs-interface
 168                   '(rename (only (guile) cons car cdr)
 169                            (cons snoc)
 170                            (car rac)
 171                            (cdr rdc)))))
 172       (pass-if "contents"
 173         (equal? '("rac" "rdc" "snoc")
 174                 (sort
 175                  (hash-map->list
 176                   (lambda (sym var) (symbol->string sym))
 177                   (module-obarray iface))
 178                  string<)))
 179       (pass-if "contains"
 180         (equal? 3 ((module-ref iface 'rac)
 181                    ((module-ref iface 'snoc) 3 4))))))
 182
 183   (with-test-prefix "srfi"
 184     (pass-if "renaming works"
 185       (eq? (resolve-interface '(srfi srfi-1))
 186            (resolve-r6rs-interface '(srfi :1)))
 187       (eq? (resolve-interface '(srfi srfi-1))
 188            (resolve-r6rs-interface '(srfi :1 lists)))))
 189
 190   (with-test-prefix "macro"
 191     (pass-if "multiple clauses"
 192       (eval '(begin
 193                (import (rnrs) (for (rnrs) expand) (rnrs))
 194                #t)
 195             (current-module)))))