summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--test-suite/Makefile.am8
-rw-r--r--test-suite/tests/rnrs-libraries.test171
-rw-r--r--test-suite/tests/rnrs-test-a.scm25
3 files changed, 203 insertions, 1 deletions
diff --git a/test-suite/Makefile.am b/test-suite/Makefile.am
index be66dea54..4444be498 100644
--- a/test-suite/Makefile.am
+++ b/test-suite/Makefile.am
@@ -76,6 +76,7 @@ SCM_TESTS = tests/00-initial-env.test \
tests/r4rs.test \
tests/r5rs_pitfall.test \
tests/r6rs-ports.test \
+ tests/rnrs-libraries.test \
tests/ramap.test \
tests/reader.test \
tests/receive.test \
@@ -122,7 +123,12 @@ SCM_TESTS = tests/00-initial-env.test \
tests/vlist.test \
tests/weaks.test
-EXTRA_DIST = guile-test lib.scm $(SCM_TESTS) ChangeLog-2008
+EXTRA_DIST = \
+ guile-test \
+ lib.scm \
+ $(SCM_TESTS) \
+ tests/rnrs-test-a.scm
+ ChangeLog-2008
# Test suite of Dominique Boucher's `lalr-scm'.
diff --git a/test-suite/tests/rnrs-libraries.test b/test-suite/tests/rnrs-libraries.test
new file mode 100644
index 000000000..9f6f6c1a8
--- /dev/null
+++ b/test-suite/tests/rnrs-libraries.test
@@ -0,0 +1,171 @@
+;;;; rnrs-libraries.test --- test library and import forms -*- scheme -*-
+;;;; Copyright (C) 2010 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 (test-suite 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 (test-suite 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 '(test-suite tests rnrs-test-a))))
+
+ (set! iface (resolve-interface '(test-suite tests rnrs-test-a)))
+
+ (pass-if "resolve-interface (2)"
+ (eq? iface (resolve-interface '(test-suite tests rnrs-test-a))))
+
+ (pass-if "resolve-r6rs-interface"
+ (eq? iface (resolve-r6rs-interface '(test-suite tests rnrs-test-a))))
+
+ (pass-if "resolve-r6rs-interface (2)"
+ (eq? iface (resolve-r6rs-interface '(library (test-suite 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)))
+
+
+;; 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"
+ (let ((bindings (hash-map->list
+ (lambda (sym var) sym)
+ (module-obarray
+ (resolve-r6rs-interface '(except (guile) +))))))
+ (pass-if "contains"
+ (equal? (length bindings)
+ (1- (hash-fold
+ (lambda (sym var n) (1+ n))
+ 0
+ (module-obarray (resolve-interface '(guile)))))))
+ (pass-if "does not contain"
+ (not (memq '+ bindings)))))
+
+ (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))))))
diff --git a/test-suite/tests/rnrs-test-a.scm b/test-suite/tests/rnrs-test-a.scm
new file mode 100644
index 000000000..7b46fd63c
--- /dev/null
+++ b/test-suite/tests/rnrs-test-a.scm
@@ -0,0 +1,25 @@
+;;; test of defining rnrs libraries
+
+;; Copyright (C) 2010 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
+
+
+(library (test-suite tests rnrs-test-a)
+ (export double)
+ (import (guile))
+
+ (define (double x)
+ (* x 2)))