123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218 |
- ;;;; rnrs-libraries.test --- test library and import forms -*- scheme -*-
- ;;;; Copyright (C) 2010, 2012 Free Software Foundation, Inc.
- ;;;;
- ;;;; This library is free software; you can redistribute it and/or
- ;;;; modify it under the terms of the GNU Lesser General Public
- ;;;; License as published by the Free Software Foundation; either
- ;;;; version 3 of the License, or (at your option) any later version.
- ;;;;
- ;;;; This library is distributed in the hope that it will be useful,
- ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
- ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
- ;;;; Lesser General Public License for more details.
- ;;;;
- ;;;; You should have received a copy of the GNU Lesser General Public
- ;;;; License along with this library; if not, write to the Free Software
- ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
- (define-module (tests rnrs-libraries)
- #:use-module (test-suite lib))
- ;; First, check that Guile modules are r6rs modules.
- ;;
- (with-test-prefix "ice-9 receive"
- (define iface #f)
- (pass-if "import"
- (eval '(begin
- (import (ice-9 receive))
- #t)
- (current-module)))
- (pass-if "resolve-interface"
- (module? (resolve-interface '(ice-9 receive))))
- (set! iface (resolve-interface '(ice-9 receive)))
- (pass-if "resolve-r6rs-interface"
- (eq? iface (resolve-r6rs-interface '(ice-9 receive))))
- (pass-if "resolve-r6rs-interface (2)"
- (eq? iface (resolve-r6rs-interface '(library (ice-9 receive)))))
- (pass-if "module uses"
- (and (memq iface (module-uses (current-module))) #t))
- (pass-if "interface contents"
- (equal? '(receive)
- (hash-map->list (lambda (sym var) sym) (module-obarray iface))))
- (pass-if "interface uses"
- (null? (module-uses iface)))
- (pass-if "version"
- (or (not (module-version iface))
- (null? (module-version iface))))
- (pass-if "calling receive from current env"
- (equal? (eval '(receive (a b) (values 10 32)
- (+ a b))
- (current-module))
- 42)))
- ;; And check that r6rs modules are guile modules.
- ;;
- (with-test-prefix "rnrs-test-a"
- (define iface #f)
- (pass-if "no double"
- (not (module-local-variable (current-module) 'double)))
- (pass-if "import"
- (eval '(begin
- (import (tests rnrs-test-a))
- #t)
- (current-module)))
- (pass-if "still no double"
- (not (module-local-variable (current-module) 'double)))
-
- (pass-if "resolve-interface"
- (module? (resolve-interface '(tests rnrs-test-a))))
- (set! iface (resolve-interface '(tests rnrs-test-a)))
- (pass-if "resolve-interface (2)"
- (eq? iface (resolve-interface '(tests rnrs-test-a))))
- (pass-if "resolve-r6rs-interface"
- (eq? iface (resolve-r6rs-interface '(tests rnrs-test-a))))
- (pass-if "resolve-r6rs-interface (2)"
- (eq? iface (resolve-r6rs-interface '(library (tests rnrs-test-a)))))
- (pass-if "module uses"
- (and (memq iface (module-uses (current-module))) #t))
- (pass-if "interface contents"
- (equal? '(double)
- (hash-map->list (lambda (sym var) sym) (module-obarray iface))))
- (pass-if "interface uses"
- (null? (module-uses iface)))
- (pass-if "version"
- (or (not (module-version iface))
- (null? (module-version iface))))
- (pass-if "calling double"
- (equal? ((module-ref iface 'double) 10)
- 20))
- (pass-if "calling double from current env"
- (equal? (eval '(double 20) (current-module))
- 40)))
- ;; Guile should ignore explicit phase specifications
- ;;
- (with-test-prefix "implicit phasing"
- (with-test-prefix "in library form"
- (pass-if "explicit phasing ignored"
- (import (for (guile) (meta -1))) #t))
- (with-test-prefix "in library form"
- (pass-if "explicit phasing ignored"
- (save-module-excursion
- (lambda ()
- (library (test)
- (export)
- (import (for (guile) (meta -1))))
- #t)))))
- ;; Now import features.
- ;;
- (with-test-prefix "import features"
- (define iface #f)
-
- (with-test-prefix "only"
- (pass-if "contents"
- (equal? '(+)
- (hash-map->list
- (lambda (sym var) sym)
- (module-obarray (resolve-r6rs-interface '(only (guile) +)))))))
-
- (with-test-prefix "except"
- ;; In Guile, interfaces can use other interfaces. For R6RS modules
- ;; that are imported as-is (without `except', etc), Guile will just
- ;; import them as-is. `(guile)' is one of those modules. For other
- ;; import kinds like `except', the resolve-r6rs-interface code will
- ;; go binding-by-binding and create a new flat interface. Anyway,
- ;; that means to compare an except interface with (guile), we're
- ;; comparing a flat interface with a deep interface, so we need to
- ;; do more work to get the set of bindings in (guile), knowing also
- ;; that some of those bindings could be duplicates.
- (define (bound-name-count mod)
- (define (module-for-each/nonlocal f mod)
- (define (module-and-uses mod)
- (let lp ((in (list mod)) (out '()))
- (cond
- ((null? in) (reverse out))
- ((memq (car in) out) (lp (cdr in) out))
- (else (lp (append (module-uses (car in)) (cdr in))
- (cons (car in) out))))))
- (for-each (lambda (mod)
- (module-for-each f mod))
- (module-and-uses mod)))
- (hash-fold (lambda (sym var n) (1+ n))
- 0
- (let ((t (make-hash-table)))
- (module-for-each/nonlocal (lambda (sym var)
- (hashq-set! t sym var))
- mod)
- t)))
- (let ((except-+ (resolve-r6rs-interface '(except (guile) +))))
- (pass-if "contains"
- (equal? (bound-name-count except-+)
- (1- (bound-name-count (resolve-interface '(guile))))))
- (pass-if "does not contain"
- (not (module-variable except-+ '+)))))
- (with-test-prefix "prefix"
- (let ((iface (resolve-r6rs-interface '(prefix (ice-9 q) q:))))
- (pass-if "contains"
- ((module-ref iface 'q:q?) ((module-ref iface 'q:make-q))))
- (pass-if "does not contain"
- (not (module-local-variable iface 'make-q)))))
- (with-test-prefix "rename"
- (let ((iface (resolve-r6rs-interface
- '(rename (only (guile) cons car cdr)
- (cons snoc)
- (car rac)
- (cdr rdc)))))
- (pass-if "contents"
- (equal? '("rac" "rdc" "snoc")
- (sort
- (hash-map->list
- (lambda (sym var) (symbol->string sym))
- (module-obarray iface))
- string<)))
- (pass-if "contains"
- (equal? 3 ((module-ref iface 'rac)
- ((module-ref iface 'snoc) 3 4))))))
- (with-test-prefix "srfi"
- (pass-if "renaming works"
- (eq? (resolve-interface '(srfi srfi-1))
- (resolve-r6rs-interface '(srfi :1)))
- (eq? (resolve-interface '(srfi srfi-1))
- (resolve-r6rs-interface '(srfi :1 lists)))))
- (with-test-prefix "macro"
- (pass-if "multiple clauses"
- (eval '(begin
- (import (rnrs) (for (rnrs) expand) (rnrs))
- #t)
- (current-module)))))
|