[Top][All Lists]
[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] GNU Guile branch, master, updated. release_1-9-10-168-gb
|
From: |
Julian Graham |
|
Subject: |
[Guile-commits] GNU Guile branch, master, updated. release_1-9-10-168-gb766109 |
|
Date: |
Fri, 21 May 2010 01:46:50 +0000 |
This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "GNU Guile".
http://git.savannah.gnu.org/cgit/guile.git/commit/?id=b766109224c8b6ddb42acca419ce6b0b234a386d
The branch, master has been updated
via b766109224c8b6ddb42acca419ce6b0b234a386d (commit)
via 2470bda772e6b93f037130ba266a4ad535ee655e (commit)
via 5f29551e4d5547027125c9850498fb9921e4f64d (commit)
via d9c40da98337676e6d45848be7ec1353bb66655e (commit)
via 2d56d2dfdddd4e1ec424ad56052a0e17aef112cd (commit)
via 8794d769bdafb18ddc962c1963041e8c9dd10b36 (commit)
via d3094cf2fa443ae97575fd6ee041574b68f79ee8 (commit)
via b01818d752d272c3a65dfd913e77d01540e21657 (commit)
via 15ce5cafbc30062b94da2f30d4c39e16ea48de1f (commit)
via bc4db0905f84680572f1528a7911fcee33d2f304 (commit)
via ace75ab775e0eb0eebd4943a5c709ee36fe492eb (commit)
via 0c7398a7dc471bc7b9f09b65dba7e33f4ac88af5 (commit)
via 2359a9a49ef4dd70e112d517b11b05840440b522 (commit)
via a725e27bdaeef13c14006f46200130467a5571d5 (commit)
via 3d5bc1ad6f2eed56acddf9c2fe2d4ddf548be4f0 (commit)
via d1c83d388aa35977a612eceda4cf52ef891cab0b (commit)
via a7ada161878d42b194660990473ccfbc86e59543 (commit)
via 0113507eee0cc8e6250958470ab4b21f32c42bcd (commit)
via 805b4179bfe44506e6dcd3e62c6868659ffdafb6 (commit)
via adf73f9ab45f5836090d2a6a76ebd534e3bad818 (commit)
via 949532501a8fed63595e3e15a17eec0069e822ff (commit)
via 2b95784c8dd29a8bb75e66f2a3c0a77f777fe61a (commit)
via 04ba959921cd8a6a69e367d4f163c45d8b36e199 (commit)
via f797da47f8a302ee80772c11f701c1abf45e9467 (commit)
via 00532e348ed773c9e0a564dd6ce71e203eded9d6 (commit)
via b3961e7ab37d367777924a8d0dd43b2fe35ed673 (commit)
via 60b240e9ae603ade8b13164f05fb208d9f4c0396 (commit)
via 55684b5e3b5ceab5b87c46fc9dd2b78637ff13e1 (commit)
via 8b58ea453916338a60b8e8cc8d785c82a801b4ae (commit)
via ce543a9f70cf4772c3a491921686ed7d5674b984 (commit)
via aa439b3908b71f268f8a8d091d8143edebb5cde7 (commit)
via bf745816f21d4d0d13889e97ae18a1171abda4a7 (commit)
via 2a435f1f911bf7ce4ab55414d2bd76e5c95cb182 (commit)
from 71194485d67733cc47c642832b2c9e1de97b6c12 (commit)
Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.
- Log -----------------------------------------------------------------
commit b766109224c8b6ddb42acca419ce6b0b234a386d
Author: Julian Graham <address@hidden>
Date: Thu May 20 21:46:12 2010 -0400
Explicitly import `*unspecified*' to support R6RS library purification
enhancements.
* module/rnrs/6/hashtables.scm: Add explicit import for `*unspecified*'.
commit 2470bda772e6b93f037130ba266a4ad535ee655e
Author: Julian Graham <address@hidden>
Date: Thu May 20 09:33:39 2010 -0400
Explicitly import `@@' to support R6RS library purification enhancements
on `master'.
* module/rnrs/6/conditions.scm:
* module/rnrs/6/exceptions.scm:
* module/rnrs/6/files.scm:
* module/rnrs/6/hashtables.scm:
* module/rnrs/io/6/simple.scm:
* module/rnrs/records/6/inspection.scm: Add explicit import for `@@'.
commit 5f29551e4d5547027125c9850498fb9921e4f64d
Author: Julian Graham <address@hidden>
Date: Thu May 13 21:41:38 2010 -0400
Fix broken imports in `(rnrs r5rs)'.
* module/rnrs/6/r5rs.scm (imports): Import `null-environment' from
`(ice-9 safe-r5rs)'; import `scheme-report-environment' from
`(ice-9 r5rs)'.
commit d9c40da98337676e6d45848be7ec1353bb66655e
Author: Julian Graham <address@hidden>
Date: Sat Apr 10 01:01:46 2010 -0400
Fix incorrect export names in `(rnrs io simple)'.
* module/rnrs/io/6/simple.scm: with-input-file => with-input-from-file,
with-output-file => with-output-to-file.
commit 2d56d2dfdddd4e1ec424ad56052a0e17aef112cd
Author: Julian Graham <address@hidden>
Date: Fri Apr 9 00:23:28 2010 -0400
Implementation for R6RS (rnrs) composite library. (Can't be loaded yet
because of conflict between `syntax-case' transformer binding and
`(rnrs syntax-case)' hierarchical namespace module binding.)
* module/6/rnrs.scm: New file.
* module/Makefile.am: Add 6/rnrs.scm to RNRS_SOURCES.
commit 8794d769bdafb18ddc962c1963041e8c9dd10b36
Author: Julian Graham <address@hidden>
Date: Sun Apr 4 14:53:06 2010 -0400
Test suite and fixes for R6RS (rnrs arithmetic fixnums).
* module/rnrs/arithmetic/6/fixnums.scm: Fix missing imports;
(fixnum-width, greatest-fixnum, least-fixnum): Redefine these as
zero-argument procedures; Fix argument mismatches in several functions.
* test-suite/Makefile.am: Add tests/r6rs-arithmetic-fixnums.test to
SCM_TESTS.
* test-suite/tests/r6rs-arithmetic-fixnums.test: New file.
commit d3094cf2fa443ae97575fd6ee041574b68f79ee8
Author: Julian Graham <address@hidden>
Date: Sat Apr 3 23:05:46 2010 -0400
Fix typo in license comment.
* test-suite/tests/r6rs-eval.test: Lice6nse => License.
commit b01818d752d272c3a65dfd913e77d01540e21657
Author: Julian Graham <address@hidden>
Date: Sat Apr 3 23:04:24 2010 -0400
Implementation and test cases for the R6RS (rnrs arithmetic flonums)
library.
* module/Makefile.am: Add rnrs/arithmetic/6/fixnums.scm and
rnrs/arithmetic/6/flonums.scm to RNRS_SOURCES.
* module/rnrs/6/base.scm: (div-and-mod, div0, mod0, div0-and-mod0): New
functions; this `div' implementation is not quite right, but we'll come
back to it later.
* module/rnrs/arithmetic/6/fixnums.scm: New file.
* module/rnrs/arithmetic/6/flonums.scm: New file.
* test-suite/Makefile.am: Add tests/r6rs-arithmetic-flonums.test to
SCM_TESTS.
* test-suite/tests/r6rs-arithmetic-flonums.test: New file.
commit 15ce5cafbc30062b94da2f30d4c39e16ea48de1f
Author: Julian Graham <address@hidden>
Date: Tue Mar 30 14:38:27 2010 -0400
Implementation and test case for R6RS (rnrs eval) library.
* module/Makefile.am: Add rnrs/6/eval.scm to RNRS_SOURCES.
* module/rnrs/6/eval.scm: New file
* test-suite/Makefile.am: Add tests/r6rs-eval.test to SCM_TESTS.
* test-suite/tests/r6rs-eval.test: New file.
commit bc4db0905f84680572f1528a7911fcee33d2f304
Author: Julian Graham <address@hidden>
Date: Tue Mar 30 14:27:00 2010 -0400
Fix syntax and consolidate imports for (rnrs lists).
* module/rnrs/6/lists.scm: Import syntax is
`(only (import-set) id-1 ...)', not `(only (import-set) (id-1 ...))';
use `rename' form as wrapper instead of creating separate custom
interface on SRFI-1.
commit ace75ab775e0eb0eebd4943a5c709ee36fe492eb
Author: Julian Graham <address@hidden>
Date: Sun Mar 28 22:31:45 2010 -0400
Implementation and test cases for the R6RS (rnrs enums) library.
* module/Makefile.am: Add rnrs/6/enums.scm to RNRS_SOURCES.
* module/rnrs/6/conditions.scm: Fix define-condition-type binding for
syntax-violation? predicate.
* module/rnrs/6/enums.scm: New file.
* test-suite/Makefile.am: Add tests/r6rs-enums.test to SCM_TESTS.
* test-suite/tests/r6rs-enums.test: New file.
commit 0c7398a7dc471bc7b9f09b65dba7e33f4ac88af5
Author: Julian Graham <address@hidden>
Date: Sun Mar 28 19:40:16 2010 -0400
Add R6RS `syntax-violation' to (rnrs syntax-case).
* module/rnrs/6/exceptions.scm: Remove dependency on (rnrs syntax-case);
rewrite guard and guard0 in using syntax-rules in terms of syntax-case.
* module/rnrs/6/syntax-case.scm: Add syntax-violation implementation.
commit 2359a9a49ef4dd70e112d517b11b05840440b522
Author: Julian Graham <address@hidden>
Date: Sun Mar 28 19:31:49 2010 -0400
Test suite and fixes for R6RS (rnrs conditions) and
(rnrs records procedural).
* module/rnrs/6/conditions.scm: Fix export of
make-implementation-restriction-violation; remove dependency on
(rnrs syntax-case); remove redundant function
compound-condition-components; rewrite define-condition-type using
syntax-rules instead of syntax-case.
* module/rnrs/records/6/procedural.scm: Remove serious-condition?,
violation? and assertion-violation? predicates, since they're not true
condition predicates.
* test-suite/Makefile.am: Add tests/r6rs-conditions.test to SCM_TESTS.
* test-suite/tests/r6rs-conditions.test: New file.
commit a725e27bdaeef13c14006f46200130467a5571d5
Author: Julian Graham <address@hidden>
Date: Sat Mar 27 15:28:24 2010 -0400
Implementation for the (rnrs mutable-pairs) and (rnrs mutable-strings)
libraries.
* module/Makefile.am: Add rnrs/6/mutable-pairs.scm and
rnrs/6/mutable-strings.scm to RNRS_SOURCES.
* module/rnrs/6/mutable-pairs.scm: New file.
* module/rnrs/6/mutable-strings.scm: New file.
commit 3d5bc1ad6f2eed56acddf9c2fe2d4ddf548be4f0
Author: Julian Graham <address@hidden>
Date: Sat Mar 27 11:39:28 2010 -0400
Implementation for the R6RS (rnrs r5rs) library.
* module/Makefile.am: Add rnrs/6/r5rs.scm to RNRS_SOURCES.
* module/rnrs/6/r5rs.scm: New file.
commit d1c83d388aa35977a612eceda4cf52ef891cab0b
Author: Julian Graham <address@hidden>
Date: Fri Mar 26 20:57:52 2010 -0400
Add `guard' form and test cases to R6RS (rnrs exceptions) library.
* module/rnrs/6/exceptions.scm: (guard0, guard): New syntax.
* module/rnrs/records/6/procedural.scm: (r6rs-raise-continuable): Can't
use `raise' here because it's exported by (rnrs exceptions); use plain
old `throw' instead.
* test-suite/Makefile.am: Add tests/r6rs-exceptions.test to SCM_TESTS.
* test-suite/tests/r6rs-exceptions.test: New file.
commit a7ada161878d42b194660990473ccfbc86e59543
Author: Julian Graham <address@hidden>
Date: Fri Mar 26 20:47:39 2010 -0400
Fix test suite title in comment
* test-suite/tests/r6rs-records-procedural.test: `(rnrs control)' =>
`(rnrs records procedural)'
commit 0113507eee0cc8e6250958470ab4b21f32c42bcd
Author: Julian Graham <address@hidden>
Date: Sun Mar 21 19:26:48 2010 -0400
Implementation and test cases for R6RS (rnrs files) library.
* module/Makefile.am: Add rnrs/6/files.scm to RNRS_SOURCES.
* module/rnrs/6/conditions.scm (define-condition-type): Use specified
accessor name to create accessor binding. Add internally-visible
&i/o-* condition types.
* module/rnrs/6/files.scm: New file.
* module/rnrs/io/6/simple.scm: Export &i/o-* condition types clandestinely
imported from (rnrs conditions).
* test-suite/Makefile.am: Add tests/r6rs-files.test to SCM_TESTS.
* test-suite/test/r6rs-files.test: New file.
commit 805b4179bfe44506e6dcd3e62c6868659ffdafb6
Author: Julian Graham <address@hidden>
Date: Sun Mar 21 17:12:38 2010 -0400
Implementation for the R6RS (rnrs sorting) library.
* module/Makefile.am: Add rnrs/6/sorting.scm to RNRS_SOURCES.
* module/rnrs/6/sorting.scm: New file.
commit adf73f9ab45f5836090d2a6a76ebd534e3bad818
Author: Julian Graham <address@hidden>
Date: Sun Mar 21 17:03:35 2010 -0400
Implementation for the R6RS (rnrs programs) library.
* module/Makefile.am: Add rnrs/6/programs.scm to RNRS_SOURCES.
* module/rnrs/6/programs.scm: New file.
commit 949532501a8fed63595e3e15a17eec0069e822ff
Author: Julian Graham <address@hidden>
Date: Sun Mar 21 16:19:06 2010 -0400
Implementation and test cases for the R6RS (rnrs unicode) library.
* module/Makefile.am: Add rnrs/6/unicode.scm to RNRS_SOURCES.
* module/rnrs/6/unicode.scm: New file.
* test-suite/Makefile.am: Add tests/r6rs-unicode.test to SCM_TESTS.
* test-suite/tests/r6rs-unicode.test
commit 2b95784c8dd29a8bb75e66f2a3c0a77f777fe61a
Author: Julian Graham <address@hidden>
Date: Sat Mar 20 20:51:37 2010 -0400
Fixes and test cases for R6RS (rnrs hashtables) library.
* module/rnrs/6/hashtables.scm: Assorted bugfixes, esp. for wrapping
single-argument hash functions.
* test-suite/Makefile.am: Add tests/r6rs-hashtables.test to SCM_TESTS.
* test-suite/tests/r6rs-hashtables.test: New file.
commit 04ba959921cd8a6a69e367d4f163c45d8b36e199
Author: Julian Graham <address@hidden>
Date: Sat Mar 20 15:14:46 2010 -0400
Add test cases for record constructor protocols and parent protocol
delegation.
* test-suite/tests/r6rs-records-procedural.test ("simple protocol",
"protocol delegates to parent with protocol"): New tests.
commit f797da47f8a302ee80772c11f701c1abf45e9467
Author: Julian Graham <address@hidden>
Date: Sat Mar 20 15:10:11 2010 -0400
Implementation for the R6RS (rnrs hashtables) library;
Implementation and test cases for the R6RS (rnrs record syntactic) library.
* module/Makefile.am: Add rnrs/6/hashtables.scm to RNRS_SOURCES.
* module/rnrs/6/hashtables.scm: New file.
* module/rnrs/records/6/inspection.scm: (record-type-generative?) Record
types are generative iff they have no uid, not vice-versa.
* module/rnrs/records/6/syntactic.scm: Finish `define-record-type'
implementation; add `record-type-descriptor' and
`record-constructor-descriptor' forms.
* test-suite/Makefile.am: Add tests/r6rs-records-syntactic.test to
SCM_TESTS.
* test-suite/tests/r6rs-records-inspection.test: Update tests for
`record-type-generative?' to reflect corrected behavior.
* test-suite/tests/r6rs-records-syntactic.test: New file.
commit 00532e348ed773c9e0a564dd6ce71e203eded9d6
Author: Julian Graham <address@hidden>
Date: Sat Mar 20 14:57:49 2010 -0400
(rnrs conditions) should not depend on (rnrs records syntactic).
* module/rnrs/6/conditions.scm: (define-condition-type) Re-implement
`define-condition-type' in terms of (rnrs records procedural).
commit b3961e7ab37d367777924a8d0dd43b2fe35ed673
Author: Julian Graham <address@hidden>
Date: Sat Mar 20 08:36:17 2010 -0400
Fix missing export of string->symbol in (rnrs base).
* module/rnrs/6/base.scm: Add string->symbol to library exports.
commit 60b240e9ae603ade8b13164f05fb208d9f4c0396
Author: Julian Graham <address@hidden>
Date: Fri Mar 19 20:03:46 2010 -0400
Implementation for the R6RS (rnrs lists) library.
* module/Makefile.am: Add module/rnrs/6/lists.scm to RNRS_SOURCES.
* module/rnrs/6/lists.scm: New file.
commit 55684b5e3b5ceab5b87c46fc9dd2b78637ff13e1
Author: Julian Graham <address@hidden>
Date: Wed Mar 10 01:36:15 2010 -0500
Implementation and test cases for the R6RS (rnrs records inspection)
library.
* module/Makefile.am: Add module/rnrs/records/6/inspection.scm to
RNRS_SOURCES.
* module/rnrs/records/6/inspection.scm: New file.
* module/rnrs/records/6/procedural.scm: Assorted refactoring:
Create index constants for record, rtd, and rcd field indexes;
record-type-vtable, record-constructor-vtable: More informative display
names;
(make-record-type-descriptor): fold left, not right when creating
vtable;
store field names as vector, not list;
detect opaque parents
* test-suite/Makefile.am: Add test-suite/tests/r6rs-records-inspection.test
to
SCM_TESTS.
* test-suite/tests/r6rs-records-inspection.test: New file.
commit 8b58ea453916338a60b8e8cc8d785c82a801b4ae
Author: Julian Graham <address@hidden>
Date: Wed Mar 10 01:26:12 2010 -0500
Remove needless import of (rnrs io simple).
* module/rnrs/6/conditions.scm: Remove (rnrs io simple (6)) from imports.
commit ce543a9f70cf4772c3a491921686ed7d5674b984
Author: Julian Graham <address@hidden>
Date: Mon Mar 8 09:00:42 2010 -0500
Implementation and test cases for the R6RS (rnrs records procedural)
library,
along with its dependencies.
* module/Makefile.am: Add new R6RS libraries below to RNRS_SOURCES.
* module/rnrs/6/conditions.scm, exceptions.scm, syntax-case.scm: New files.
* module/rnrs/io/6/simple.scm: New file.
* module/rnrs/records/6/procedural.scm, syntactic.scm: New files.
* test-suite/Makefile.am: Add tests/r6rs-records-procedural.test to
SCM_TESTS.
* test-suite/tests/r6rs-records-procedural.test: New file.
commit aa439b3908b71f268f8a8d091d8143edebb5cde7
Author: Julian Graham <address@hidden>
Date: Sat Mar 6 02:04:25 2010 -0500
Fix missing imports for `(rnrs arithmetic bitwise)'.
* module/Makefile.am: Add module/rnrs/arithmetic/6/bitwise.scm to
RNRS_SOURCES.
* module/rnrs/arithmetic/6/bitwise.scm: Import `(rnrs control)' and `modulo'
from `(guile)'.
* test-suite/Makefile.am: Add r6rs-arithmetic-bitwise.test to SCM_TESTS.
commit bf745816f21d4d0d13889e97ae18a1171abda4a7
Author: Julian Graham <address@hidden>
Date: Sat Mar 6 01:28:46 2010 -0500
Implementation and test cases for the R6RS (rnrs control) library.
* module/Makefile.am: Add rnrs/6/base.scm and rnrs/6/control.scm to
RNRS_SOURCES.
* module/rnrs/6/base.scm, control.scm: New files.
* test-suite/Makefile.am: Add tests/r6rs-control.test to SCM_TESTS.
* test-suite/tests/r6rs-control.test: New file.
commit 2a435f1f911bf7ce4ab55414d2bd76e5c95cb182
Author: Julian Graham <address@hidden>
Date: Mon Feb 8 09:45:54 2010 -0500
Implementation and test cases for the R6RS (rnrs arithmetic bitwise)
library.
* module/rnrs/arithmetic/6/bitwise.scm: New file.
* test-suite/tests/r6rs-arithmetic-bitwise.test: New file.
-----------------------------------------------------------------------
Summary of changes:
module/6/rnrs.scm | 239 +++++++++++++++++++
module/Makefile.am | 26 ++-
module/rnrs/6/base.scm | 94 ++++++++
module/rnrs/6/conditions.scm | 243 +++++++++++++++++++
module/rnrs/6/control.scm | 33 +++
module/rnrs/6/enums.scm | 153 ++++++++++++
module/rnrs/6/eval.scm | 39 +++
module/rnrs/6/exceptions.scm | 67 ++++++
module/rnrs/6/files.scm | 125 ++++++++++
module/rnrs/6/hashtables.scm | 179 ++++++++++++++
module/rnrs/6/lists.scm | 49 ++++
module/rnrs/6/mutable-pairs.scm | 22 ++
module/rnrs/6/mutable-strings.scm | 22 ++
module/rnrs/6/programs.scm | 22 ++
module/rnrs/6/r5rs.scm | 34 +++
module/rnrs/6/sorting.scm | 27 +++
module/rnrs/6/syntax-case.scm | 67 ++++++
module/rnrs/6/unicode.scm | 104 +++++++++
module/rnrs/arithmetic/6/bitwise.scm | 125 ++++++++++
module/rnrs/arithmetic/6/fixnums.scm | 268 +++++++++++++++++++++
module/rnrs/arithmetic/6/flonums.scm | 216 +++++++++++++++++
module/rnrs/io/6/simple.scm | 173 ++++++++++++++
module/rnrs/records/6/inspection.scm | 83 +++++++
module/rnrs/records/6/procedural.scm | 275 ++++++++++++++++++++++
module/rnrs/records/6/syntactic.scm | 253 ++++++++++++++++++++
test-suite/Makefile.am | 14 ++
test-suite/tests/r6rs-arithmetic-bitwise.test | 97 ++++++++
test-suite/tests/r6rs-arithmetic-fixnums.test | 211 +++++++++++++++++
test-suite/tests/r6rs-arithmetic-flonums.test | 310 +++++++++++++++++++++++++
test-suite/tests/r6rs-conditions.test | 91 +++++++
test-suite/tests/r6rs-control.test | 34 +++
test-suite/tests/r6rs-enums.test | 257 ++++++++++++++++++++
test-suite/tests/r6rs-eval.test | 28 +++
test-suite/tests/r6rs-exceptions.test | 98 ++++++++
test-suite/tests/r6rs-files.test | 40 ++++
test-suite/tests/r6rs-hashtables.test | 178 ++++++++++++++
test-suite/tests/r6rs-records-inspection.test | 148 ++++++++++++
test-suite/tests/r6rs-records-procedural.test | 244 +++++++++++++++++++
test-suite/tests/r6rs-records-syntactic.test | 116 +++++++++
test-suite/tests/r6rs-unicode.test | 50 ++++
40 files changed, 4853 insertions(+), 1 deletions(-)
create mode 100644 module/6/rnrs.scm
create mode 100644 module/rnrs/6/base.scm
create mode 100644 module/rnrs/6/conditions.scm
create mode 100644 module/rnrs/6/control.scm
create mode 100644 module/rnrs/6/enums.scm
create mode 100644 module/rnrs/6/eval.scm
create mode 100644 module/rnrs/6/exceptions.scm
create mode 100644 module/rnrs/6/files.scm
create mode 100644 module/rnrs/6/hashtables.scm
create mode 100644 module/rnrs/6/lists.scm
create mode 100644 module/rnrs/6/mutable-pairs.scm
create mode 100644 module/rnrs/6/mutable-strings.scm
create mode 100644 module/rnrs/6/programs.scm
create mode 100644 module/rnrs/6/r5rs.scm
create mode 100644 module/rnrs/6/sorting.scm
create mode 100644 module/rnrs/6/syntax-case.scm
create mode 100644 module/rnrs/6/unicode.scm
create mode 100644 module/rnrs/arithmetic/6/bitwise.scm
create mode 100644 module/rnrs/arithmetic/6/fixnums.scm
create mode 100644 module/rnrs/arithmetic/6/flonums.scm
create mode 100644 module/rnrs/io/6/simple.scm
create mode 100644 module/rnrs/records/6/inspection.scm
create mode 100644 module/rnrs/records/6/procedural.scm
create mode 100644 module/rnrs/records/6/syntactic.scm
create mode 100644 test-suite/tests/r6rs-arithmetic-bitwise.test
create mode 100644 test-suite/tests/r6rs-arithmetic-fixnums.test
create mode 100644 test-suite/tests/r6rs-arithmetic-flonums.test
create mode 100644 test-suite/tests/r6rs-conditions.test
create mode 100644 test-suite/tests/r6rs-control.test
create mode 100644 test-suite/tests/r6rs-enums.test
create mode 100644 test-suite/tests/r6rs-eval.test
create mode 100644 test-suite/tests/r6rs-exceptions.test
create mode 100644 test-suite/tests/r6rs-files.test
create mode 100644 test-suite/tests/r6rs-hashtables.test
create mode 100644 test-suite/tests/r6rs-records-inspection.test
create mode 100644 test-suite/tests/r6rs-records-procedural.test
create mode 100644 test-suite/tests/r6rs-records-syntactic.test
create mode 100644 test-suite/tests/r6rs-unicode.test
diff --git a/module/6/rnrs.scm b/module/6/rnrs.scm
new file mode 100644
index 0000000..d8d7567
--- /dev/null
+++ b/module/6/rnrs.scm
@@ -0,0 +1,239 @@
+;;; rnrs.scm --- The R6RS composite library
+
+;; 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 (rnrs (6))
+ (export ;; (rnrs arithmetic bitwise)
+
+ bitwise-not bitwise-and bitwise-ior bitwise-xor bitwise-if
+ bitwise-bit-count bitwise-length bitwise-first-bit-set
+ bitwise-bit-set? bitwise-copy-bit bitwise-bit-field
+ bitwise-copy-bit-field bitwise-arithmetic-shift
+ bitwise-arithmetic-shift-left bitwise-arithmetic-shift-right
+ bitwise-rotate-bit-field bitwise-reverse-bit-field
+
+ ;; (rnrs arithmetic fixnums)
+
+ fixnum? fixnum-width least-fixnum greatest-fixnum fx=? fx>? fx<? fx>=?
+ fx<=? fxzero? fxpositive? fxnegative? fxodd? fxeven? fxmax fxmin fx+
+ fx* fx- fxdiv-and-mod fxdiv fxmod fxdiv0-and-mod0 fxdiv0 fxmod0
+ fx+/carry fx-/carry fx*/carry fxnot fxand fxior fxxor fxif fxbit-count
+ fxlength fxfirst-bit-set fxbit-set? fxcopy-bit fxbit-field
+ fxcopy-bit-field fxarithmetic-shift fxarithmetic-shift-left
+ fxarithmetic-shift-right fxrotate-bit-field fxreverse-bit-field
+
+ ;; (rnrs arithmetic flonums)
+
+ flonum? real->flonum fl=? fl<? fl<=? fl>? fl>=? flinteger? flzero?
+ flpositive? flnegative? flodd? fleven? flfinite? flinfinite? flnan?
+ flmax flmin fl+ fl* fl- fl/ flabs fldiv-and-mod fldiv flmod
+ fldiv0-and-mod0 fldiv0 flmod0 flnumerator fldenominator flfloor
+ flceiling fltruncate flround flexp fllog flsin flcos fltan flacos
+ flasin flatan flsqrt flexpt &no-infinities
+ make-no-infinities-violation no-infinities-violation? &no-nans
+ make-no-nans-violation no-nans-violation? fixnum->flonum
+
+ ;; (rnrs base)
+
+ boolean? symbol? char? vector? null? pair? number? string? procedure?
+ define define-syntax syntax-rules lambda let let* let-values
+ let*-values letrec begin quote lambda if set! cond case or and not
+ eqv? equal? eq? + - * / max min abs numerator denominator gcd lcm
+ floor ceiling truncate round rationalize real-part imag-part
+ make-rectangular angle div mod div-and-mod div0 mod0 div0-and-mod0
+ expt exact-integer-sqrt sqrt exp log sin cos tan asin acos atan
+ make-polar magnitude angle complex? real? rational? integer? exact?
+ inexact? real-valued? rational-valued? integer-values? zero?
+ positive? negative? odd? even? nan? finite? infinite? exact inexact =
+ < > <= >= number->string string->number cons car cdr caar cadr cdar
+ cddr caaar caadr cadar cdaar caddr cdadr cddar cdddr caaaar caaadr
+ caadar cadaar cdaaar cddaar cdadar cdaadr cadadr caaddr caddar cadddr
+ cdaddr cddadr cdddar cddddr list? list length append reverse
+ list-tail list-ref map for-each symbol->string string->symbol symbol=?
+ char->integer integer->char char=? char<? char>? char<=? char>=?
+ make-string string string-length string-ref string=? string<? string>?
+ string<=? string>=? substring string-append string->list list->string
+ string-for-each string-copy vector? make-vector vector vector-length
+ vector-ref vector-set! vector->list list->vector vector-fill!
+ vector-map vector-for-each error assertion-violation assert
+ call-with-current-continuation call/cc call-with-values dynamic-wind
+ values apply quasiquote unquote unquote-splicing let-syntax
+ letrec-syntax syntax-rules identifier-syntax
+
+ ;; (rnrs bytevector)
+
+ endianness native-endianness bytevector? make-bytevector
+ bytevector-length bytevector=? bytevector-fill! bytevector-copy!
+ bytevector-copy uniform-array->bytevector bytevector-u8-ref
+ bytevector-s8-ref bytevector-u8-set! bytevector-s8-set!
+ bytevector->u8-list u8-list->bytevector bytevector-uint-ref
+ bytevector-uint-set! bytevector-sint-ref bytevector-sint-set!
+ bytevector->sint-list bytevector->uint-list uint-list->bytevector
+ sint-list->bytevector bytevector-u16-ref bytevector-s16-ref
+ bytevector-u16-set! bytevector-s16-set! bytevector-u16-native-ref
+ bytevector-s16-native-ref bytevector-u16-native-set!
+ bytevector-s16-native-set! bytevector-u32-ref bytevector-s32-ref
+ bytevector-u32-set! bytevector-s32-set! bytevector-u32-native-ref
+ bytevector-s32-native-ref bytevector-u32-native-set!
+ bytevector-s32-native-set! bytevector-u64-ref bytevector-s64-ref
+ bytevector-u64-set! bytevector-s64-set! bytevector-u64-native-ref
+ bytevector-s64-native-ref bytevector-u64-native-set!
+ bytevector-s64-native-set! bytevector-ieee-single-ref
+ bytevector-ieee-single-set! bytevector-ieee-single-native-ref
+ bytevector-ieee-single-native-set! bytevector-ieee-double-ref
+ bytevector-ieee-double-set! bytevector-ieee-double-native-ref
+ bytevector-ieee-double-native-set! string->utf8 string->utf16
+ string->utf32 utf8->string utf16->string utf32->string
+
+ ;; (rnrs conditions)
+
+ &condition condition simple-conditions condition? condition-predicate
+ condition-accessor define-condition-type &message
+ make-message-condition message-condition? condition-message &warning
+ make-warning warning? &serious make-serious-condition
+ serious-condition? &error make-error error? &violation make-violation
+ violation? &assertion make-assertion-violation assertion-violation?
+ &irritants make-irritants-condition irritants-condition?
+ condition-irritants &who make-who-condition who-condition?
+ condition-who &non-continuable make-non-continuable-violation
+ non-continuable-violation? &implementation-restriction
+ make-implementation-restriction-violation
+ implementation-restriction-violation? &lexical make-lexical-violation
+ lexical-violation? &syntax make-syntax-violation syntax-violation?
+ syntax-violation-form syntax-violation-subform &undefined
+ make-undefined-violation undefined-violation?
+
+ ;; (rnrs control)
+
+ when unless do case-lambda
+
+ ;; (rnrs enums)
+
+ make-enumeration enum-set-universe enum-set-indexer
+ enum-set-constructor enum-set->list enum-set-member? enum-set-subset?
+ enum-set=? enum-set-union enum-set-intersection enum-set-difference
+ enum-set-complement enum-set-projection define-enumeration
+
+ ;; (rnrs exceptions)
+
+ guard with-exception-handler raise raise-continuable
+
+ ;; (rnrs files)
+
+ file-exists? delete-file &i/o make-i/o-error i/o-error? &i/o-read
+ make-i/o-read-error i/o-read-error? &i/o-write make-i/o-write-error
+ i/o-write-error? &i/o-invalid-position
+ make-i/o-invalid-position-error i/o-invalid-position-error?
+ i/o-error-position &i/o-filename make-i/o-filename-error
+ i/o-filename-error? i/o-error-filename &i/o-file-protection
+ make-i/o-file-protection-error i/o-file-protection-error?
+ &i/o-file-is-read-only make-i/o-file-is-read-only-error
+ i/o-file-is-read-only-error? &i/o-file-already-exists
+ make-i/o-file-already-exists-error i/o-file-already-exists-error?
+ &i/o-file-does-not-exist make-i/o-file-does-not-exist-error
+ i/o-file-does-not-exist-error? &i/o-port make-i/o-port-error
+ i/o-port-error? i/o-error-port
+
+ ;; (rnrs hashtables)
+
+ make-eq-hashtable make-eqv-hashtable make-hashtable hashtable?
+ hashtable-size hashtable-ref hashtable-set! hashtable-delete!
+ hashtable-contains? hashtable-update! hashtable-copy hashtable-clear!
+ hashtable-keys hashtable-entries hashtable-equivalence-function
+ hashtable-hash-function hashtable-mutable? equal-hash string-hash
+ string-ci-hash symbol-hash
+
+ ;; (rnrs io ports)
+
+ eof-object? port? input-port? output-port? eof-object port-transcoder
+ binary-port? transcoded-port port-position set-port-position!
+ port-has-port-position? port-has-set-port-position!? call-with-port
+ open-bytevector-input-port make-custom-binary-input-port get-u8
+ lookahead-u8 get-bytevector-n get-bytevector-n! get-bytevector-some
+ get-bytevector-all open-bytevector-output-port
+ make-custom-binary-output-port put-u8 put-bytevector
+
+ ;; (rnrs io simple)
+
+ call-with-input-file call-with-output-file current-input-port
+ current-output-port current-error-port with-input-from-file
+ with-output-to-file open-input-file open-output-file close-input-port
+ close-output-port read-char peek-char read write-char newline display
+ write
+
+ ;; (rnrs lists)
+
+ find for-all exists filter partition fold-left fold-right remp remove
+ remv remq memp member memv memq assp assoc assv assq cons*
+
+ ;; (rnrs programs)
+
+ command-line exit
+
+ ;; (rnrs records inspection)
+
+ record? record-rtd record-type-name record-type-parent
+ record-type-uid record-type-generative? record-type-sealed?
+ record-type-opaque? record-type-field-names record-field-mutable?
+
+ ;; (rnrs records procedural)
+
+ make-record-type-descriptor record-type-descriptor?
+ make-record-constructor-descriptor record-constructor record-predicate
+ record-accessor record-mutator
+
+ ;; (rnrs records syntactic)
+
+ define-record-type record-type-descriptor
+ record-constructor-descriptor
+
+ ;; (rnrs sorting)
+
+ list-sort vector-sort vector-sort!
+
+ ;; (rnrs syntax-case)
+
+ make-variable-transformer syntax syntax-case identifier?
+ bound-identifier=? free-identifier=? syntax->datum datum->syntax
+ generate-temporaries with-syntax quasisyntax unsyntax
+ unsyntax-splicing syntax-violation)
+
+ (import (rnrs arithmetic bitwise (6))
+ (rnrs arithmetic fixnums (6))
+ (rnrs arithmetic flonums (6))
+ (rnrs base (6))
+
+ (rnrs bytevector)
+
+ (rnrs conditions (6))
+ (rnrs control (6))
+ (rnrs enums (6))
+ (rnrs exceptions (6))
+ (rnrs files (6))
+ (rnrs hashtables (6))
+
+ (rnrs io ports)
+
+ (rnrs io simple (6))
+ (rnrs lists (6))
+ (rnrs programs (6))
+ (rnrs records inspection (6))
+ (rnrs records procedural (6))
+ (rnrs records syntactic (6))
+ (rnrs sorting (6))
+ (rnrs syntax-case (6))))
diff --git a/module/Makefile.am b/module/Makefile.am
index cbe945f..92c0e58 100644
--- a/module/Makefile.am
+++ b/module/Makefile.am
@@ -256,8 +256,32 @@ SRFI_SOURCES = \
srfi/srfi-98.scm
RNRS_SOURCES = \
+ 6/rnrs.scm \
+ rnrs/6/base.scm \
+ rnrs/6/conditions.scm \
+ rnrs/6/control.scm \
+ rnrs/6/enums.scm \
+ rnrs/6/eval.scm \
+ rnrs/6/exceptions.scm \
+ rnrs/6/files.scm \
+ rnrs/6/hashtables.scm \
+ rnrs/6/lists.scm \
+ rnrs/6/mutable-pairs.scm \
+ rnrs/6/mutable-strings.scm \
+ rnrs/6/programs.scm \
+ rnrs/6/r5rs.scm \
+ rnrs/6/sorting.scm \
+ rnrs/6/syntax-case.scm \
+ rnrs/6/unicode.scm \
+ rnrs/arithmetic/6/bitwise.scm \
+ rnrs/arithmetic/6/fixnums.scm \
+ rnrs/arithmetic/6/flonums.scm \
rnrs/bytevector.scm \
- rnrs/io/ports.scm
+ rnrs/io/6/simple.scm \
+ rnrs/io/ports.scm \
+ rnrs/records/6/inspection.scm \
+ rnrs/records/6/procedural.scm \
+ rnrs/records/6/syntactic.scm
EXTRA_DIST += scripts/ChangeLog-2008
EXTRA_DIST += scripts/README
diff --git a/module/rnrs/6/base.scm b/module/rnrs/6/base.scm
new file mode 100644
index 0000000..4358aa4
--- /dev/null
+++ b/module/rnrs/6/base.scm
@@ -0,0 +1,94 @@
+;;; base.scm --- The R6RS base library
+
+;; 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 (rnrs base (6))
+ (export boolean? symbol? char? vector? null? pair? number? string? procedure?
+
+ define define-syntax syntax-rules lambda let let* let-values
+ let*-values letrec begin
+
+ quote lambda if set! cond case
+
+ or and not
+
+ eqv? equal? eq?
+
+ + - * / max min abs numerator denominator gcd lcm floor ceiling
+ truncate round rationalize real-part imag-part make-rectangular angle
+ div mod div-and-mod div0 mod0 div0-and-mod0
+
+ expt exact-integer-sqrt sqrt exp log sin cos tan asin acos atan
+ make-polar magnitude angle
+
+ complex? real? rational? integer? exact? inexact? real-valued?
+ rational-valued? integer-values? zero? positive? negative? odd? even?
+ nan? finite? infinite?
+
+ exact inexact = < > <= >=
+
+ number->string string->number
+
+ cons car cdr caar cadr cdar cddr caaar caadr cadar cdaar caddr cdadr
+ cddar cdddr caaaar caaadr caadar cadaar cdaaar cddaar cdadar cdaadr
+ cadadr caaddr caddar cadddr cdaddr cddadr cdddar cddddr
+
+ list? list length append reverse list-tail list-ref map for-each
+
+ symbol->string string->symbol symbol=?
+
+ char->integer integer->char char=? char<? char>? char<=? char>=?
+
+ make-string string string-length string-ref string=? string<? string>?
+ string<=? string>=? substring string-append string->list list->string
+ string-for-each string-copy
+
+ vector? make-vector vector vector-length vector-ref vector-set!
+ vector->list list->vector vector-fill! vector-map vector-for-each
+
+ error assertion-violation assert
+
+ call-with-current-continuation call/cc call-with-values dynamic-wind
+ values apply
+
+ quasiquote unquote unquote-splicing
+
+ let-syntax letrec-syntax
+
+ syntax-rules identifier-syntax)
+ (import (rename (guile) (quotient div) (modulo mod))
+ (rename (only (guile) for-each map)
+ (for-each vector-for-each) (map vector-map))
+ (srfi srfi-11))
+
+ (define (div-and-mod x y) (let ((q (div x y)) (r (mod x y))) (values q r)))
+
+ (define (div0 x y)
+ (call-with-values (lambda () (div0-and-mod0 x y)) (lambda (q r) q)))
+
+ (define (mod0 x y)
+ (call-with-values (lambda () (div0-and-mod0 x y)) (lambda (q r) r)))
+
+ (define (div0-and-mod0 x y)
+ (call-with-values (lambda () (div-and-mod x y))
+ (lambda (q r)
+ (cond ((< r (abs (/ y 2))) (values q r))
+ ((negative? y) (values (- q 1) (+ r y)))
+ (else (values (+ q 1) (+ r y)))))))
+
+)
diff --git a/module/rnrs/6/conditions.scm b/module/rnrs/6/conditions.scm
new file mode 100644
index 0000000..9c6539f
--- /dev/null
+++ b/module/rnrs/6/conditions.scm
@@ -0,0 +1,243 @@
+;;; conditions.scm --- The R6RS conditions library
+
+;; 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 (rnrs conditions (6))
+ (export &condition
+ condition
+ simple-conditions
+ condition?
+ condition-predicate
+ condition-accessor
+ define-condition-type
+
+ &message
+ make-message-condition
+ message-condition?
+ condition-message
+
+ &warning
+ make-warning
+ warning?
+
+ &serious
+ make-serious-condition
+ serious-condition?
+
+ &error
+ make-error
+ error?
+
+ &violation
+ make-violation
+ violation?
+
+ &assertion
+ make-assertion-violation
+ assertion-violation?
+
+ &irritants
+ make-irritants-condition
+ irritants-condition?
+ condition-irritants
+
+ &who
+ make-who-condition
+ who-condition?
+ condition-who
+
+ &non-continuable
+ make-non-continuable-violation
+ non-continuable-violation?
+
+ &implementation-restriction
+ make-implementation-restriction-violation
+ implementation-restriction-violation?
+
+ &lexical
+ make-lexical-violation
+ lexical-violation?
+
+ &syntax
+ make-syntax-violation
+ syntax-violation?
+ syntax-violation-form
+ syntax-violation-subform
+
+ &undefined
+ make-undefined-violation
+ undefined-violation?)
+ (import (only (guile) and=> @@)
+ (rnrs base (6))
+ (rnrs lists (6))
+ (rnrs records procedural (6)))
+
+ (define &compound-condition (make-record-type-descriptor
+ '&compound-condition #f #f #f #f
+ '#((immutable components))))
+ (define compound-condition? (record-predicate &compound-condition))
+
+ (define make-compound-condition
+ (record-constructor (make-record-constructor-descriptor
+ &compound-condition #f #f)))
+ (define simple-conditions (record-accessor &compound-condition 0))
+
+ (define (condition? obj)
+ (or (compound-condition? obj) (condition-internal? obj)))
+
+ (define condition
+ (lambda conditions
+ (define (flatten cond)
+ (if (compound-condition? cond) (simple-conditions cond) (list cond)))
+ (or (for-all condition? conditions)
+ (raise (make-assertion-violation)))
+ (if (or (null? conditions) (> (length conditions) 1))
+ (make-compound-condition (apply append (map flatten conditions)))
+ (car conditions))))
+
+ (define-syntax define-condition-type
+ (syntax-rules ()
+ ((_ condition-type supertype constructor predicate
+ (field accessor) ...)
+ (letrec-syntax
+ ((transform-fields
+ (syntax-rules ()
+ ((_ (f a) . rest)
+ (cons '(immutable f a) (transform-fields rest)))
+ ((_ ((f a))) '((immutable f a)))
+ ((_ ()) '())
+ ((_) '())))
+
+ (generate-accessors
+ (syntax-rules ()
+ ((_ counter (f a) . rest)
+ (begin (define a (record-accessor condition-type counter))
+ (generate-accessors (+ counter 1) rest)))
+ ((_ counter ((f a)))
+ (define a (record-accessor condition-type counter)))
+ ((_ counter ()) (begin))
+ ((_ counter) (begin)))))
+ (begin
+ (define condition-type
+ (make-record-type-descriptor
+ 'condition-type supertype #f #f #f
+ (list->vector (transform-fields (field accessor) ...))))
+ (define constructor
+ (record-constructor
+ (make-record-constructor-descriptor condition-type #f #f)))
+ (define predicate (condition-predicate condition-type))
+ (generate-accessors 0 (field accessor) ...))))))
+
+ (define &condition (@@ (rnrs records procedural) &condition))
+ (define &condition-constructor-descriptor
+ (make-record-constructor-descriptor &condition #f #f))
+ (define condition-internal? (record-predicate &condition))
+
+ (define (condition-predicate rtd)
+ (let ((rtd-predicate (record-predicate rtd)))
+ (lambda (obj)
+ (cond ((compound-condition? obj)
+ (exists rtd-predicate (simple-conditions obj)))
+ ((condition-internal? obj) (rtd-predicate obj))
+ (else #f)))))
+
+ (define (condition-accessor rtd proc)
+ (let ((rtd-predicate (record-predicate rtd)))
+ (lambda (obj)
+ (cond ((rtd-predicate obj) (proc obj))
+ ((compound-condition? obj)
+ (and=> (find rtd-predicate (simple-conditions obj)) proc))
+ (else #f)))))
+
+ (define-condition-type &message &condition
+ make-message-condition message-condition?
+ (message condition-message))
+
+ (define-condition-type &warning &condition make-warning warning?)
+
+ (define &serious (@@ (rnrs records procedural) &serious))
+ (define make-serious-condition
+ (@@ (rnrs records procedural) make-serious-condition))
+ (define serious-condition? (condition-predicate &serious))
+
+ (define-condition-type &error &serious make-error error?)
+
+ (define &violation (@@ (rnrs records procedural) &violation))
+ (define make-violation (@@ (rnrs records procedural) make-violation))
+ (define violation? (condition-predicate &violation))
+
+ (define &assertion (@@ (rnrs records procedural) &assertion))
+ (define make-assertion-violation
+ (@@ (rnrs records procedural) make-assertion-violation))
+ (define assertion-violation? (condition-predicate &assertion))
+
+ (define-condition-type &irritants &condition
+ make-irritants-condition irritants-condition?
+ (irritants condition-irritants))
+
+ (define-condition-type &who &condition
+ make-who-condition who-condition?
+ (who condition-who))
+
+ (define-condition-type &non-continuable &violation
+ make-non-continuable-violation
+ non-continuable-violation?)
+
+ (define-condition-type &implementation-restriction
+ &violation
+ make-implementation-restriction-violation
+ implementation-restriction-violation?)
+
+ (define-condition-type &lexical &violation
+ make-lexical-violation lexical-violation?)
+
+ (define-condition-type &syntax &violation
+ make-syntax-violation syntax-violation?
+ (form syntax-violation-form)
+ (subform syntax-violation-subform))
+
+ (define-condition-type &undefined &violation
+ make-undefined-violation undefined-violation?)
+
+ ;; Condition types that are used by (rnrs files), (rnrs io ports), and
+ ;; (rnrs io simple). These are defined here so as to be easily shareable by
+ ;; these three libraries.
+
+ (define-condition-type &i/o &error make-i/o-error i/o-error?)
+ (define-condition-type &i/o-read &i/o make-i/o-read-error i/o-read-error?)
+ (define-condition-type &i/o-write &i/o make-i/o-write-error i/o-write-error?)
+ (define-condition-type &i/o-invalid-position
+ &i/o make-i/o-invalid-position-error i/o-invalid-position-error?
+ (position i/o-error-position))
+ (define-condition-type &i/o-filename
+ &i/o make-i/o-filename-error i/o-filename-error?
+ (filename i/o-error-filename))
+ (define-condition-type &i/o-file-protection
+ &i/o-filename make-i/o-file-protection-error i/o-file-protection-error?)
+ (define-condition-type &i/o-file-is-read-only
+ &i/o-file-protection make-i/o-file-is-read-only-error
+ i/o-file-is-read-only-error?)
+ (define-condition-type &i/o-file-already-exists
+ &i/o-filename make-i/o-file-already-exists-error
+ i/o-file-already-exists-error?)
+ (define-condition-type &i/o-file-does-not-exist
+ &i/o-filename make-i/o-file-does-not-exist-error
+ i/o-file-does-not-exist-error?)
+ (define-condition-type &i/o-port &i/o make-i/o-port-error i/o-port-error?
+ (port i/o-error-port))
+)
diff --git a/module/rnrs/6/control.scm b/module/rnrs/6/control.scm
new file mode 100644
index 0000000..69351c6
--- /dev/null
+++ b/module/rnrs/6/control.scm
@@ -0,0 +1,33 @@
+;;; control.scm --- The R6RS control structures library
+
+;; 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 (rnrs control (6))
+ (export when unless do case-lambda)
+ (import (rnrs base (6))
+ (only (guile) do case-lambda))
+
+ (define-syntax when
+ (syntax-rules ()
+ ((when test result1 result2 ...)
+ (if test (begin result1 result2 ...)))))
+
+ (define-syntax unless
+ (syntax-rules ()
+ ((unless test result1 result2 ...)
+ (if (not test) (begin result1 result2 ...))))))
diff --git a/module/rnrs/6/enums.scm b/module/rnrs/6/enums.scm
new file mode 100644
index 0000000..cd7e346
--- /dev/null
+++ b/module/rnrs/6/enums.scm
@@ -0,0 +1,153 @@
+;;; enums.scm --- The R6RS enumerations library
+
+;; 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 (rnrs enums (6))
+ (export make-enumeration enum-set-universe enum-set-indexer
+ enum-set-constructor enum-set->list enum-set-member? enum-set-subset?
+ enum-set=? enum-set-union enum-set-intersection enum-set-difference
+ enum-set-complement enum-set-projection define-enumeration)
+ (import (only (guile) and=>)
+ (rnrs base (6))
+ (rnrs conditions (6))
+ (rnrs exceptions (6))
+ (rnrs records procedural (6))
+ (rnrs syntax-case (6))
+ (srfi :1))
+
+ (define enum-set-rtd (make-record-type-descriptor
+ 'enum-set #f #f #f #f '#((mutable universe)
+ (immutable set))))
+
+ (define make-enum-set
+ (record-constructor
+ (make-record-constructor-descriptor enum-set-rtd #f #f)))
+
+ (define enum-set-universe-internal (record-accessor enum-set-rtd 0))
+ (define enum-set-universe-set! (record-mutator enum-set-rtd 0))
+
+ (define enum-set-set (record-accessor enum-set-rtd 1))
+
+ (define (make-enumeration symbol-list)
+ (let ((es (make-enum-set #f symbol-list)))
+ (enum-set-universe-set! es es)))
+
+ (define (enum-set-universe enum-set)
+ (or (enum-set-universe-internal enum-set)
+ enum-set))
+
+ (define (enum-set-indexer enum-set)
+ (let* ((symbols (enum-set->list (enum-set-universe enum-set)))
+ (cardinality (length symbols)))
+ (lambda (x)
+ (and=> (memq x symbols)
+ (lambda (probe) (- cardinality (length probe)))))))
+
+ (define (enum-set-constructor enum-set)
+ (lambda (symbol-list)
+ (make-enum-set (enum-set-universe enum-set)
+ (list-copy symbol-list))))
+
+ (define (enum-set->list enum-set)
+ (lset-intersection eq?
+ (enum-set-set (enum-set-universe enum-set))
+ (enum-set-set enum-set)))
+
+ (define (enum-set-member? symbol enum-set)
+ (and (memq symbol (enum-set-set enum-set)) #t))
+
+ (define (enum-set-subset? enum-set-1 enum-set-2)
+ (and (lset<= eq?
+ (enum-set-set (enum-set-universe enum-set-1))
+ (enum-set-set (enum-set-universe enum-set-2)))
+ (lset<= eq? (enum-set-set enum-set-1) (enum-set-set enum-set-2))))
+
+ (define (enum-set=? enum-set-1 enum-set-2)
+ (and (enum-set-subset? enum-set-1 enum-set-2)
+ (enum-set-subset? enum-set-2 enum-set-1)))
+
+ (define (enum-set-union enum-set-1 enum-set-2)
+ (if (eq? (enum-set-universe enum-set-1)
+ (enum-set-universe enum-set-2))
+ (make-enum-set (enum-set-universe enum-set-1)
+ (lset-union eq?
+ (enum-set-set enum-set-1)
+ (enum-set-set enum-set-2)))
+ (raise (make-assertion-violation))))
+
+ (define (enum-set-intersection enum-set-1 enum-set-2)
+ (if (eq? (enum-set-universe enum-set-1)
+ (enum-set-universe enum-set-2))
+ (make-enum-set (enum-set-universe enum-set-1)
+ (lset-intersection eq?
+ (enum-set-set enum-set-1)
+ (enum-set-set enum-set-2)))
+ (raise (make-assertion-violation))))
+
+ (define (enum-set-difference enum-set-1 enum-set-2)
+ (if (eq? (enum-set-universe enum-set-1)
+ (enum-set-universe enum-set-2))
+ (make-enum-set (enum-set-universe enum-set-1)
+ (lset-difference eq?
+ (enum-set-set enum-set-1)
+ (enum-set-set enum-set-2)))
+ (raise (make-assertion-violation))))
+
+ (define (enum-set-complement enum-set)
+ (let ((universe (enum-set-universe enum-set)))
+ (make-enum-set universe
+ (lset-difference
+ eq? (enum-set->list universe) (enum-set-set enum-set)))))
+
+ (define (enum-set-projection enum-set-1 enum-set-2)
+ (make-enum-set (enum-set-universe enum-set-2)
+ (lset-intersection eq?
+ (enum-set-set enum-set-1)
+ (enum-set->list
+ (enum-set-universe enum-set-2)))))
+
+ (define-syntax define-enumeration
+ (syntax-rules ()
+ ((_ type-name (symbol ...) constructor-syntax)
+ (begin
+ (define-syntax type-name
+ (lambda (s)
+ (syntax-case s ()
+ ((type-name sym)
+ (if (memq (syntax->datum #'sym) '(symbol ...))
+ #'(quote sym)
+ (syntax-violation (symbol->string 'type-name)
+ "not a member of the set"
+ #f))))))
+ (define-syntax constructor-syntax
+ (lambda (s)
+ (syntax-case s ()
+ ((_) (syntax #f))
+ ((_ sym (... ...))
+ (let* ((universe '(symbol ...))
+ (syms (syntax->datum #'(sym (... ...))))
+ (quoted-universe
+ (datum->syntax s (list 'quote universe)))
+ (quoted-syms (datum->syntax s (list 'quote syms))))
+ (or (every (lambda (x) (memq x universe)) syms)
+ (syntax-violation (symbol->string 'constructor-syntax)
+ "not a subset of the universe"
+ #f))
+ #`((enum-set-constructor (make-enumeration #,quoted-universe))
+ #,quoted-syms))))))))))
+)
diff --git a/module/rnrs/6/eval.scm b/module/rnrs/6/eval.scm
new file mode 100644
index 0000000..d58f877
--- /dev/null
+++ b/module/rnrs/6/eval.scm
@@ -0,0 +1,39 @@
+;;; eval.scm --- The R6RS `eval' library
+
+;; 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 (rnrs eval (6))
+ (export eval environment)
+ (import (only (guile) eval
+ make-module
+ module-uses
+ beautify-user-module!
+ set-module-uses!)
+ (rnrs base (6))
+ (rnrs io simple (6))
+ (rnrs lists (6)))
+
+ (define (environment . import-specs)
+ (let ((module (make-module))
+ (needs-purify? (not (member '(guile) import-specs))))
+ (beautify-user-module! module)
+ (for-each (lambda (import-spec) (eval (list 'import import-spec) module))
+ import-specs)
+ (if needs-purify? (set-module-uses! module (cdr (module-uses module))))
+ module))
+)
diff --git a/module/rnrs/6/exceptions.scm b/module/rnrs/6/exceptions.scm
new file mode 100644
index 0000000..d810f2b
--- /dev/null
+++ b/module/rnrs/6/exceptions.scm
@@ -0,0 +1,67 @@
+;;; exceptions.scm --- The R6RS exceptions library
+
+;; 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 (rnrs exceptions (6))
+ (export guard with-exception-handler raise raise-continuable)
+ (import (rnrs base (6))
+ (rnrs conditions (6))
+ (rnrs records procedural (6))
+ (only (guile) with-throw-handler @@))
+
+ (define raise (@@ (rnrs records procedural) r6rs-raise))
+ (define raise-continuable
+ (@@ (rnrs records procedural) r6rs-raise-continuable))
+ (define raise-object-wrapper?
+ (@@ (rnrs records procedural) raise-object-wrapper?))
+ (define raise-object-wrapper-obj
+ (@@ (rnrs records procedural) raise-object-wrapper-obj))
+ (define raise-object-wrapper-continuation
+ (@@ (rnrs records procedural) raise-object-wrapper-continuation))
+
+ (define (with-exception-handler handler thunk)
+ (with-throw-handler 'r6rs:exception
+ thunk
+ (lambda (key . args)
+ (if (and (not (null? args))
+ (raise-object-wrapper? (car args)))
+ (let* ((cargs (car args))
+ (obj (raise-object-wrapper-obj cargs))
+ (continuation (raise-object-wrapper-continuation cargs))
+ (handler-return (handler obj)))
+ (if continuation
+ (continuation handler-return)
+ (raise (make-non-continuable-violation))))
+ *unspecified*))))
+
+ (define-syntax guard0
+ (syntax-rules ()
+ ((_ (variable cond-clause ...) body)
+ (call/cc (lambda (continuation)
+ (with-exception-handler
+ (lambda (variable)
+ (continuation (cond cond-clause ...)))
+ (lambda () body)))))))
+
+ (define-syntax guard
+ (syntax-rules (else)
+ ((_ (variable cond-clause ... . ((else else-clause ...))) body)
+ (guard0 (variable cond-clause ... (else else-clause ...)) body))
+ ((_ (variable cond-clause ...) body)
+ (guard0 (variable cond-clause ... (else (raise variable))) body))))
+)
diff --git a/module/rnrs/6/files.scm b/module/rnrs/6/files.scm
new file mode 100644
index 0000000..e6851d0
--- /dev/null
+++ b/module/rnrs/6/files.scm
@@ -0,0 +1,125 @@
+;;; files.scm --- The R6RS file system library
+
+;; 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 (rnrs files (6))
+ (export file-exists?
+ delete-file
+
+ &i/o make-i/o-error i/o-error?
+ &i/o-read make-i/o-read-error i/o-read-error?
+ &i/o-write make-i/o-write-error i/o-write-error?
+
+ &i/o-invalid-position
+ make-i/o-invalid-position-error
+ i/o-invalid-position-error?
+ i/o-error-position
+
+ &i/o-filename
+ make-i/o-filename-error
+ i/o-filename-error?
+ i/o-error-filename
+
+ &i/o-file-protection
+ make-i/o-file-protection-error
+ i/o-file-protection-error?
+
+ &i/o-file-is-read-only
+ make-i/o-file-is-read-only-error
+ i/o-file-is-read-only-error?
+
+ &i/o-file-already-exists
+ make-i/o-file-already-exists-error
+ i/o-file-already-exists-error?
+
+ &i/o-file-does-not-exist
+ make-i/o-file-does-not-exist-error
+ i/o-file-does-not-exist-error?
+
+ &i/o-port
+ make-i/o-port-error
+ i/o-port-error?
+ i/o-error-port)
+
+ (import (rename (only (guile) file-exists? delete-file catch @@)
+ (delete-file delete-file-internal))
+ (rnrs base (6))
+ (rnrs conditions (6))
+ (rnrs exceptions (6)))
+
+ (define (delete-file filename)
+ (catch #t
+ (lambda () (delete-file-internal filename))
+ (lambda (key . args) (raise (make-i/o-filename-error filename)))))
+
+ (define &i/o (@@ (rnrs conditions) &i/o))
+ (define make-i/o-error (@@ (rnrs conditions) make-i/o-error))
+ (define i/o-error? (@@ (rnrs conditions) i/o-error?))
+
+ (define &i/o-read (@@ (rnrs conditions) &i/o-read))
+ (define make-i/o-read-error (@@ (rnrs conditions) make-i/o-read-error))
+ (define i/o-read-error? (@@ (rnrs conditions) i/o-read-error?))
+
+ (define &i/o-write (@@ (rnrs conditions) &i/o-write))
+ (define make-i/o-write-error (@@ (rnrs conditions) make-i/o-write-error))
+ (define i/o-write-error? (@@ (rnrs conditions) i/o-write-error?))
+
+ (define &i/o-invalid-position (@@ (rnrs conditions) &i/o-invalid-position))
+ (define make-i/o-invalid-position-error
+ (@@ (rnrs conditions) make-i/o-invalid-position-error))
+ (define i/o-invalid-position-error?
+ (@@ (rnrs conditions) i/o-invalid-position-error?))
+ (define i/o-error-position (@@ (rnrs conditions) i/o-error-position))
+
+ (define &i/o-filename (@@ (rnrs conditions) &i/o-filename))
+ (define make-i/o-filename-error
+ (@@ (rnrs conditions) make-i/o-filename-error))
+ (define i/o-filename-error? (@@ (rnrs conditions) i/o-filename-error?))
+ (define i/o-error-filename (@@ (rnrs conditions) i/o-error-filename))
+
+ (define &i/o-file-protection (@@ (rnrs conditions) &i/o-file-protection))
+ (define make-i/o-file-protection-error
+ (@@ (rnrs conditions) make-i/o-file-protection-error))
+ (define i/o-file-protection-error?
+ (@@ (rnrs conditions) i/o-file-protection-error?))
+
+ (define &i/o-file-is-read-only (@@ (rnrs conditions) &i/o-file-is-read-only))
+ (define make-i/o-file-is-read-only-error
+ (@@ (rnrs conditions) make-i/o-file-is-read-only-error))
+ (define i/o-file-is-read-only-error?
+ (@@ (rnrs conditions) i/o-file-is-read-only-error?))
+
+ (define &i/o-file-already-exists
+ (@@ (rnrs conditions) &i/o-file-already-exists))
+ (define make-i/o-file-already-exists-error
+ (@@ (rnrs conditions) make-i/o-file-already-exists-error))
+ (define i/o-file-already-exists-error?
+ (@@ (rnrs conditions) i/o-file-already-exists-error?))
+
+ (define &i/o-file-does-not-exist
+ (@@ (rnrs conditions) &i/o-file-does-not-exist))
+ (define make-i/o-file-does-not-exist-error
+ (@@ (rnrs conditions) make-i/o-file-does-not-exist-error))
+ (define i/o-file-does-not-exist-error?
+ (@@ (rnrs conditions) i/o-file-does-not-exist-error?))
+
+ (define &i/o-port (@@ (rnrs conditions) &i/o-port))
+ (define make-i/o-port-error (@@ (rnrs conditions) make-i/o-port-error))
+ (define i/o-port-error? (@@ (rnrs conditions) i/o-port-error?))
+ (define i/o-error-port (@@ (rnrs conditions) i/o-error-port))
+)
diff --git a/module/rnrs/6/hashtables.scm b/module/rnrs/6/hashtables.scm
new file mode 100644
index 0000000..48ca5f3
--- /dev/null
+++ b/module/rnrs/6/hashtables.scm
@@ -0,0 +1,179 @@
+;;; hashtables.scm --- The R6RS hashtables library
+
+;; 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 (rnrs hashtables (6))
+ (export make-eq-hashtable
+ make-eqv-hashtable
+ make-hashtable
+
+ hashtable?
+ hashtable-size
+ hashtable-ref
+ hashtable-set!
+ hashtable-delete!
+ hashtable-contains?
+ hashtable-update!
+ hashtable-copy
+ hashtable-clear!
+ hashtable-keys
+ hashtable-entries
+
+ hashtable-equivalence-function
+ hashtable-hash-function
+ hashtable-mutable?
+
+ equal-hash
+ string-hash
+ string-ci-hash
+ symbol-hash)
+ (import (rename (only (guile) string-hash-ci
+ string-hash
+ hashq
+ hashv
+ *unspecified*
+ @@)
+ (string-hash-ci string-ci-hash))
+ (only (ice-9 optargs) define*)
+ (rename (only (srfi :69) make-hash-table
+ hash
+ hash-by-identity
+ hash-table-size
+ hash-table-ref/default
+ hash-table-set!
+ hash-table-delete!
+ hash-table-exists?
+ hash-table-update!/default
+ hash-table-copy
+ hash-table-equivalence-function
+ hash-table-hash-function
+ hash-table-keys
+ hash-table-fold)
+ (hash equal-hash)
+ (hash-by-identity symbol-hash))
+ (rnrs base (6))
+ (rnrs records procedural (6)))
+
+ (define r6rs:hashtable
+ (make-record-type-descriptor
+ 'r6rs:hashtable #f #f #t #t
+ '#((mutable wrapped-table)
+ (immutable orig-hash-function)
+ (immutable mutable))))
+
+ (define hashtable? (record-predicate r6rs:hashtable))
+ (define make-r6rs-hashtable
+ (record-constructor (make-record-constructor-descriptor
+ r6rs:hashtable #f #f)))
+ (define r6rs:hashtable-wrapped-table (record-accessor r6rs:hashtable 0))
+ (define r6rs:hashtable-set-wrapped-table! (record-mutator r6rs:hashtable 0))
+ (define r6rs:hashtable-orig-hash-function (record-accessor r6rs:hashtable 1))
+ (define r6rs:hashtable-mutable? (record-accessor r6rs:hashtable 2))
+
+ (define hashtable-mutable? r6rs:hashtable-mutable?)
+
+ (define hash-by-value ((@@ (srfi srfi-69) caller-with-default-size) hashv))
+ (define (wrap-hash-function proc) (lambda (key obj) (proc key)))
+
+ (define* (make-eq-hashtable #:optional k)
+ (make-r6rs-hashtable
+ (if k (make-hash-table eq? hashq k) (make-hash-table eq? symbol-hash))
+ symbol-hash
+ #t))
+
+ (define* (make-eqv-hashtable #:optional k)
+ (make-r6rs-hashtable
+ (if k (make-hash-table eqv? hashv k) (make-hash-table eqv? hash-by-value))
+ hash-by-value
+ #t))
+
+ (define* (make-hashtable hash-function equiv #:optional k)
+ (let ((wrapped-hash-function (wrap-hash-function hash-function)))
+ (make-r6rs-hashtable
+ (if k
+ (make-hash-table equiv wrapped-hash-function k)
+ (make-hash-table equiv wrapped-hash-function))
+ hash-function
+ #t)))
+
+ (define (hashtable-size hashtable)
+ (hash-table-size (r6rs:hashtable-wrapped-table hashtable)))
+
+ (define (hashtable-ref hashtable key default)
+ (hash-table-ref/default
+ (r6rs:hashtable-wrapped-table hashtable) key default))
+
+ (define (hashtable-set! hashtable key obj)
+ (if (r6rs:hashtable-mutable? hashtable)
+ (hash-table-set! (r6rs:hashtable-wrapped-table hashtable) key obj))
+ *unspecified*)
+
+ (define (hashtable-delete! hashtable key)
+ (if (r6rs:hashtable-mutable? hashtable)
+ (hash-table-delete! (r6rs:hashtable-wrapped-table hashtable) key))
+ *unspecified*)
+
+ (define (hashtable-contains? hashtable key)
+ (hash-table-exists? (r6rs:hashtable-wrapped-table hashtable) key))
+
+ (define (hashtable-update! hashtable key proc default)
+ (if (r6rs:hashtable-mutable? hashtable)
+ (hash-table-update!/default
+ (r6rs:hashtable-wrapped-table hashtable) key proc default))
+ *unspecified*)
+
+ (define* (hashtable-copy hashtable #:optional mutable)
+ (make-r6rs-hashtable
+ (hash-table-copy (r6rs:hashtable-wrapped-table hashtable))
+ (r6rs:hashtable-orig-hash-function hashtable)
+ (and mutable #t)))
+
+ (define* (hashtable-clear! hashtable #:optional k)
+ (if (r6rs:hashtable-mutable? hashtable)
+ (let* ((ht (r6rs:hashtable-wrapped-table hashtable))
+ (equiv (hash-table-equivalence-function ht))
+ (hash-function (r6rs:hashtable-orig-hash-function hashtable))
+ (wrapped-hash-function (wrap-hash-function hash-function)))
+ (r6rs:hashtable-set-wrapped-table!
+ hashtable
+ (if k
+ (make-hash-table equiv wrapped-hash-function k)
+ (make-hash-table equiv wrapped-hash-function)))))
+ *unspecified*)
+
+ (define (hashtable-keys hashtable)
+ (list->vector (hash-table-keys (r6rs:hashtable-wrapped-table hashtable))))
+
+ (define (hashtable-entries hashtable)
+ (let* ((ht (r6rs:hashtable-wrapped-table hashtable))
+ (size (hash-table-size ht))
+ (keys (make-vector size))
+ (vals (make-vector size)))
+ (hash-table-fold (r6rs:hashtable-wrapped-table hashtable)
+ (lambda (k v i)
+ (vector-set! keys i k)
+ (vector-set! vals i v)
+ (+ i 1))
+ 0)
+ (values keys vals)))
+
+ (define (hashtable-equivalence-function hashtable)
+ (hash-table-equivalence-function (r6rs:hashtable-wrapped-table hashtable)))
+
+ (define (hashtable-hash-function hashtable)
+ (r6rs:hashtable-orig-hash-function hashtable)))
diff --git a/module/rnrs/6/lists.scm b/module/rnrs/6/lists.scm
new file mode 100644
index 0000000..c9d913b
--- /dev/null
+++ b/module/rnrs/6/lists.scm
@@ -0,0 +1,49 @@
+;;; lists.scm --- The R6RS list utilities library
+
+;; 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 (rnrs lists (6))
+ (export find for-all exists filter partition fold-left fold-right remp
remove
+ remv remq memp member memv memq assp assoc assv assq cons*)
+ (import (rnrs base (6))
+ (only (guile) filter member memv memq assoc assv assq cons*)
+ (rename (only (srfi srfi-1) fold
+ any
+ every
+ remove
+ member
+ assoc
+ find
+ partition
+ fold-right
+ filter-map)
+ (fold fold-left)
+ (any exists)
+ (every for-all)
+ (remove remp)
+
+ (member memp-internal)
+ (assoc assp-internal)))
+
+ (define (remove obj list) (remp (lambda (elt) (equal? obj elt)) list))
+ (define (remv obj list) (remp (lambda (elt) (eqv? obj elt)) list))
+ (define (remq obj list) (remp (lambda (elt) (eq? obj elt)) list))
+
+ (define (memp pred list) (memp-internal #f list pred))
+ (define (assp pred list) (assp-internal #f list pred))
+)
diff --git a/module/rnrs/6/mutable-pairs.scm b/module/rnrs/6/mutable-pairs.scm
new file mode 100644
index 0000000..3e5da14
--- /dev/null
+++ b/module/rnrs/6/mutable-pairs.scm
@@ -0,0 +1,22 @@
+;;; mutable-pairs.scm --- The R6RS mutable pair library
+
+;; 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
+^L
+
+(library (rnrs mutable-pairs (6))
+ (export set-car! set-cdr!)
+ (import (only (guile) set-car! set-cdr!)))
diff --git a/module/rnrs/6/mutable-strings.scm
b/module/rnrs/6/mutable-strings.scm
new file mode 100644
index 0000000..1eeb8f3
--- /dev/null
+++ b/module/rnrs/6/mutable-strings.scm
@@ -0,0 +1,22 @@
+;;; mutable-strings.scm --- The R6RS mutable string library
+
+;; 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
+^L
+
+(library (rnrs mutable-strings (6))
+ (export string-set! string-fill!)
+ (import (only (guile) string-set! string-fill!)))
diff --git a/module/rnrs/6/programs.scm b/module/rnrs/6/programs.scm
new file mode 100644
index 0000000..4daa781
--- /dev/null
+++ b/module/rnrs/6/programs.scm
@@ -0,0 +1,22 @@
+;;; programs.scm --- The R6RS process management library
+
+;; 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 (rnrs programs (6))
+ (export command-line exit)
+ (import (only (guile) command-line exit)))
diff --git a/module/rnrs/6/r5rs.scm b/module/rnrs/6/r5rs.scm
new file mode 100644
index 0000000..ab74854
--- /dev/null
+++ b/module/rnrs/6/r5rs.scm
@@ -0,0 +1,34 @@
+;;; r5rs.scm --- The R6RS / R5RS compatibility library
+
+;; 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 (rnrs r5rs (6))
+ (export exact->inexact inexact->exact
+
+ quotient remainder modulo
+
+ delay force
+
+ null-environment scheme-report-environment)
+ (import (only (guile) exact->inexact inexact->exact
+
+ quotient remainder modulo
+
+ delay force)
+ (only (ice-9 r5rs) scheme-report-environment)
+ (only (ice-9 safe-r5rs) null-environment)))
diff --git a/module/rnrs/6/sorting.scm b/module/rnrs/6/sorting.scm
new file mode 100644
index 0000000..08f44b8
--- /dev/null
+++ b/module/rnrs/6/sorting.scm
@@ -0,0 +1,27 @@
+;;; sorting.scm --- The R6RS sorting library
+
+;; 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 (rnrs sorting (6))
+ (export list-sort vector-sort vector-sort!)
+ (import (rnrs base (6))
+ (only (guile) *unspecified* stable-sort sort!))
+
+ (define (list-sort proc list) (stable-sort list proc))
+ (define (vector-sort proc vector) (stable-sort vector proc))
+ (define (vector-sort! proc vector) (sort! vector proc) *unspecified*))
diff --git a/module/rnrs/6/syntax-case.scm b/module/rnrs/6/syntax-case.scm
new file mode 100644
index 0000000..6aa1cef
--- /dev/null
+++ b/module/rnrs/6/syntax-case.scm
@@ -0,0 +1,67 @@
+;;; syntax-case.scm --- R6RS support for `syntax-case' macros
+
+;; 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 (rnrs syntax-case (6))
+ (export make-variable-transformer
+ syntax-case
+ syntax
+
+ identifier?
+ bound-identifier=?
+ free-identifier=?
+
+ syntax->datum
+ datum->syntax
+ generate-temporaries
+ with-syntax
+
+ quasisyntax
+ unsyntax
+ unsyntax-splicing
+
+ syntax-violation)
+ (import (only (guile) syntax-case
+ syntax
+
+ identifier?
+ bound-identifier=?
+ free-identifier=?
+
+ syntax->datum
+ datum->syntax
+ generate-temporaries
+ with-syntax
+
+ quasisyntax
+ unsyntax
+ unsyntax-splicing)
+ (ice-9 optargs)
+ (rnrs base (6))
+ (rnrs conditions (6))
+ (rnrs exceptions (6))
+ (rnrs records procedural (6)))
+
+ (define* (syntax-violation who message form #:optional subform)
+ (let* ((conditions (list (make-message-condition message)
+ (make-syntax-violation form subform)))
+ (conditions (if who
+ (cons (make-who-condition who) conditions)
+ conditions)))
+ (raise (apply condition conditions))))
+)
diff --git a/module/rnrs/6/unicode.scm b/module/rnrs/6/unicode.scm
new file mode 100644
index 0000000..09140b6
--- /dev/null
+++ b/module/rnrs/6/unicode.scm
@@ -0,0 +1,104 @@
+;;; unicode.scm --- The R6RS Unicode library
+
+;; 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 (rnrs unicode (6))
+ (export char-upcase
+ char-downcase
+ char-titlecase
+ char-foldcase
+
+ char-ci=?
+ char-ci<?
+ char-ci>?
+ char-ci<=?
+ char-ci>=?
+
+ char-alphabetic?
+ char-numeric?
+ char-whitespace?
+ char-upper-case?
+ char-lower-case?
+ char-title-case?
+
+ char-general-category
+
+ string-upcase
+ string-downcase
+ string-titlecase
+ string-foldcase
+
+ string-ci=?
+ string-ci<?
+ string-ci>?
+ string-ci<=?
+ string-ci>=?
+
+ string-normalize-nfd
+ string-normalize-nfkd
+ string-normalize-nfc
+ string-normalize-nfkc)
+ (import (only (guile) char-upcase
+ char-downcase
+ char-titlecase
+
+ char-ci=?
+ char-ci<?
+ char-ci>?
+ char-ci<=?
+ char-ci>=?
+
+ char-alphabetic?
+ char-numeric?
+ char-whitespace?
+ char-upper-case?
+ char-lower-case?
+
+ char-set-contains?
+ char-set:title-case
+
+ char-general-category
+
+ char-upcase
+ char-downcase
+ char-titlecase
+
+ string-upcase
+ string-downcase
+ string-titlecase
+
+ string-ci=?
+ string-ci<?
+ string-ci>?
+ string-ci<=?
+ string-ci>=?
+
+ string-normalize-nfd
+ string-normalize-nfkd
+ string-normalize-nfc
+ string-normalize-nfkc)
+ (rnrs base (6)))
+
+ (define (char-foldcase char)
+ (if (or (eqv? char #\460) (eqv? char #\461))
+ char (char-downcase (char-upcase char))))
+
+ (define (char-title-case? char) (char-set-contains? char-set:title-case
char))
+
+ (define (string-foldcase str) (string-downcase (string-upcase str)))
+)
diff --git a/module/rnrs/arithmetic/6/bitwise.scm
b/module/rnrs/arithmetic/6/bitwise.scm
new file mode 100644
index 0000000..bb3a207
--- /dev/null
+++ b/module/rnrs/arithmetic/6/bitwise.scm
@@ -0,0 +1,125 @@
+;;; bitwise.scm --- The R6RS bitwise arithmetic operations library
+
+;; 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 (rnrs arithmetic bitwise (6))
+ (export bitwise-not
+
+ bitwise-and
+ bitwise-ior
+ bitwise-xor
+
+ bitwise-if
+ bitwise-bit-count
+ bitwise-length
+
+ bitwise-first-bit-set
+ bitwise-bit-set?
+ bitwise-copy-bit
+ bitwise-bit-field
+ bitwise-copy-bit-field
+
+ bitwise-arithmetic-shift
+ bitwise-arithmetic-shift-left
+ bitwise-arithmetic-shift-right
+ bitwise-rotate-bit-field
+ bitwise-reverse-bit-field)
+ (import (rnrs base (6))
+ (rnrs control (6))
+ (rename (only (guile) lognot
+ logand
+ logior
+ logxor
+ logcount
+ logbit?
+ modulo
+ ash)
+ (lognot bitwise-not)
+ (logand bitwise-and)
+ (logior bitwise-ior)
+ (logxor bitwise-xor)
+ (logcount bitwise-bit-count)
+ (ash bitwise-arithmetic-shift)))
+
+ (define (bitwise-if ei1 ei2 ei3)
+ (bitwise-ior (bitwise-and ei1 ei2) (bitwise-and (bitwise-not ei1) ei3)))
+
+ (define (bitwise-length ei)
+ (do ((result 0 (+ result 1))
+ (bits (if (negative? ei) (bitwise-not ei) ei)
+ (bitwise-arithmetic-shift bits -1)))
+ ((zero? bits)
+ result)))
+
+ (define (bitwise-first-bit-set ei)
+ (define (bitwise-first-bit-set-inner bits count)
+ (cond ((zero? bits) -1)
+ ((logbit? 0 bits) count)
+ (else (bitwise-first-bit-set-inner
+ (bitwise-arithmetic-shift bits -1) (+ count 1)))))
+ (bitwise-first-bit-set-inner ei 0))
+
+ (define (bitwise-bit-set? ei1 ei2) (logbit? ei2 ei1))
+
+ (define (bitwise-copy-bit ei1 ei2 ei3)
+ (bitwise-if (bitwise-arithmetic-shift-left 1 ei2)
+ (bitwise-arithmetic-shift-left ei3 ei2)
+ ei1))
+
+ (define (bitwise-bit-field ei1 ei2 ei3)
+ (bitwise-arithmetic-shift-right
+ (bitwise-and ei1 (bitwise-not (bitwise-arithmetic-shift-left -1 ei3)))
+ ei2))
+
+ (define (bitwise-copy-bit-field ei1 ei2 ei3 ei4)
+ (bitwise-if (bitwise-and (bitwise-arithmetic-shift-left -1 ei2)
+ (bitwise-not
+ (bitwise-arithmetic-shift-left -1 ei3)))
+ (bitwise-arithmetic-shift-left ei4 ei2)
+ ei1))
+
+ (define bitwise-arithmetic-shift-left bitwise-arithmetic-shift)
+ (define (bitwise-arithmetic-shift-right ei1 ei2)
+ (bitwise-arithmetic-shift ei1 (- ei2)))
+
+ (define (bitwise-rotate-bit-field ei1 ei2 ei3 ei4)
+ (let ((width (- ei3 ei2)))
+ (if (positive? width)
+ (let ((field (bitwise-bit-field ei1 ei2 ei3))
+ (count (modulo ei4 width)))
+ (bitwise-copy-bit-field
+ ei1 ei2 ei3
+ (bitwise-ior (bitwise-arithmetic-shift-left field count)
+ (bitwise-arithmetic-shift-right
+ field (- width count)))))
+ ei1)))
+
+ (define (bitwise-reverse-bit-field ei1 ei2 ei3)
+ (define (reverse-bit-field-recursive n1 n2 len)
+ (if (> len 0)
+ (reverse-bit-field-recursive
+ (bitwise-arithmetic-shift-right n1 1)
+ (bitwise-copy-bit (bitwise-arithmetic-shift-left n2 1) 0 n1)
+ (- len 1))
+ n2))
+ (let ((width (- ei3 ei2)))
+ (if (positive? width)
+ (let ((field (bitwise-bit-field ei1 ei2 ei3)))
+ (bitwise-copy-bit-field
+ ei1 ei2 ei3 (reverse-bit-field-recursive field 0 width)))
+ ei1))))
diff --git a/module/rnrs/arithmetic/6/fixnums.scm
b/module/rnrs/arithmetic/6/fixnums.scm
new file mode 100644
index 0000000..cda1933
--- /dev/null
+++ b/module/rnrs/arithmetic/6/fixnums.scm
@@ -0,0 +1,268 @@
+;;; fixnums.scm --- The R6RS fixnums arithmetic library
+
+;; 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 (rnrs arithmetic fixnums (6))
+ (export fixnum?
+
+ fixnum-width
+ least-fixnum
+ greatest-fixnum
+
+ fx=?
+ fx>?
+ fx<?
+ fx>=?
+ fx<=?
+
+ fxzero?
+ fxpositive?
+ fxnegative?
+ fxodd?
+ fxeven?
+
+ fxmax
+ fxmin
+
+ fx+
+ fx*
+ fx-
+
+ fxdiv-and-mod
+ fxdiv
+ fxmod
+ fxdiv0-and-mod0
+ fxdiv0
+ fxmod0
+
+ fx+/carry
+ fx-/carry
+ fx*/carry
+
+ fxnot
+ fxand
+ fxior
+ fxxor
+ fxif
+
+ fxbit-count
+ fxlength
+ fxfirst-bit-set
+ fxbit-set?
+ fxcopy-bit
+ fxbit-field
+ fxcopy-bit-field
+
+ fxarithmetic-shift
+ fxarithmetic-shift-left
+ fxarithmetic-shift-right
+
+ fxrotate-bit-field
+ fxreverse-bit-field)
+ (import (only (guile) ash
+ cons*
+ inexact->exact
+ logand
+ logbit?
+ logcount
+ logior
+ lognot
+ logxor
+ most-positive-fixnum
+ most-negative-fixnum)
+ (ice-9 optargs)
+ (rnrs base (6))
+ (rnrs arithmetic bitwise (6))
+ (rnrs conditions (6))
+ (rnrs exceptions (6))
+ (rnrs lists (6)))
+
+ (define fixnum-width
+ (let ((w (round (/ (log (+ most-positive-fixnum 1)) (log 2)))))
+ (lambda () w)))
+
+ (define (greatest-fixnum) most-positive-fixnum)
+ (define (least-fixnum) most-negative-fixnum)
+
+ (define (fixnum? obj)
+ (and (integer? obj)
+ (exact? obj)
+ (>= obj most-negative-fixnum)
+ (<= obj most-positive-fixnum)))
+
+ (define (assert-fixnum . args)
+ (or (for-all fixnum? args) (raise (make-assertion-violation))))
+
+ (define (fx=? fx1 fx2 . rst)
+ (let ((args (cons* fx1 fx2 rst)))
+ (apply assert-fixnum args)
+ (apply = args)))
+
+ (define (fx>? fx1 fx2 . rst)
+ (let ((args (cons* fx1 fx2 rst)))
+ (apply assert-fixnum args)
+ (apply > args)))
+
+ (define (fx<? fx1 fx2 . rst)
+ (let ((args (cons* fx1 fx2 rst)))
+ (apply assert-fixnum rst)
+ (apply < args)))
+
+ (define (fx>=? fx1 fx2 . rst)
+ (let ((args (cons* fx1 fx2 rst)))
+ (apply assert-fixnum rst)
+ (apply >= args)))
+
+ (define (fx<=? fx1 fx2 . rst)
+ (let ((args (cons* fx1 fx2 rst)))
+ (apply assert-fixnum rst)
+ (apply <= args)))
+
+ (define (fxzero? fx) (assert-fixnum fx) (zero? fx))
+ (define (fxpositive? fx) (assert-fixnum fx) (positive? fx))
+ (define (fxnegative? fx) (assert-fixnum fx) (negative? fx))
+ (define (fxodd? fx) (assert-fixnum fx) (odd? fx))
+ (define (fxeven? fx) (assert-fixnum fx) (even? fx))
+
+ (define (fxmax fx1 fx2 . rst)
+ (let ((args (cons* fx1 fx2 rst)))
+ (apply assert-fixnum args)
+ (apply max args)))
+
+ (define (fxmin fx1 fx2 . rst)
+ (let ((args (cons* fx1 fx2 rst)))
+ (apply assert-fixnum args)
+ (apply min args)))
+
+ (define (fx+ fx1 fx2)
+ (assert-fixnum fx1 fx2)
+ (let ((r (+ fx1 fx2)))
+ (or (fixnum? r) (raise (make-implementation-restriction-violation)))
+ r))
+
+ (define (fx* fx1 fx2)
+ (assert-fixnum fx1 fx2)
+ (let ((r (* fx1 fx2)))
+ (or (fixnum? r) (raise (make-implementation-restriction-violation)))
+ r))
+
+ (define* (fx- fx1 #:optional fx2)
+ (assert-fixnum fx1)
+ (if fx2
+ (begin
+ (assert-fixnum fx2)
+ (let ((r (- fx1 fx2)))
+ (or (fixnum? r) (raise (make-assertion-violation)))
+ r))
+ (let ((r (- fx1)))
+ (or (fixnum? r) (raise (make-assertion-violation)))
+ r)))
+
+ (define (fxdiv fx1 fx2)
+ (assert-fixnum fx1 fx2)
+ (if (zero? fx2) (raise (make-assertion-violation)))
+ (let ((r (div fx1 fx2))) r))
+
+ (define (fxmod fx1 fx2)
+ (assert-fixnum fx1 fx2)
+ (if (zero? fx2) (raise (make-assertion-violation)))
+ (let ((r (mod fx1 fx2))) r))
+
+ (define (fxdiv-and-mod fx1 fx2)
+ (assert-fixnum fx1 fx2)
+ (if (zero? fx2) (raise (make-assertion-violation)))
+ (div-and-mod fx1 fx2))
+
+ (define (fxdiv0 fx1 fx2)
+ (assert-fixnum fx1 fx2)
+ (if (zero? fx2) (raise (make-assertion-violation)))
+ (let ((r (div0 fx1 fx2))) r))
+
+ (define (fxmod0 fx1 fx2)
+ (assert-fixnum fx1 fx2)
+ (if (zero? fx2) (raise (make-assertion-violation)))
+ (let ((r (mod0 fx1 fx2))) r))
+
+ (define (fxdiv0-and-mod0 fx1 fx2)
+ (assert-fixnum fx1 fx2)
+ (if (zero? fx2) (raise (make-assertion-violation)))
+ (call-with-values (lambda () (div0-and-mod0 fx1 fx2))
+ (lambda (q r) (values q r))))
+
+ (define (fx+/carry fx1 fx2 fx3)
+ (assert-fixnum fx1 fx2 fx3)
+ (let* ((s (+ fx1 fx2 fx3))
+ (s0 (mod0 s (inexact->exact (expt 2 (fixnum-width)))))
+ (s1 (div0 s (inexact->exact (expt 2 (fixnum-width))))))
+ (values s0 s1)))
+
+ (define (fx-/carry fx1 fx2 fx3)
+ (assert-fixnum fx1 fx2 fx3)
+ (let* ((d (- fx1 fx2 fx3))
+ (d0 (mod0 d (expt 2 (fixnum-width))))
+ (d1 (div0 d (expt 2 (fixnum-width)))))
+ (values d0 d1)))
+
+ (define (fx*/carry fx1 fx2 fx3)
+ (assert-fixnum fx1 fx2 fx3)
+ (let* ((s (+ (* fx1 fx2) fx3))
+ (s0 (mod0 s (expt 2 (fixnum-width))))
+ (s1 (div0 s (expt 2 (fixnum-width)))))
+ (values s0 s1)))
+
+ (define (fxnot fx) (assert-fixnum fx) (lognot fx))
+ (define (fxand . args) (apply assert-fixnum args) (apply logand args))
+ (define (fxior . args) (apply assert-fixnum args) (apply logior args))
+ (define (fxxor . args) (apply assert-fixnum args) (apply logxor args))
+
+ (define (fxif fx1 fx2 fx3)
+ (assert-fixnum fx1 fx2 fx3)
+ (bitwise-if fx1 fx2 fx3))
+
+ (define (fxbit-count fx) (assert-fixnum fx) (logcount fx))
+ (define (fxlength fx) (assert-fixnum fx) (bitwise-length fx))
+ (define (fxfirst-bit-set fx) (assert-fixnum fx) (bitwise-first-bit-set fx))
+ (define (fxbit-set? fx1 fx2) (assert-fixnum fx1 fx2) (logbit? fx2 fx1))
+
+ (define (fxcopy-bit fx1 fx2 fx3)
+ (assert-fixnum fx1 fx2 fx3)
+ (bitwise-copy-bit fx1 fx2 fx3))
+
+ (define (fxbit-field fx1 fx2 fx3)
+ (assert-fixnum fx1 fx2 fx3)
+ (bitwise-bit-field fx1 fx2 fx3))
+
+ (define (fxcopy-bit-field fx1 fx2 fx3 fx4)
+ (assert-fixnum fx1 fx2 fx3 fx4)
+ (bitwise-copy-bit-field fx1 fx2 fx3 fx4))
+
+ (define (fxarithmetic-shift fx1 fx2) (assert-fixnum fx1 fx2) (ash fx1 fx2))
+ (define fxarithmetic-shift-left fxarithmetic-shift)
+
+ (define (fxarithmetic-shift-right fx1 fx2)
+ (assert-fixnum fx1 fx2) (ash fx1 (- fx2)))
+
+ (define (fxrotate-bit-field fx1 fx2 fx3 fx4)
+ (assert-fixnum fx1 fx2 fx3 fx4)
+ (bitwise-rotate-bit-field fx1 fx2 fx3 fx4))
+
+ (define (fxreverse-bit-field fx1 fx2 fx3)
+ (assert-fixnum fx1 fx2 fx3)
+ (bitwise-reverse-bit-field fx1 fx2 fx3))
+
+)
diff --git a/module/rnrs/arithmetic/6/flonums.scm
b/module/rnrs/arithmetic/6/flonums.scm
new file mode 100644
index 0000000..4fadbd0
--- /dev/null
+++ b/module/rnrs/arithmetic/6/flonums.scm
@@ -0,0 +1,216 @@
+;;; flonums.scm --- The R6RS flonums arithmetic library
+
+;; 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 (rnrs arithmetic flonums (6))
+ (export flonum?
+ real->flonum
+
+ fl=? fl<? fl<=? fl>? fl>=?
+
+ flinteger? flzero? flpositive? flnegative? flodd? fleven? flfinite?
+ flinfinite? flnan?
+
+ flmax flmin
+
+ fl+ fl* fl- fl/
+
+ flabs
+
+ fldiv-and-mod
+ fldiv
+ flmod
+ fldiv0-and-mod0
+ fldiv0
+ flmod0
+
+ flnumerator
+ fldenominator
+
+ flfloor flceiling fltruncate flround
+
+ flexp fllog flsin flcos fltan flacos flasin flatan
+
+ flsqrt flexpt
+
+ &no-infinities
+ make-no-infinities-violation
+ no-infinities-violation?
+
+ &no-nans
+ make-no-nans-violation
+ no-nans-violation?
+
+ fixnum->flonum)
+ (import (ice-9 optargs)
+ (only (guile) inf?)
+ (rnrs arithmetic fixnums (6))
+ (rnrs base (6))
+ (rnrs conditions (6))
+ (rnrs exceptions (6))
+ (rnrs lists (6))
+ (rnrs r5rs (6)))
+
+ (define (flonum? obj) (and (number? obj) (inexact? obj)))
+ (define (assert-flonum . args)
+ (or (for-all flonum? args) (raise (make-assertion-violation))))
+ (define (assert-iflonum . args)
+ (or (for-all (lambda (i) (and (flonum? i) (integer? i))) args)
+ (raise (make-assertion-violation))))
+
+ (define (real->flonum x)
+ (or (real? x) (raise (make-assertion-violation)))
+ (exact->inexact x))
+
+ (define (fl=? . args) (apply assert-flonum args) (apply = args))
+ (define (fl<? . args) (apply assert-flonum args) (apply < args))
+ (define (fl<=? . args) (apply assert-flonum args) (apply <= args))
+ (define (fl>? . args) (apply assert-flonum args) (apply > args))
+ (define (fl>=? . args) (apply assert-flonum args) (apply >= args))
+
+ (define (flinteger? fl) (assert-flonum fl) (integer? fl))
+ (define (flzero? fl) (assert-flonum fl) (zero? fl))
+ (define (flpositive? fl) (assert-flonum fl) (positive? fl))
+ (define (flnegative? fl) (assert-flonum fl) (negative? fl))
+ (define (flodd? ifl) (assert-iflonum ifl) (odd? ifl))
+ (define (fleven? ifl) (assert-iflonum ifl) (even? ifl))
+ (define (flfinite? fl) (assert-flonum fl) (not (inf? fl)))
+ (define (flinfinite? fl) (assert-flonum fl) (inf? fl))
+ (define (flnan? fl) (assert-flonum fl) (nan? fl))
+
+ (define (flmax fl1 . args)
+ (let ((flargs (cons fl1 args)))
+ (apply assert-flonum flargs)
+ (apply max flargs)))
+
+ (define (flmin fl1 . args)
+ (let ((flargs (cons fl1 args)))
+ (apply assert-flonum flargs)
+ (apply min flargs)))
+
+ (define (fl+ fl1 . args)
+ (let ((flargs (cons fl1 args)))
+ (apply assert-flonum flargs)
+ (apply + flargs)))
+
+ (define (fl* fl1 . args)
+ (let ((flargs (cons fl1 args)))
+ (apply assert-flonum flargs)
+ (apply * flargs)))
+
+ (define (fl- fl1 . args)
+ (let ((flargs (cons fl1 args)))
+ (apply assert-flonum flargs)
+ (apply - flargs)))
+
+ (define (fl/ fl1 . args)
+ (let ((flargs (cons fl1 args)))
+ (apply assert-flonum flargs)
+ (apply / flargs)))
+
+ (define (flabs fl) (assert-flonum fl) (abs fl))
+
+ (define (fldiv-and-mod fl1 fl2)
+ (assert-iflonum fl1 fl2)
+ (if (zero? fl2) (raise (make-assertion-violation)))
+ (let ((fx1 (inexact->exact fl1))
+ (fx2 (inexact->exact fl2)))
+ (call-with-values (lambda () (div-and-mod fx1 fx2))
+ (lambda (div mod) (values (exact->inexact div)
+ (exact->inexact mod))))))
+
+ (define (fldiv fl1 fl2)
+ (assert-iflonum fl1 fl2)
+ (if (zero? fl2) (raise (make-assertion-violation)))
+ (let ((fx1 (inexact->exact fl1))
+ (fx2 (inexact->exact fl2)))
+ (exact->inexact (quotient fx1 fx2))))
+
+ (define (flmod fl1 fl2)
+ (assert-iflonum fl1 fl2)
+ (if (zero? fl2) (raise (make-assertion-violation)))
+ (let ((fx1 (inexact->exact fl1))
+ (fx2 (inexact->exact fl2)))
+ (exact->inexact (modulo fx1 fx2))))
+
+ (define (fldiv0-and-mod0 fl1 fl2)
+ (assert-iflonum fl1 fl2)
+ (if (zero? fl2) (raise (make-assertion-violation)))
+ (let* ((fx1 (inexact->exact fl1))
+ (fx2 (inexact->exact fl2)))
+ (call-with-values (lambda () (div0-and-mod0 fx1 fx2))
+ (lambda (q r) (values (real->flonum q) (real->flonum r))))))
+
+ (define (fldiv0 fl1 fl2)
+ (call-with-values (lambda () (fldiv0-and-mod0 fl1 fl2)) (lambda (q r) q)))
+
+ (define (flmod0 fl1 fl2)
+ (call-with-values (lambda () (fldiv0-and-mod0 fl1 fl2)) (lambda (q r) r)))
+
+ (define (flnumerator fl)
+ (assert-flonum fl)
+ (case fl
+ ((+inf.0) +inf.0)
+ ((-inf.0) -inf.0)
+ (else (numerator fl))))
+
+ (define (fldenominator fl)
+ (assert-flonum fl)
+ (case fl
+ ((+inf.0) 1.0)
+ ((-inf.0) 1.0)
+ (else (denominator fl))))
+
+ (define (flfloor fl) (assert-flonum fl) (floor fl))
+ (define (flceiling fl) (assert-flonum fl) (ceiling fl))
+ (define (fltruncate fl) (assert-flonum fl) (truncate fl))
+ (define (flround fl) (assert-flonum fl) (round fl))
+
+ (define (flexp fl) (assert-flonum fl) (exp fl))
+ (define* (fllog fl #:optional fl2)
+ (assert-flonum fl)
+ (cond ((fl=? fl -inf.0) +nan.0)
+ (fl2 (begin (assert-flonum fl2) (/ (log fl) (log fl2))))
+ (else (log fl))))
+
+ (define (flsin fl) (assert-flonum fl) (sin fl))
+ (define (flcos fl) (assert-flonum fl) (cos fl))
+ (define (fltan fl) (assert-flonum fl) (tan fl))
+ (define (flasin fl) (assert-flonum fl) (asin fl))
+ (define (flacos fl) (assert-flonum fl) (acos fl))
+ (define* (flatan fl #:optional fl2)
+ (assert-flonum fl)
+ (if fl2 (begin (assert-flonum fl2) (atan fl fl2)) (atan fl)))
+
+ (define (flsqrt fl) (assert-flonum fl) (sqrt fl))
+ (define (flexpt fl1 fl2) (assert-flonum fl1 fl2) (expt fl1 fl2))
+
+ (define-condition-type &no-infinities
+ &implementation-restriction
+ make-no-infinities-violation
+ no-infinities-violation?)
+
+ (define-condition-type &no-nans
+ &implementation-restriction
+ make-no-nans-violation
+ no-nans-violation?)
+
+ (define (fixnum->flonum fx)
+ (or (fixnum? fx) (raise (make-assertion-violation)))
+ (exact->inexact fx))
+)
diff --git a/module/rnrs/io/6/simple.scm b/module/rnrs/io/6/simple.scm
new file mode 100644
index 0000000..6afae14
--- /dev/null
+++ b/module/rnrs/io/6/simple.scm
@@ -0,0 +1,173 @@
+;;; simple.scm --- The R6RS simple I/O library
+
+;; 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 (rnrs io simple (6))
+ (export eof-object
+ eof-object?
+
+ call-with-input-file
+ call-with-output-file
+
+ input-port?
+ output-port?
+
+ current-input-port
+ current-output-port
+ current-error-port
+
+ with-input-from-file
+ with-output-to-file
+
+ open-input-file
+ open-output-file
+
+ close-input-port
+ close-output-port
+
+ read-char
+ peek-char
+ read
+ write-char
+ newline
+ display
+ write
+
+ &i/o make-i/o-error i/o-error?
+ &i/o-read make-i/o-read-error i/o-read-error?
+ &i/o-write make-i/o-write-error i/o-write-error?
+
+ &i/o-invalid-position
+ make-i/o-invalid-position-error
+ i/o-invalid-position-error?
+ i/o-error-position
+
+ &i/o-filename
+ make-i/o-filename-error
+ i/o-filename-error?
+ i/o-error-filename
+
+ &i/o-file-protection
+ make-i/o-file-protection-error
+ i/o-file-protection-error?
+
+ &i/o-file-is-read-only
+ make-i/o-file-is-read-only-error
+ i/o-file-is-read-only-error?
+
+ &i/o-file-already-exists
+ make-i/o-file-already-exists-error
+ i/o-file-already-exists-error?
+
+ &i/o-file-does-not-exist
+ make-i/o-file-does-not-exist-error
+ i/o-file-does-not-exist-error?
+
+ &i/o-port
+ make-i/o-port-error
+ i/o-port-error?
+ i/o-error-port)
+
+ (import (only (rnrs io ports) eof-object
+ eof-object?
+
+ input-port?
+ output-port?)
+ (only (guile) @@
+ call-with-input-file
+ call-with-output-file
+
+ current-input-port
+ current-output-port
+ current-error-port
+
+ with-input-from-file
+ with-output-to-file
+
+ open-input-file
+ open-output-file
+
+ close-input-port
+ close-output-port
+
+ read-char
+ peek-char
+ read
+ write-char
+ newline
+ display
+ write)
+ (rnrs base (6))
+ (rnrs conditions (6)))
+
+ (define &i/o (@@ (rnrs conditions) &i/o))
+ (define make-i/o-error (@@ (rnrs conditions) make-i/o-error))
+ (define i/o-error? (@@ (rnrs conditions) i/o-error?))
+
+ (define &i/o-read (@@ (rnrs conditions) &i/o-read))
+ (define make-i/o-read-error (@@ (rnrs conditions) make-i/o-read-error))
+ (define i/o-read-error? (@@ (rnrs conditions) i/o-read-error?))
+
+ (define &i/o-write (@@ (rnrs conditions) &i/o-write))
+ (define make-i/o-write-error (@@ (rnrs conditions) make-i/o-write-error))
+ (define i/o-write-error? (@@ (rnrs conditions) i/o-write-error?))
+
+ (define &i/o-invalid-position (@@ (rnrs conditions) &i/o-invalid-position))
+ (define make-i/o-invalid-position-error
+ (@@ (rnrs conditions) make-i/o-invalid-position-error))
+ (define i/o-invalid-position-error?
+ (@@ (rnrs conditions) i/o-invalid-position-error?))
+ (define i/o-error-position (@@ (rnrs conditions) i/o-error-position))
+
+ (define &i/o-filename (@@ (rnrs conditions) &i/o-filename))
+ (define make-i/o-filename-error
+ (@@ (rnrs conditions) make-i/o-filename-error))
+ (define i/o-filename-error? (@@ (rnrs conditions) i/o-filename-error?))
+ (define i/o-error-filename (@@ (rnrs conditions) i/o-error-filename))
+
+ (define &i/o-file-protection (@@ (rnrs conditions) &i/o-file-protection))
+ (define make-i/o-file-protection-error
+ (@@ (rnrs conditions) make-i/o-file-protection-error))
+ (define i/o-file-protection-error?
+ (@@ (rnrs conditions) i/o-file-protection-error?))
+
+ (define &i/o-file-is-read-only (@@ (rnrs conditions) &i/o-file-is-read-only))
+ (define make-i/o-file-is-read-only-error
+ (@@ (rnrs conditions) make-i/o-file-is-read-only-error))
+ (define i/o-file-is-read-only-error?
+ (@@ (rnrs conditions) i/o-file-is-read-only-error?))
+
+ (define &i/o-file-already-exists
+ (@@ (rnrs conditions) &i/o-file-already-exists))
+ (define make-i/o-file-already-exists-error
+ (@@ (rnrs conditions) make-i/o-file-already-exists-error))
+ (define i/o-file-already-exists-error?
+ (@@ (rnrs conditions) i/o-file-already-exists-error?))
+
+ (define &i/o-file-does-not-exist
+ (@@ (rnrs conditions) &i/o-file-does-not-exist))
+ (define make-i/o-file-does-not-exist-error
+ (@@ (rnrs conditions) make-i/o-file-does-not-exist-error))
+ (define i/o-file-does-not-exist-error?
+ (@@ (rnrs conditions) i/o-file-does-not-exist-error?))
+
+ (define &i/o-port (@@ (rnrs conditions) &i/o-port))
+ (define make-i/o-port-error (@@ (rnrs conditions) make-i/o-port-error))
+ (define i/o-port-error? (@@ (rnrs conditions) i/o-port-error?))
+ (define i/o-error-port (@@ (rnrs conditions) i/o-error-port))
+)
diff --git a/module/rnrs/records/6/inspection.scm
b/module/rnrs/records/6/inspection.scm
new file mode 100644
index 0000000..a142d7c
--- /dev/null
+++ b/module/rnrs/records/6/inspection.scm
@@ -0,0 +1,83 @@
+;;; inspection.scm --- Inspection support for R6RS records
+
+;; 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 (rnrs records inspection (6))
+ (export record?
+ record-rtd
+ record-type-name
+ record-type-parent
+ record-type-uid
+ record-type-generative?
+ record-type-sealed?
+ record-type-opaque?
+ record-type-field-names
+ record-field-mutable?)
+ (import (rnrs base (6))
+ (rnrs conditions (6))
+ (rnrs exceptions (6))
+ (rnrs records procedural (6))
+ (only (guile) struct-ref vtable-index-layout @@))
+
+ (define record-internal? (@@ (rnrs records procedural) record-internal?))
+
+ (define record-index-rtd (@@ (rnrs records procedural) record-index-rtd))
+
+ (define rtd-index-name (@@ (rnrs records procedural) rtd-index-name))
+ (define rtd-index-parent (@@ (rnrs records procedural) rtd-index-parent))
+ (define rtd-index-uid (@@ (rnrs records procedural) rtd-index-uid))
+ (define rtd-index-sealed? (@@ (rnrs records procedural) rtd-index-sealed?))
+ (define rtd-index-opaque? (@@ (rnrs records procedural) rtd-index-opaque?))
+ (define rtd-index-field-names
+ (@@ (rnrs records procedural) rtd-index-field-names))
+ (define rtd-index-field-vtable
+ (@@ (rnrs records procedural) rtd-index-field-vtable))
+
+ (define (record? obj)
+ (and (record-internal? obj)
+ (not (record-type-opaque? (struct-ref obj record-index-rtd)))))
+
+ (define (record-rtd record)
+ (or (and (record-internal? record)
+ (let ((rtd (struct-ref record record-index-rtd)))
+ (and (not (struct-ref rtd rtd-index-opaque?)) rtd)))
+ (raise (make-assertion-violation))))
+
+ (define (ensure-rtd rtd)
+ (if (not (record-type-descriptor? rtd)) (raise
(make-assertion-violation))))
+
+ (define (record-type-name rtd)
+ (ensure-rtd rtd) (struct-ref rtd rtd-index-name))
+ (define (record-type-parent rtd)
+ (ensure-rtd rtd) (struct-ref rtd rtd-index-parent))
+ (define (record-type-uid rtd) (ensure-rtd rtd) (struct-ref rtd
rtd-index-uid))
+ (define (record-type-generative? rtd)
+ (ensure-rtd rtd) (not (record-type-uid rtd)))
+ (define (record-type-sealed? rtd)
+ (ensure-rtd rtd) (struct-ref rtd rtd-index-sealed?))
+ (define (record-type-opaque? rtd)
+ (ensure-rtd rtd) (struct-ref rtd rtd-index-opaque?))
+ (define (record-type-field-names rtd)
+ (ensure-rtd rtd) (struct-ref rtd rtd-index-field-names))
+ (define (record-field-mutable? rtd k)
+ (ensure-rtd rtd)
+ (let ((vt (struct-ref rtd rtd-index-field-vtable)))
+ (eqv? (string-ref (symbol->string (struct-ref vt vtable-index-layout))
+ (+ (* 2 (+ k 2)) 1))
+ #\w)))
+)
diff --git a/module/rnrs/records/6/procedural.scm
b/module/rnrs/records/6/procedural.scm
new file mode 100644
index 0000000..bd1d0d1
--- /dev/null
+++ b/module/rnrs/records/6/procedural.scm
@@ -0,0 +1,275 @@
+;;; procedural.scm --- Procedural interface to R6RS records
+
+;; 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 (rnrs records procedural (6))
+ (export make-record-type-descriptor
+ record-type-descriptor?
+ make-record-constructor-descriptor
+
+ record-constructor
+ record-predicate
+ record-accessor
+ record-mutator)
+
+ (import (rnrs base (6))
+ (only (guile) and=>
+ throw
+ display
+ make-struct
+ make-vtable
+ map
+ simple-format
+ string-append
+
+ struct?
+ struct-ref
+ struct-set!
+ struct-vtable
+ vtable-index-layout
+
+ make-hash-table
+ hashq-ref
+ hashq-set!
+
+ vector->list)
+ (ice-9 receive)
+ (only (srfi :1) fold split-at take))
+
+ (define (record-internal? obj)
+ (and (struct? obj)
+ (let* ((vtable (struct-vtable obj))
+ (layout (symbol->string
+ (struct-ref vtable vtable-index-layout))))
+ (and (>= (string-length layout) 4)
+ (let ((rtd (struct-ref obj record-index-rtd)))
+ (and (record-type-descriptor? rtd)))))))
+
+ (define record-index-parent 0)
+ (define record-index-rtd 1)
+
+ (define rtd-index-name 0)
+ (define rtd-index-uid 1)
+ (define rtd-index-parent 2)
+ (define rtd-index-sealed? 3)
+ (define rtd-index-opaque? 4)
+ (define rtd-index-predicate 5)
+ (define rtd-index-field-names 6)
+ (define rtd-index-field-vtable 7)
+ (define rtd-index-field-binder 8)
+
+ (define rctd-index-rtd 0)
+ (define rctd-index-parent 1)
+ (define rctd-index-protocol 2)
+
+ (define record-type-vtable
+ (make-vtable "prprprprprprprprpr"
+ (lambda (obj port)
+ (simple-format port "#<r6rs:record-type:~A>"
+ (struct-ref obj rtd-index-name)))))
+
+ (define record-constructor-vtable
+ (make-vtable "prprpr"
+ (lambda (obj port)
+ (simple-format port "#<r6rs:record-constructor:~A>"
+ (struct-ref (struct-ref obj rctd-index-rtd)
+ rtd-index-name)))))
+
+ (define uid-table (make-hash-table))
+
+ (define (make-record-type-descriptor name parent uid sealed? opaque? fields)
+ (define fields-vtable
+ (make-vtable (fold (lambda (x p)
+ (string-append p (case (car x)
+ ((immutable) "pr")
+ ((mutable) "pw"))))
+ "prpr" (vector->list fields))
+ (lambda (obj port)
+ (simple-format port "#<r6rs:record:~A>" name))))
+ (define field-names (list->vector (map cadr (vector->list fields))))
+ (define late-rtd #f)
+ (define (private-record-predicate obj)
+ (and (record-internal? obj)
+ (let ((rtd (struct-ref obj record-index-rtd)))
+ (or (eq? (struct-ref rtd rtd-index-field-vtable) fields-vtable)
+ (and=> (struct-ref obj record-index-parent)
+ private-record-predicate)))))
+
+ (define (field-binder parent-struct . args)
+ (apply make-struct (append (list fields-vtable 0
+ parent-struct
+ late-rtd)
+ args)))
+ (if (and parent (struct-ref parent rtd-index-sealed?))
+ (r6rs-raise (make-assertion-violation)))
+
+ (let ((matching-rtd (and uid (hashq-ref uid-table uid)))
+ (opaque? (or opaque? (and parent (struct-ref
+ parent rtd-index-opaque?)))))
+ (if matching-rtd
+ (if (equal? (list name
+ parent
+ sealed?
+ opaque?
+ field-names
+ (struct-ref fields-vtable vtable-index-layout))
+ (list (struct-ref matching-rtd rtd-index-name)
+ (struct-ref matching-rtd rtd-index-parent)
+ (struct-ref matching-rtd rtd-index-sealed?)
+ (struct-ref matching-rtd rtd-index-opaque?)
+ (struct-ref matching-rtd rtd-index-field-names)
+ (struct-ref (struct-ref matching-rtd
+ rtd-index-field-vtable)
+ vtable-index-layout)))
+ matching-rtd
+ (r6rs-raise (make-assertion-violation)))
+
+ (let ((rtd (make-struct record-type-vtable 0
+
+ name
+ uid
+ parent
+ sealed?
+ opaque?
+
+ private-record-predicate
+ field-names
+ fields-vtable
+ field-binder)))
+ (set! late-rtd rtd)
+ (if uid (hashq-set! uid-table uid rtd))
+ rtd))))
+
+ (define (record-type-descriptor? obj)
+ (and (struct? obj) (eq? (struct-vtable obj) record-type-vtable)))
+
+ (define (make-record-constructor-descriptor rtd
+ parent-constructor-descriptor
+ protocol)
+ (define rtd-arity (vector-length (struct-ref rtd rtd-index-field-names)))
+ (define (default-inherited-protocol n)
+ (lambda args
+ (receive
+ (n-args p-args)
+ (split-at args (- (length args) rtd-arity))
+ (let ((p (apply n n-args)))
+ (apply p p-args)))))
+ (define (default-protocol p) p)
+
+ (let* ((prtd (struct-ref rtd rtd-index-parent))
+ (pcd (or parent-constructor-descriptor
+ (and=> prtd (lambda (d) (make-record-constructor-descriptor
+ prtd #f #f)))))
+ (prot (or protocol (if pcd
+ default-inherited-protocol
+ default-protocol))))
+ (make-struct record-constructor-vtable 0 rtd pcd prot)))
+
+ (define (record-constructor rctd)
+ (let* ((rtd (struct-ref rctd rctd-index-rtd))
+ (parent-rctd (struct-ref rctd rctd-index-parent))
+ (protocol (struct-ref rctd rctd-index-protocol)))
+ (protocol
+ (if parent-rctd
+ (let ((parent-record-constructor (record-constructor parent-rctd))
+ (parent-rtd (struct-ref parent-rctd rctd-index-rtd)))
+ (lambda args
+ (let ((struct (apply parent-record-constructor args)))
+ (lambda args
+ (apply (struct-ref rtd rtd-index-field-binder)
+ (cons struct args))))))
+ (lambda args (apply (struct-ref rtd rtd-index-field-binder)
+ (cons #f args)))))))
+
+ (define (record-predicate rtd) (struct-ref rtd rtd-index-predicate))
+
+ (define (record-accessor rtd k)
+ (define (record-accessor-inner obj)
+ (if (not (record-internal? obj))
+ (r6rs-raise (make-assertion-violation)))
+ (if (eq? (struct-ref obj record-index-rtd) rtd)
+ (struct-ref obj (+ k 2))
+ (record-accessor-inner (struct-ref obj record-index-parent))))
+ (lambda (obj) (record-accessor-inner obj)))
+
+ (define (record-mutator rtd k)
+ (define (record-mutator-inner obj val)
+ (and obj
+ (or (and (eq? (struct-ref obj record-index-rtd) rtd)
+ (struct-set! obj (+ k 2) val))
+ (record-mutator-inner (struct-ref obj record-index-parent)
+ val))))
+ (let* ((rtd-vtable (struct-ref rtd rtd-index-field-vtable))
+ (field-layout (symbol->string
+ (struct-ref rtd-vtable vtable-index-layout))))
+ (if (not (eqv? (string-ref field-layout (+ (* (+ k 2) 2) 1)) #\w))
+ (r6rs-raise (make-assertion-violation))))
+ (lambda (obj val) (record-mutator-inner obj val)))
+
+ ;; Condition types that are used in the current library. These are defined
+ ;; here and not in (rnrs conditions) to avoid a circular dependency.
+
+ (define &condition (make-record-type-descriptor '&condition #f #f #f #f
'#()))
+ (define &condition-constructor-descriptor
+ (make-record-constructor-descriptor &condition #f #f))
+
+ (define &serious (make-record-type-descriptor
+ '&serious &condition #f #f #f '#()))
+ (define &serious-constructor-descriptor
+ (make-record-constructor-descriptor
+ &serious &condition-constructor-descriptor #f))
+
+ (define make-serious-condition
+ (record-constructor &serious-constructor-descriptor))
+
+ (define &violation (make-record-type-descriptor
+ '&violation &serious #f #f #f '#()))
+ (define &violation-constructor-descriptor
+ (make-record-constructor-descriptor
+ &violation &serious-constructor-descriptor #f))
+ (define make-violation (record-constructor
&violation-constructor-descriptor))
+
+ (define &assertion (make-record-type-descriptor
+ '&assertion &violation #f #f #f '#()))
+ (define make-assertion-violation
+ (record-constructor
+ (make-record-constructor-descriptor
+ &assertion &violation-constructor-descriptor #f)))
+
+ ;; Exception wrapper type, along with a wrapping `throw' implementation.
+ ;; These are used in the current library, and so they are defined here and
not
+ ;; in (rnrs exceptions) to avoid a circular dependency.
+
+ (define &raise-object-wrapper
+ (make-record-type-descriptor '&raise-object-wrapper #f #f #f #f
+ '#((immutable obj) (immutable continuation))))
+ (define make-raise-object-wrapper
+ (record-constructor (make-record-constructor-descriptor
+ &raise-object-wrapper #f #f)))
+ (define raise-object-wrapper? (record-predicate &raise-object-wrapper))
+ (define raise-object-wrapper-obj (record-accessor &raise-object-wrapper 0))
+ (define raise-object-wrapper-continuation
+ (record-accessor &raise-object-wrapper 1))
+
+ (define (r6rs-raise obj)
+ (throw 'r6rs:exception (make-raise-object-wrapper obj #f)))
+ (define (r6rs-raise-continuable obj)
+ (define (r6rs-raise-continuable-internal continuation)
+ (throw 'r6rs:exception (make-raise-object-wrapper obj continuation)))
+ (call/cc r6rs-raise-continuable-internal))
+)
diff --git a/module/rnrs/records/6/syntactic.scm
b/module/rnrs/records/6/syntactic.scm
new file mode 100644
index 0000000..d46efbc
--- /dev/null
+++ b/module/rnrs/records/6/syntactic.scm
@@ -0,0 +1,253 @@
+;;; syntactic.scm --- Syntactic support for R6RS records
+
+;; 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 (rnrs records syntactic (6))
+ (export define-record-type
+ record-type-descriptor
+ record-constructor-descriptor)
+ (import (only (guile) *unspecified* and=> gensym unspecified?)
+ (rnrs base (6))
+ (rnrs conditions (6))
+ (rnrs exceptions (6))
+ (rnrs hashtables (6))
+ (rnrs lists (6))
+ (rnrs records procedural (6))
+ (rnrs syntax-case (6))
+ (only (srfi :1) take))
+
+ (define record-type-registry (make-eq-hashtable))
+
+ (define (guess-constructor-name record-name)
+ (string->symbol (string-append "make-" (symbol->string record-name))))
+ (define (guess-predicate-name record-name)
+ (string->symbol (string-append (symbol->string record-name) "?")))
+ (define (register-record-type name rtd rcd)
+ (hashtable-set! record-type-registry name (cons rtd rcd)))
+ (define (lookup-record-type-descriptor name)
+ (and=> (hashtable-ref record-type-registry name #f) car))
+ (define (lookup-record-constructor-descriptor name)
+ (and=> (hashtable-ref record-type-registry name #f) cdr))
+
+ (define-syntax define-record-type
+ (lambda (stx)
+ (syntax-case stx ()
+ ((_ (record-name constructor-name predicate-name) record-clause ...)
+ #'(define-record-type0
+ (record-name constructor-name predicate-name)
+ record-clause ...))
+ ((_ record-name record-clause ...)
+ (let* ((record-name-sym (syntax->datum #'record-name))
+ (constructor-name
+ (datum->syntax
+ #'record-name (guess-constructor-name record-name-sym)))
+ (predicate-name
+ (datum->syntax
+ #'record-name (guess-predicate-name record-name-sym))))
+ #`(define-record-type0
+ (record-name #,constructor-name #,predicate-name)
+ record-clause ...))))))
+
+ (define (sequence n)
+ (define (seq-inner n) (if (= n 0) '(0) (cons n (seq-inner (- n 1)))))
+ (reverse (seq-inner n)))
+ (define (number-fields fields)
+ (define (number-fields-inner fields counter)
+ (if (null? fields)
+ '()
+ (cons (cons fields counter)
+ (number-fields-inner (cdr fields) (+ counter 1)))))
+ (number-fields-inner fields 0))
+
+ (define (process-fields record-name fields)
+ (define record-name-str (symbol->string record-name))
+ (define (guess-accessor-name field-name)
+ (string->symbol (string-append
+ record-name-str "-" (symbol->string field-name))))
+ (define (guess-mutator-name field-name)
+ (string->symbol
+ (string-append
+ record-name-str "-" (symbol->string field-name) "-set!")))
+
+ (define (f x)
+ (cond ((symbol? x) (list 'immutable x (guess-accessor-name x) #f))
+ ((not (list? x)) (error))
+ ((eq? (car x) 'immutable)
+ (cons 'immutable
+ (case (length x)
+ ((2) (list (cadr x) (guess-accessor-name (cadr x)) #f))
+ ((3) (list (cadr x) (caddr x) #f))
+ (else (error)))))
+ ((eq? (car x) 'mutable)
+ (cons 'mutable
+ (case (length x)
+ ((2) (list (cadr x)
+ (guess-accessor-name (cadr x))
+ (guess-mutator-name (cadr x))))
+ ((4) (cdr x))
+ (else (error)))))
+ (else (error))))
+ (map f fields))
+
+ (define-syntax define-record-type0
+ (lambda (stx)
+ (syntax-case stx ()
+ ((_ (record-name constructor-name predicate-name) record-clause ...)
+ (let loop ((fields *unspecified*)
+ (parent *unspecified*)
+ (protocol *unspecified*)
+ (sealed *unspecified*)
+ (opaque *unspecified*)
+ (nongenerative *unspecified*)
+ (constructor *unspecified*)
+ (parent-rtd *unspecified*)
+ (record-clauses (syntax->datum #'(record-clause ...))))
+ (if (null? record-clauses)
+ (let*
+ ((fields (if (unspecified? fields) '() fields))
+ (field-names
+ (datum->syntax
+ #'record-name
+ (list->vector (map (lambda (x) (take x 2)) fields))))
+ (field-accessors
+ (fold-left (lambda (x c lst)
+ (cons #`(define #,(datum->syntax
+ #'record-name (caddr x))
+ (record-accessor record-name #,c))
+ lst))
+ '() fields (sequence (length fields))))
+ (field-mutators
+ (fold-left (lambda (x c lst)
+ (if (cadddr x)
+ (cons #`(define #,(datum->syntax
+ #'record-name (cadddr x))
+ (record-mutator record-name #,c))
+ lst)
+ lst))
+ '() fields (sequence (length fields))))
+
+ (parent-cd
+ (datum->syntax
+ stx (cond ((not (unspecified? parent))
+ `(record-constructor-descriptor ,parent))
+ ((not (unspecified? parent-rtd)) (cadr parent-rtd))
+ (else #f))))
+ (parent-rtd
+ (datum->syntax
+ stx (cond ((not (unspecified? parent))
+ `(record-type-descriptor ,parent))
+ ((not (unspecified? parent-rtd)) (car parent-rtd))
+ (else #f))))
+
+ (protocol (datum->syntax
+ #'record-name (if (unspecified? protocol)
+ #f protocol)))
+ (uid (datum->syntax
+ #'record-name (if (unspecified? nongenerative)
+ #f nongenerative)))
+ (sealed? (if (unspecified? sealed) #f sealed))
+ (opaque? (if (unspecified? opaque) #f opaque))
+
+ (record-name-sym (datum->syntax
+ stx (list 'quote
+ (syntax->datum #'record-name)))))
+
+ #`(begin
+ (define record-name
+ (make-record-type-descriptor
+ #,record-name-sym
+ #,parent-rtd #,uid #,sealed? #,opaque?
+ #,field-names))
+ (define constructor-name
+ (record-constructor
+ (make-record-constructor-descriptor
+ record-name #,parent-cd #,protocol)))
+ (register-record-type
+ #,record-name-sym
+ record-name (make-record-constructor-descriptor
+ record-name #,parent-cd #,protocol))
+ (define predicate-name (record-predicate record-name))
+ #,@field-accessors
+ #,@field-mutators))
+ (let ((cr (car record-clauses)))
+ (case (car cr)
+ ((fields)
+ (if (unspecified? fields)
+ (loop (process-fields (syntax->datum #'record-name)
+ (cdr cr))
+ parent protocol sealed opaque nongenerative
+ constructor parent-rtd (cdr record-clauses))
+ (raise (make-assertion-violation))))
+ ((parent)
+ (if (not (unspecified? parent-rtd))
+ (raise (make-assertion-violation)))
+ (if (unspecified? parent)
+ (loop fields (cadr cr) protocol sealed opaque
+ nongenerative constructor parent-rtd
+ (cdr record-clauses))
+ (raise (make-assertion-violation))))
+ ((protocol)
+ (if (unspecified? protocol)
+ (loop fields parent (cadr cr) sealed opaque
+ nongenerative constructor parent-rtd
+ (cdr record-clauses))
+ (raise (make-assertion-violation))))
+ ((sealed)
+ (if (unspecified? sealed)
+ (loop fields parent protocol (cadr cr) opaque
+ nongenerative constructor parent-rtd
+ (cdr record-clauses))
+ (raise (make-assertion-violation))))
+ ((opaque) (if (unspecified? opaque)
+ (loop fields parent protocol sealed (cadr cr)
+ nongenerative constructor parent-rtd
+ (cdr record-clauses))
+ (raise (make-assertion-violation))))
+ ((nongenerative)
+ (if (unspecified? nongenerative)
+ (let ((uid (list 'quote
+ (or (and (> (length cr) 1) (cadr cr))
+ (gensym)))))
+ (loop fields parent protocol sealed
+ opaque uid constructor
+ parent-rtd (cdr record-clauses)))
+ (raise (make-assertion-violation))))
+ ((parent-rtd)
+ (if (not (unspecified? parent))
+ (raise (make-assertion-violation)))
+ (if (unspecified? parent-rtd)
+ (loop fields parent protocol sealed opaque
+ nongenerative constructor (cdr cr)
+ (cdr record-clauses))
+ (raise (make-assertion-violation))))
+ (else (raise (make-assertion-violation)))))))))))
+
+ (define-syntax record-type-descriptor
+ (lambda (stx)
+ (syntax-case stx ()
+ ((_ name) #`(lookup-record-type-descriptor
+ #,(datum->syntax
+ stx (list 'quote (syntax->datum #'name))))))))
+
+ (define-syntax record-constructor-descriptor
+ (lambda (stx)
+ (syntax-case stx ()
+ ((_ name) #`(lookup-record-constructor-descriptor
+ #,(datum->syntax
+ stx (list 'quote (syntax->datum #'name))))))))
+)
diff --git a/test-suite/Makefile.am b/test-suite/Makefile.am
index 0f49d05..51870e6 100644
--- a/test-suite/Makefile.am
+++ b/test-suite/Makefile.am
@@ -76,7 +76,21 @@ SCM_TESTS = tests/00-initial-env.test \
tests/q.test \
tests/r4rs.test \
tests/r5rs_pitfall.test \
+ tests/r6rs-arithmetic-bitwise.test \
+ tests/r6rs-arithmetic-fixnums.test \
+ tests/r6rs-arithmetic-flonums.test \
+ tests/r6rs-conditions.test \
+ tests/r6rs-control.test \
+ tests/r6rs-enums.test \
+ tests/r6rs-eval.test \
+ tests/r6rs-exceptions.test \
+ tests/r6rs-files.test \
+ tests/r6rs-hashtables.test \
tests/r6rs-ports.test \
+ tests/r6rs-records-inspection.test \
+ tests/r6rs-records-procedural.test \
+ tests/r6rs-records-syntactic.test \
+ tests/r6rs-unicode.test \
tests/rnrs-libraries.test \
tests/ramap.test \
tests/reader.test \
diff --git a/test-suite/tests/r6rs-arithmetic-bitwise.test
b/test-suite/tests/r6rs-arithmetic-bitwise.test
new file mode 100644
index 0000000..a61fef8
--- /dev/null
+++ b/test-suite/tests/r6rs-arithmetic-bitwise.test
@@ -0,0 +1,97 @@
+;;; arithmetic-bitwise.test --- Test suite for R6RS (rnrs arithmetic bitwise)
+
+;; 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 test-r6rs-arithmetic-bitwise)
+ :use-module ((rnrs arithmetic bitwise) :version (6))
+ :use-module (test-suite lib))
+
+(with-test-prefix "bitwise-not"
+ (pass-if "bitwise-not simple"
+ (eqv? (bitwise-not 3) -4)))
+
+(with-test-prefix "bitwise-and"
+ (pass-if "bitwise-and simple"
+ (eqv? (bitwise-and #b101 #b110) #b100)))
+
+(with-test-prefix "bitwise-ior"
+ (pass-if "bitwise-ior simple"
+ (eqv? (bitwise-ior #b010 #b100) #b110)))
+
+(with-test-prefix "bitwise-xor"
+ (pass-if "bitwise-xor simple"
+ (eqv? (bitwise-xor #b101 #b100) #b001)))
+
+(with-test-prefix "bitwise-if"
+ (pass-if "bitwise-if simple"
+ (eqv? (bitwise-if #b101 #b011 #b100) #b001)))
+
+(with-test-prefix "bitwise-bit-count"
+ (pass-if "bitwise-bit-count simple"
+ (eqv? (bitwise-bit-count #b101) 2)))
+
+(with-test-prefix "bitwise-length"
+ (pass-if "bitwise-length simple"
+ (eqv? (bitwise-length #b101) 3))
+ (pass-if "bitwise-length leading zeros"
+ (eqv? (bitwise-length #b001) 1)))
+
+(with-test-prefix "bitwise-first-bit-set"
+ (pass-if "bitwise-first-bit-set simple"
+ (and (eqv? (bitwise-first-bit-set 1) 0)
+ (eqv? (bitwise-first-bit-set -4) 2)))
+ (pass-if "bitwise-first-bit-set zero"
+ (and (eqv? (bitwise-first-bit-set 0) -1))))
+
+(with-test-prefix "bitwise-copy-bit"
+ (pass-if "bitwise-copy-bit simple"
+ (eqv? (bitwise-copy-bit #b010 2 #b111) #b110)))
+
+(with-test-prefix "bitwise-bit-field"
+ (pass-if "bitwise-bit-field simple"
+ (eqv? (bitwise-bit-field #b110010 1 4) #b001)))
+
+(with-test-prefix "bitwise-copy-bit-field"
+ (pass-if "bitwise-copy-bit-field simple"
+ (eqv? (bitwise-copy-bit-field #b11111111 2 6 #b1010) #b11101011)))
+
+(with-test-prefix "bitwise-arithmetic-shift"
+ (pass-if "bitwise-arithmetic-shift simple"
+ (and (eqv? (bitwise-arithmetic-shift -6 -1) -3)
+ (eqv? (bitwise-arithmetic-shift -5 -1) -3)
+ (eqv? (bitwise-arithmetic-shift -4 -1) -2)
+ (eqv? (bitwise-arithmetic-shift -3 -1) -2)
+ (eqv? (bitwise-arithmetic-shift -2 -1) -1)
+ (eqv? (bitwise-arithmetic-shift -1 -1) -1))))
+
+(with-test-prefix "bitwise-arithmetic-shift-left"
+ (pass-if "bitwise-arithmetic-shift-left simple"
+ (eqv? (bitwise-arithmetic-shift-left -6 -1) -3)))
+
+(with-test-prefix "bitwise-arithmetic-shift-right"
+ (pass-if "bitwise-arithmetic-shift-right simple"
+ (eqv? (bitwise-arithmetic-shift-right -6 1) -3)))
+
+(with-test-prefix "bitwise-rotate-bit-field"
+ (pass-if "bitwise-rotate-bit-field simple"
+ (eqv? (bitwise-rotate-bit-field #b11100011 2 6 2) #b11001011)))
+
+(with-test-prefix "bitwise-reverse-bit-field"
+ (pass-if "bitwise-reverse-bit-field simple"
+ (eqv? (bitwise-reverse-bit-field #b1010010 1 4) #b1011000)))
+
diff --git a/test-suite/tests/r6rs-arithmetic-fixnums.test
b/test-suite/tests/r6rs-arithmetic-fixnums.test
new file mode 100644
index 0000000..fed72eb
--- /dev/null
+++ b/test-suite/tests/r6rs-arithmetic-fixnums.test
@@ -0,0 +1,211 @@
+;;; arithmetic-fixnums.test --- Test suite for R6RS (rnrs arithmetic bitwise)
+
+;; 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 test-r6rs-arithmetic-fixnums)
+ :use-module ((rnrs arithmetic fixnums) :version (6))
+ :use-module ((rnrs conditions) :version (6))
+ :use-module ((rnrs exceptions) :version (6))
+ :use-module (test-suite lib))
+
+(with-test-prefix "fixnum?"
+ (pass-if "fixnum? is #t for fixnums" (fixnum? 0))
+
+ (pass-if "fixnum? is #f for non-fixnums" (not (fixnum? 'foo)))
+
+ (pass-if "fixnum? is #f for non-fixnum numbers"
+ (and (not (fixnum? 1.0)) (not (fixnum? (+ (greatest-fixnum) 1))))))
+
+(with-test-prefix "fx=?"
+ (pass-if "fx=? is #t for eqv inputs" (fx=? 3 3 3))
+
+ (pass-if "fx=? is #f for non-eqv inputs" (not (fx=? 1 2 3))))
+
+(with-test-prefix "fx>?"
+ (pass-if "fx>? is #t for monotonically > inputs" (fx>? 3 2 1))
+
+ (pass-if "fx>? is #f for non-monotonically > inputs" (not (fx>? 1 2 3))))
+
+(with-test-prefix "fx<?"
+ (pass-if "fx<? is #t for monotonically < inputs" (fx<? 1 2 3))
+
+ (pass-if "fx<? is #t for non-monotonically < inputs" (not (fx<? 3 2 1))))
+
+(with-test-prefix "fx>=?"
+ (pass-if "fx>=? is #t for monotonically > or = inputs" (fx>=? 3 2 2 1))
+
+ (pass-if "fx>=? is #f for non-monotonically > or = inputs"
+ (not (fx>=? 1 2 3))))
+
+(with-test-prefix "fx<=?"
+ (pass-if "fx<=? is #t for monotonically < or = inputs" (fx<=? 1 2 2 3))
+
+ (pass-if "fx<=? is #f for non-monotonically < or = inputs"
+ (not (fx<=? 3 2 1))))
+
+(with-test-prefix "fxzero?"
+ (pass-if "fxzero? is #t for zero" (fxzero? 0))
+
+ (pass-if "fxzero? is #f for non-zero fixnums"
+ (and (not (fxzero? 1)) (not (fxzero? -1)))))
+
+(with-test-prefix "fxpositive?"
+ (pass-if "fxpositive? is #t for positive fixnums" (fxpositive? 1))
+
+ (pass-if "fxpositive? is #f for non-positive fixnums"
+ (and (not (fxpositive? -1))
+ (not (fxpositive? 0)))))
+
+(with-test-prefix "fxnegative?"
+ (pass-if "fxnegative? is #t for negative fixnums" (fxnegative? -1))
+
+ (pass-if "fxnegative? is #f for non-negative fixnums"
+ (and (not (fxnegative? 1))
+ (not (fxnegative? 0)))))
+
+(with-test-prefix "fxodd?"
+ (pass-if "fxodd? is #t for odd fixnums" (fxodd? 1))
+
+ (pass-if "fxodd? is #f for even fixnums" (not (fxodd? 2))))
+
+(with-test-prefix "fxeven?"
+ (pass-if "fxeven? is #t for even fixnums" (fxeven? 2))
+
+ (pass-if "fxeven? is #f for odd fixnums" (not (fxeven? 1))))
+
+(with-test-prefix "fxmax" (pass-if "simple" (fx=? (fxmax 1 3 2) 3)))
+
+(with-test-prefix "fxmin" (pass-if "simple" (fx=? (fxmin -1 0 2) -1)))
+
+(with-test-prefix "fx+"
+ (pass-if "simple" (fx=? (fx+ 1 2) 3))
+
+ (pass-if "&implementation-restriction on non-fixnum result"
+ (guard (condition ((implementation-restriction-violation? condition) #t)
+ (else #f))
+ (begin (fx+ (greatest-fixnum) 1) #f))))
+
+(with-test-prefix "fx*"
+ (pass-if "simple" (fx=? (fx* 2 3) 6))
+
+ (pass-if "&implementation-restriction on non-fixnum result"
+ (guard (condition ((implementation-restriction-violation? condition) #t)
+ (else #f))
+ (begin (fx* (greatest-fixnum) 2) #f))))
+
+(with-test-prefix "fx-"
+ (pass-if "unary fx- negates argument" (fx=? (fx- 1) -1))
+
+ (pass-if "simple" (fx=? (fx- 3 2) 1))
+
+ (pass-if "&assertion on non-fixnum result"
+ (guard (condition ((assertion-violation? condition) #t) (else #f))
+ (fx- (least-fixnum) 1))))
+
+(with-test-prefix "fxdiv-and-mod"
+ (pass-if "simple"
+ (call-with-values (lambda () (fxdiv-and-mod 123 10))
+ (lambda (d m)
+ (or (and (fx=? d 12) (fx=? m 3))
+ (throw 'unresolved))))))
+
+(with-test-prefix "fxdiv"
+ (pass-if "simple" (or (fx=? (fxdiv -123 10) -13) (throw 'unresolved))))
+
+(with-test-prefix "fxmod"
+ (pass-if "simple" (or (fx=? (fxmod -123 10) 7) (throw 'unresolved))))
+
+(with-test-prefix "fxdiv0-and-mod0"
+ (pass-if "simple"
+ (call-with-values (lambda () (fxdiv0-and-mod0 -123 10))
+ (lambda (d m)
+ (or (and (fx=? d 12) (fx=? m -3))
+ (throw 'unresolved))))))
+
+(with-test-prefix "fxdiv0"
+ (pass-if "simple" (or (fx=? (fxdiv0 -123 10) 12) (throw 'unresolved))))
+
+(with-test-prefix "fxmod0"
+ (pass-if "simple" (or (fx=? (fxmod0 -123 10) -3) (throw 'unresolved))))
+
+
+;; Without working div and mod implementations and without any example results
+;; from the spec, I have no idea what the results of these functions should
+;; be. -juliang
+
+(with-test-prefix "fx+/carry" (pass-if "simple" (throw 'unresolved)))
+
+(with-test-prefix "fx-/carry" (pass-if "simple" (throw 'unresolved)))
+
+(with-test-prefix "fx*/carry" (pass-if "simple" (throw 'unresolved)))
+
+(with-test-prefix "fxnot" (pass-if "simple" (fx=? (fxnot 3) -4)))
+
+(with-test-prefix "fxand" (pass-if "simple" (fx=? (fxand 5 6) 4)))
+
+(with-test-prefix "fxior" (pass-if "simple" (fx=? (fxior 2 4) 6)))
+
+(with-test-prefix "fxxor" (pass-if "simple" (fx=? (fxxor 5 4) 1)))
+
+(with-test-prefix "fxif" (pass-if "simple" (fx=? (fxif 5 3 4) 1)))
+
+(with-test-prefix "fxbit-count" (pass-if "simple" (fx=? (fxbit-count 5) 2)))
+
+(with-test-prefix "fxlength" (pass-if "simple" (fx=? (fxlength 5) 3)))
+
+(with-test-prefix "fxfirst-bit-set"
+ (pass-if "simple"
+ (and (eqv? (fxfirst-bit-set 1) 0)
+ (eqv? (fxfirst-bit-set -4) 2)))
+
+ (pass-if "fxfirst-bit-set is -1 on zero"
+ (and (eqv? (fxfirst-bit-set 0) -1))))
+
+(with-test-prefix "fxbit-set?"
+ (pass-if "fxbit-set? is #t on index of set bit" (fxbit-set? 5 2))
+
+ (pass-if "fxbit-set? is #f on index of unset bit" (not (fxbit-set? 5 1))))
+
+(with-test-prefix "fxcopy-bit" (pass-if "simple" (fx=? (fxcopy-bit 2 2 7) 6)))
+
+(with-test-prefix "fxbit-field"
+ (pass-if "simple" (fx=? (fxbit-field 50 1 4) 1)))
+
+(with-test-prefix "fxcopy-bit-field"
+ (pass-if "simple" (fx=? (fxcopy-bit-field 255 2 6 10) 235)))
+
+(with-test-prefix "fxarithmetic-shift"
+ (pass-if "simple"
+ (and (fx=? (fxarithmetic-shift -6 -1) -3)
+ (fx=? (fxarithmetic-shift -5 -1) -3)
+ (fx=? (fxarithmetic-shift -4 -1) -2)
+ (fx=? (fxarithmetic-shift -3 -1) -2)
+ (fx=? (fxarithmetic-shift -2 -1) -1)
+ (fx=? (fxarithmetic-shift -1 -1) -1))))
+
+(with-test-prefix "fxarithmetic-shift-left"
+ (pass-if "simple" (fx=? (fxarithmetic-shift-left -6 -1) -3)))
+
+(with-test-prefix "fxarithmetic-shift-right"
+ (pass-if "simple" (fx=? (fxarithmetic-shift-right -6 1) -3)))
+
+(with-test-prefix "fxrotate-bit-field"
+ (pass-if "simple" (fx=? (fxrotate-bit-field 227 2 6 2) 203)))
+
+(with-test-prefix "fxreverse-bit-field"
+ (pass-if "simple" (fx=? (fxreverse-bit-field 82 1 4) 88)))
diff --git a/test-suite/tests/r6rs-arithmetic-flonums.test
b/test-suite/tests/r6rs-arithmetic-flonums.test
new file mode 100644
index 0000000..873447b
--- /dev/null
+++ b/test-suite/tests/r6rs-arithmetic-flonums.test
@@ -0,0 +1,310 @@
+;;; arithmetic-flonums.test --- Test suite for R6RS (rnrs arithmetic flonums)
+
+;; 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 test-r6rs-arithmetic-flonums)
+ :use-module ((rnrs arithmetic flonums) :version (6))
+ :use-module ((rnrs conditions) :version (6))
+ :use-module ((rnrs exceptions) :version (6))
+ :use-module (test-suite lib))
+
+(define fake-pi 3.14159265)
+(define (reasonably-close? x y) (< (abs (- x y)) 0.0000001))
+
+(with-test-prefix "flonum?"
+ (pass-if "flonum? is #t on flonum"
+ (flonum? 1.5))
+
+ (pass-if "flonum? is #f on non-flonum"
+ (not (flonum? 3))))
+
+(with-test-prefix "real->flonum"
+ (pass-if "simple"
+ (flonum? (real->flonum 3))))
+
+(with-test-prefix "fl=?"
+ (pass-if "fl=? is #t for eqv inputs"
+ (fl=? 3.0 3.0 3.0))
+
+ (pass-if "fl=? is #f for non-eqv inputs"
+ (not (fl=? 1.5 0.0 3.0)))
+
+ (pass-if "+inf.0 is fl= to itself"
+ (fl=? +inf.0 +inf.0))
+
+ (pass-if "0.0 and -0.0 are fl="
+ (fl=? 0.0 -0.0)))
+
+(with-test-prefix "fl<?"
+ (pass-if "fl<? is #t for monotonically < inputs"
+ (fl<? 1.0 2.0 3.0))
+
+ (pass-if "fl<? is #f for non-monotonically < inputs"
+ (not (fl<? 2.0 2.0 1.4))))
+
+(with-test-prefix "fl<=?"
+ (pass-if "fl<=? is #t for monotonically < or = inputs"
+ (fl<=? 1.0 1.2 1.2))
+
+ (pass-if "fl<=? is #f non-monotonically < or = inputs"
+ (not (fl<=? 2.0 1.0 0.9))))
+
+(with-test-prefix "fl>?"
+ (pass-if "fl>? is #t for monotonically > inputs"
+ (fl>? 3.0 2.0 1.0))
+
+ (pass-if "fl>? is #f for non-monotonically > inputs"
+ (not (fl>? 1.0 1.0 1.2))))
+
+(with-test-prefix "fl>=?"
+ (pass-if "fl>=? is #t for monotonically > or = inputs"
+ (fl>=? 3.0 2.0 2.0))
+
+ (pass-if "fl>=? is #f for non-monotonically > or = inputs"
+ (not (fl>=? 1.0 1.2 1.2))))
+
+(with-test-prefix "flinteger?"
+ (pass-if "flinteger? is #t on integer flomnums"
+ (flinteger? 1.0))
+
+ (pass-if "flinteger? is #f on non-integer flonums"
+ (not (flinteger? 1.5))))
+
+(with-test-prefix "flzero?"
+ (pass-if "flzero? is #t for 0.0 and -0.0"
+ (and (flzero? 0.0) (flzero? -0.0)))
+
+ (pass-if "flzero? is #f for non-zero flonums"
+ (not (flzero? 1.0))))
+
+(with-test-prefix "flpositive?"
+ (pass-if "flpositive? is #t on positive flonum"
+ (flpositive? 1.0))
+
+ (pass-if "flpositive? is #f on negative flonum"
+ (not (flpositive? -1.0)))
+
+ (pass-if "0.0 and -0.0 are not flpositive"
+ (and (not (flpositive? 0.0)) (not (flpositive? -0.0)))))
+
+(with-test-prefix "flnegative?"
+ (pass-if "flnegative? is #t on negative flonum"
+ (flnegative? -1.0))
+
+ (pass-if "flnegative? is #f on positive flonum"
+ (not (flnegative? 1.0)))
+
+ (pass-if "0.0 and -0.0 are not flnegative"
+ (and (not (flnegative? 0.0)) (not (flnegative? -0.0)))))
+
+(with-test-prefix "flodd?"
+ (pass-if "&assertion raised on non-integer flonum"
+ (guard (condition ((assertion-violation? condition) #t) (else #f))
+ (begin (flodd? 1.5) #f)))
+
+ (pass-if "flodd? is #t on odd flonums"
+ (flodd? 3.0))
+
+ (pass-if "flodd? is #f on even flonums"
+ (not (flodd? 2.0))))
+
+(with-test-prefix "fleven?"
+ (pass-if "&assertion raised on non-integer flonum"
+ (guard (condition ((assertion-violation? condition) #t) (else #f))
+ (begin (fleven? 1.5) #f)))
+
+ (pass-if "fleven? is #t on even flonums"
+ (fleven? 2.0))
+
+ (pass-if "fleven? is #f on odd flonums"
+ (not (fleven? 3.0))))
+
+(with-test-prefix "flfinite?"
+ (pass-if "flfinite? is #t on non-infinite flonums"
+ (flfinite? 2.0))
+
+ (pass-if "flfinite? is #f on infinities"
+ (and (not (flfinite? +inf.0)) (not (flfinite? -inf.0)))))
+
+(with-test-prefix "flinfinite?"
+ (pass-if "flinfinite? is #t on infinities"
+ (and (flinfinite? +inf.0) (flinfinite? -inf.0)))
+
+ (pass-if "flinfinite? is #f on non-infinite flonums"
+ (not (flinfinite? 2.0))))
+
+(with-test-prefix "flnan?"
+ (pass-if "flnan? is #t on NaN and -NaN"
+ (and (flnan? +nan.0) (flnan? -nan.0)))
+
+ (pass-if "flnan? is #f on non-NaN values"
+ (not (flnan? 1.5))))
+
+(with-test-prefix "flmax"
+ (pass-if "simple" (fl=? (flmax 1.0 3.0 2.0) 3.0)))
+
+(with-test-prefix "flmin"
+ (pass-if "simple" (fl=? (flmin -1.0 0.0 2.0) -1.0)))
+
+(with-test-prefix "fl+"
+ (pass-if "simple" (fl=? (fl+ 2.141 1.0 0.1) 3.241)))
+
+(with-test-prefix "fl*"
+ (pass-if "simple" (fl=? (fl* 1.0 2.0 3.0 1.5) 9.0)))
+
+(with-test-prefix "fl-"
+ (pass-if "unary fl- negates argument" (fl=? (fl- 2.0) -2.0))
+
+ (pass-if "simple" (fl=? (fl- 10.5 6.0 0.5) 4.0)))
+
+(with-test-prefix "fl/"
+ (pass-if "unary fl/ returns multiplicative inverse" (fl=? (fl/ 10.0) 0.1))
+
+ (pass-if "simple" (fl=? (fl/ 10.0 2.0 2.0) 2.5)))
+
+(with-test-prefix "flabs"
+ (pass-if "simple" (and (fl=? (flabs -1.0) 1.0) (fl=? (flabs 1.23) 1.23))))
+
+(with-test-prefix "fldiv-and-mod"
+ (pass-if "simple"
+ (call-with-values (lambda () (fldiv-and-mod 5.0 2.0))
+ (lambda (div mod) (fl=? div 2.0) (fl=? mod 1.0)))))
+
+(with-test-prefix "fldiv"
+ (pass-if "simple" (fl=? (fldiv 5.0 2.0) 2.0)))
+
+(with-test-prefix "flmod"
+ (pass-if "simple" (fl=? (flmod 5.0 2.0) 1.0)))
+
+(with-test-prefix "fldiv0-and-mod0"
+ (pass-if "simple"
+ (call-with-values (lambda () (fldiv0-and-mod0 -123.0 10.0))
+ (lambda (div mod)
+ (or (and (fl=? div -12.0) (fl=? mod -3.0))
+ (throw 'unresolved))))))
+
+(with-test-prefix "fldiv0"
+ (pass-if "simple" (or (fl=? (fldiv0 -123.0 10.0) -12.0) (throw
'unresolved))))
+
+(with-test-prefix "flmod0"
+ (pass-if "simple" (or (fl=? (flmod0 -123.0 10.0) -3.0) (throw 'unresolved))))
+
+(with-test-prefix "flnumerator"
+ (pass-if "simple" (fl=? (flnumerator 0.5) 1.0))
+
+ (pass-if "infinities"
+ (and (fl=? (flnumerator +inf.0) +inf.0)
+ (fl=? (flnumerator -inf.0) -inf.0)))
+
+ (pass-if "negative zero" (fl=? (flnumerator -0.0) -0.0)))
+
+(with-test-prefix "fldenominator"
+ (pass-if "simple" (fl=? (fldenominator 0.5) 2.0))
+
+ (pass-if "infinities"
+ (and (fl=? (fldenominator +inf.0) 1.0)
+ (fl=? (fldenominator -inf.0) 1.0)))
+
+ (pass-if "zero" (fl=? (fldenominator 0.0) 1.0)))
+
+(with-test-prefix "flfloor"
+ (pass-if "simple"
+ (and (fl=? (flfloor -4.3) -5.0)
+ (fl=? (flfloor 3.5) 3.0))))
+
+(with-test-prefix "flceiling"
+ (pass-if "simple"
+ (and (fl=? (flceiling -4.3) -4.0)
+ (fl=? (flceiling 3.5) 4.0))))
+
+(with-test-prefix "fltruncate"
+ (pass-if "simple"
+ (and (fl=? (fltruncate -4.3) -4.0)
+ (fl=? (fltruncate 3.5) 3.0))))
+
+(with-test-prefix "flround"
+ (pass-if "simple"
+ (and (fl=? (flround -4.3) -4.0)
+ (fl=? (flround 3.5) 4.0))))
+
+(with-test-prefix "flexp"
+ (pass-if "infinities"
+ (and (fl=? (flexp +inf.0) +inf.0)
+ (fl=? (flexp -inf.0) 0.0))))
+
+(with-test-prefix "fllog"
+ (pass-if "unary fllog returns natural log"
+ (let ((l (fllog 2.718281828459045)))
+ (and (fl<=? 0.9 l) (fl>=? 1.1 l))))
+
+ (pass-if "infinities"
+ (and (fl=? (fllog +inf.0) +inf.0)
+ (flnan? (fllog -inf.0))))
+
+ (pass-if "zeroes" (fl=? (fllog 0.0) -inf.0))
+
+ (pass-if "binary fllog returns log in specified base"
+ (fl=? (fllog 8.0 2.0) 3.0)))
+
+(with-test-prefix "flsin"
+ (pass-if "simple"
+ (and (reasonably-close? (flsin (/ fake-pi 2)) 1.0)
+ (reasonably-close? (flsin (/ fake-pi 6)) 0.5))))
+
+(with-test-prefix "flcos"
+ (pass-if "simple"
+ (and (fl=? (flcos 0.0) 1.0) (reasonably-close? (flcos (/ fake-pi 3))
0.5))))
+
+(with-test-prefix "fltan"
+ (pass-if "simple"
+ (and (reasonably-close? (fltan (/ fake-pi 4)) 1.0)
+ (reasonably-close? (fltan (/ (* 3 fake-pi) 4)) -1.0))))
+
+(with-test-prefix "flasin"
+ (pass-if "simple"
+ (and (reasonably-close? (flasin 1.0) (/ fake-pi 2))
+ (reasonably-close? (flasin 0.5) (/ fake-pi 6)))))
+
+(with-test-prefix "flacos"
+ (pass-if "simple"
+ (and (fl=? (flacos 1.0) 0.0)
+ (reasonably-close? (flacos 0.5) (/ fake-pi 3)))))
+
+(with-test-prefix "flatan"
+ (pass-if "unary flatan"
+ (and (reasonably-close? (flatan 1.0) (/ fake-pi 4))
+ (reasonably-close? (flatan -1.0) (/ fake-pi -4))))
+
+ (pass-if "infinities"
+ (and (reasonably-close? (flatan -inf.0) -1.5707963267949)
+ (reasonably-close? (flatan +inf.0) 1.5707963267949)))
+
+ (pass-if "binary flatan"
+ (and (reasonably-close? (flatan 3.5 3.5) (/ fake-pi 4)))))
+
+(with-test-prefix "flsqrt"
+ (pass-if "simple" (fl=? (flsqrt 4.0) 2.0))
+
+ (pass-if "infinity" (fl=? (flsqrt +inf.0) +inf.0))
+
+ (pass-if "negative zero" (fl=? (flsqrt -0.0) -0.0)))
+
+(with-test-prefix "flexpt" (pass-if "simple" (fl=? (flexpt 2.0 3.0) 8.0)))
+
+(with-test-prefix "fixnum->flonum"
+ (pass-if "simple" (fl=? (fixnum->flonum 100) 100.0)))
diff --git a/test-suite/tests/r6rs-conditions.test
b/test-suite/tests/r6rs-conditions.test
new file mode 100644
index 0000000..5883131
--- /dev/null
+++ b/test-suite/tests/r6rs-conditions.test
@@ -0,0 +1,91 @@
+;;; r6rs-conditions.test --- Test suite for R6RS (rnrs conditions)
+
+;; 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 test-rnrs-conditions)
+ :use-module ((rnrs conditions) :version (6))
+ :use-module (test-suite lib))
+
+(with-test-prefix "condition?"
+ (pass-if "condition? is #t for simple conditions"
+ (condition? (make-error)))
+
+ (pass-if "condition? is #t for compound conditions"
+ (condition? (condition (make-error) (make-assertion-violation))))
+
+ (pass-if "condition? is #f for non-conditions"
+ (not (condition? 'foo))))
+
+(with-test-prefix "simple-conditions"
+ (pass-if "simple-conditions returns condition components"
+ (let* ((error (make-error))
+ (assertion (make-assertion-violation))
+ (c (condition error assertion))
+ (scs (simple-conditions c)))
+ (equal? scs (list error assertion))))
+
+ (pass-if "simple-conditions flattens compound conditions"
+ (let* ((implementation-restriction
+ (make-implementation-restriction-violation))
+ (error1 (make-error))
+ (c1 (condition implementation-restriction error1))
+ (error2 (make-error))
+ (assertion (make-assertion-violation))
+ (c2 (condition error2 assertion c1))
+ (scs (simple-conditions c2)))
+ (equal? scs (list error2 assertion implementation-restriction error1)))))
+
+(with-test-prefix "condition-predicate"
+ (pass-if "returned procedure identifies matching simple conditions"
+ (let ((mp (condition-predicate &message))
+ (mc (make-message-condition "test")))
+ (mp mc)))
+
+ (pass-if "returned procedure identifies matching compound conditions"
+ (let* ((sp (condition-predicate &serious))
+ (vp (condition-predicate &violation))
+ (sc (make-serious-condition))
+ (vc (make-violation))
+ (c (condition sc vc)))
+ (and (sp c) (vp c))))
+
+ (pass-if "returned procedure is #f for non-matching simple"
+ (let ((sp (condition-predicate &serious)))
+ (not (sp 'foo))))
+
+ (pass-if "returned procedure is #f for compound without match"
+ (let* ((ip (condition-predicate &irritants))
+ (sc (make-serious-condition))
+ (vc (make-violation))
+ (c (condition sc vc)))
+ (not (ip c)))))
+
+(with-test-prefix "condition-accessor"
+ (pass-if "accessor applies proc to field from simple condition"
+ (let* ((proc (lambda (c) (condition-message c)))
+ (ma (condition-accessor &message proc))
+ (mc (make-message-condition "foo")))
+ (equal? (ma mc) "foo")))
+
+ (pass-if "accessor applies proc to field from compound condition"
+ (let* ((proc (lambda (c) (condition-message c)))
+ (ma (condition-accessor &message proc))
+ (mc (make-message-condition "foo"))
+ (vc (make-violation))
+ (c (condition vc mc)))
+ (equal? (ma c) "foo"))))
diff --git a/test-suite/tests/r6rs-control.test
b/test-suite/tests/r6rs-control.test
new file mode 100644
index 0000000..0f099a0
--- /dev/null
+++ b/test-suite/tests/r6rs-control.test
@@ -0,0 +1,34 @@
+;;; r6rs-control.test --- Test suite for R6RS (rnrs control)
+
+;; 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 test-rnrs-control)
+ :use-module ((rnrs control) :version (6))
+ :use-module (test-suite lib))
+
+(with-test-prefix "when"
+ (pass-if "when true"
+ (eq? (when (> 3 2) 'greater) 'greater))
+ (pass-if "when false"
+ (unspecified? (when (< 3 2) 'greater))))
+
+(with-test-prefix "unless"
+ (pass-if "unless true"
+ (unspecified? (unless (> 3 2) 'less)))
+ (pass-if "unless false"
+ (eq? (unless (< 3 2) 'less) 'less)))
diff --git a/test-suite/tests/r6rs-enums.test b/test-suite/tests/r6rs-enums.test
new file mode 100644
index 0000000..d91de1c
--- /dev/null
+++ b/test-suite/tests/r6rs-enums.test
@@ -0,0 +1,257 @@
+;;; r6rs-enums.test --- Test suite for R6RS (rnrs enums)
+
+;; 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 test-rnrs-enums)
+ :use-module ((rnrs conditions) :version (6))
+ :use-module ((rnrs enums) :version (6))
+ :use-module ((rnrs exceptions) :version (6))
+ :use-module (test-suite lib))
+
+(define-enumeration foo-enumeration (foo bar baz) make-foo-set)
+
+(with-test-prefix "enum-set-universe"
+ (pass-if "universe of an enumeration is itself"
+ (let ((et (make-enumeration '(a b c))))
+ (eq? (enum-set-universe et) et)))
+
+ (pass-if "enum-set-universe returns universe"
+ (let* ((et (make-enumeration '(a b c)))
+ (es ((enum-set-constructor et) '(a b))))
+ (eq? (enum-set-universe es) et))))
+
+(with-test-prefix "enum-set-indexer"
+ (pass-if "indexer returns index of symbol in universe"
+ (let* ((universe (make-enumeration '(a b c)))
+ (set ((enum-set-constructor universe) '(a c)))
+ (indexer (enum-set-indexer set)))
+ (and (eqv? (indexer 'a) 0) (eqv? (indexer 'c) 2))))
+
+ (pass-if "indexer returns index of symbol in universe but not set"
+ (let* ((universe (make-enumeration '(a b c)))
+ (set ((enum-set-constructor universe) '(a c)))
+ (indexer (enum-set-indexer set)))
+ (eqv? (indexer 'b) 1)))
+
+ (pass-if "indexer returns #f for symbol not in universe"
+ (let* ((universe (make-enumeration '(a b c)))
+ (set ((enum-set-constructor universe) '(a b c)))
+ (indexer (enum-set-indexer set)))
+ (eqv? (indexer 'd) #f))))
+
+(with-test-prefix "enum-set->list"
+ (pass-if "enum-set->list returns members in universe order"
+ (let* ((universe (make-enumeration '(a b c d e)))
+ (set ((enum-set-constructor universe) '(d a e c))))
+ (equal? (enum-set->list set) '(a c d e)))))
+
+(with-test-prefix "enum-set-member?"
+ (pass-if "enum-set-member? is #t for set members"
+ (let* ((universe (make-enumeration '(a b c)))
+ (set ((enum-set-constructor universe) '(a b c))))
+ (enum-set-member? 'a set)))
+
+ (pass-if "enum-set-member? is #f for set non-members"
+ (let* ((universe (make-enumeration '(a b c)))
+ (set ((enum-set-constructor universe) '(a b c))))
+ (not (enum-set-member? 'd set))))
+
+ (pass-if "enum-set-member? is #f for universe but not set members"
+ (let* ((universe (make-enumeration '(a b c d)))
+ (set ((enum-set-constructor universe) '(a b c))))
+ (not (enum-set-member? 'd set)))))
+
+(with-test-prefix "enum-set-subset?"
+ (pass-if "enum-set-subset? is #t when set1 subset of set2"
+ (let* ((universe (make-enumeration '(a b c d e)))
+ (set1 ((enum-set-constructor universe) '(a b c)))
+ (set2 ((enum-set-constructor universe) '(a b c d))))
+ (enum-set-subset? set1 set2)))
+
+ (pass-if "enum-set-subset? is #t when universe and set are subsets"
+ (let* ((universe1 (make-enumeration '(a b c d)))
+ (universe2 (make-enumeration '(a b c d e)))
+ (set1 ((enum-set-constructor universe1) '(a b c)))
+ (set2 ((enum-set-constructor universe2) '(a b c d))))
+ (enum-set-subset? set1 set2)))
+
+ (pass-if "enum-set-subset? is #f when set not subset"
+ (let* ((universe (make-enumeration '(a b c d e)))
+ (set1 ((enum-set-constructor universe) '(a b c d)))
+ (set2 ((enum-set-constructor universe) '(a b c))))
+ (not (enum-set-subset? set1 set2))))
+
+ (pass-if "enum-set-subset? is #f when universe not subset"
+ (let* ((universe1 (make-enumeration '(a b c d e)))
+ (universe2 (make-enumeration '(a b c d)))
+ (set1 ((enum-set-constructor universe1) '(a b c)))
+ (set2 ((enum-set-constructor universe2) '(a b c d))))
+ (not (enum-set-subset? set1 set2)))))
+
+(with-test-prefix "enum-set=?"
+ (pass-if "enum-set=? is #t when sets are equal"
+ (let* ((universe1 (make-enumeration '(a b c)))
+ (universe2 (make-enumeration '(a b c)))
+ (set1 ((enum-set-constructor universe1) '(a b c)))
+ (set2 ((enum-set-constructor universe2) '(a b c))))
+ (enum-set=? set1 set2)))
+
+ (pass-if "enum-set=? is #f when sets are not equal"
+ (let* ((universe (make-enumeration '(a b c d)))
+ (set1 ((enum-set-constructor universe) '(a b)))
+ (set2 ((enum-set-constructor universe) '(c d))))
+ (not (enum-set=? set1 set2))))
+
+ (pass-if "enum-set=? is #f when universes are not equal"
+ (let* ((universe1 (make-enumeration '(a b c d)))
+ (universe2 (make-enumeration '(a b c d e)))
+ (set1 ((enum-set-constructor universe1) '(a b c d)))
+ (set2 ((enum-set-constructor universe2) '(a b c d))))
+ (not (enum-set=? set1 set2)))))
+
+(with-test-prefix "enum-set-union"
+ (pass-if "&assertion raised on different universes"
+ (guard (condition ((assertion-violation? condition) #t))
+ (let* ((universe1 (make-enumeration '(a b c)))
+ (universe2 (make-enumeration '(d e f)))
+ (set1 ((enum-set-constructor universe1) '(a b c)))
+ (set2 ((enum-set-constructor universe2) '(d e f))))
+ (enum-set-union set1 set2)
+ #f)))
+
+ (pass-if "enum-set-union creates union on overlapping sets"
+ (let* ((universe (make-enumeration '(a b c d e)))
+ (set1 ((enum-set-constructor universe) '(a b c)))
+ (set2 ((enum-set-constructor universe) '(c d e)))
+ (union (enum-set-union set1 set2)))
+ (equal? (enum-set->list union) '(a b c d e))))
+
+ (pass-if "enum-set-union creates union on disjoint sets"
+ (let* ((universe (make-enumeration '(a b c d e f)))
+ (set1 ((enum-set-constructor universe) '(a b c)))
+ (set2 ((enum-set-constructor universe) '(d e f)))
+ (union (enum-set-union set1 set2)))
+ (equal? (enum-set->list union) '(a b c d e f)))))
+
+(with-test-prefix "enum-set-intersection"
+ (pass-if "&assertion raised on different universes"
+ (guard (condition ((assertion-violation? condition) #t))
+ (let* ((universe1 (make-enumeration '(a b c)))
+ (universe2 (make-enumeration '(d e f)))
+ (set1 ((enum-set-constructor universe1) '(a b c)))
+ (set2 ((enum-set-constructor universe2) '(d e f))))
+ (enum-set-intersection set1 set2)
+ #f)))
+
+ (pass-if "enum-set-intersection on overlapping sets"
+ (let* ((universe (make-enumeration '(a b c d e)))
+ (set1 ((enum-set-constructor universe) '(a b c)))
+ (set2 ((enum-set-constructor universe) '(c d e)))
+ (intersection (enum-set-intersection set1 set2)))
+ (equal? (enum-set->list intersection) '(c))))
+
+ (pass-if "enum-set-intersection on disjoint sets"
+ (let* ((universe (make-enumeration '(a b c d e f)))
+ (set1 ((enum-set-constructor universe) '(a b c)))
+ (set2 ((enum-set-constructor universe) '(d e f)))
+ (intersection (enum-set-intersection set1 set2)))
+ (null? (enum-set->list intersection)))))
+
+(with-test-prefix "enum-set-difference"
+ (pass-if "&assertion raised on different universes"
+ (guard (condition ((assertion-violation? condition) #t))
+ (let* ((universe1 (make-enumeration '(a b c)))
+ (universe2 (make-enumeration '(d e f)))
+ (set1 ((enum-set-constructor universe1) '(a b c)))
+ (set2 ((enum-set-constructor universe2) '(d e f))))
+ (enum-set-difference set1 set2)
+ #f)))
+
+ (pass-if "enum-set-difference with subset"
+ (let* ((universe (make-enumeration '(a b c)))
+ (set1 ((enum-set-constructor universe) '(a b c)))
+ (set2 ((enum-set-constructor universe) '(a)))
+ (difference (enum-set-difference set1 set2)))
+ (equal? (enum-set->list difference) '(b c))))
+
+ (pass-if "enum-set-difference with superset is empty"
+ (let* ((universe (make-enumeration '(a b c d)))
+ (set1 ((enum-set-constructor universe) '(a b c)))
+ (set2 ((enum-set-constructor universe) '(a b c d)))
+ (difference (enum-set-difference set1 set2)))
+ (null? (enum-set->list difference)))))
+
+(with-test-prefix "enum-set-complement"
+ (pass-if "complement of empty set is universe"
+ (let* ((universe (make-enumeration '(a b c)))
+ (set ((enum-set-constructor universe) '()))
+ (complement (enum-set-complement set)))
+ (equal? (enum-set->list complement) (enum-set->list universe))))
+
+ (pass-if "simple complement"
+ (let* ((universe (make-enumeration '(a b c d)))
+ (set ((enum-set-constructor universe) '(a c)))
+ (complement (enum-set-complement set)))
+ (equal? (enum-set->list complement) '(b d)))))
+
+(with-test-prefix "enum-set-projection"
+ (pass-if "projection onto subset universe"
+ (let* ((universe1 (make-enumeration '(a b c d)))
+ (universe2 (make-enumeration '(a b c)))
+ (set1 ((enum-set-constructor universe1) '(a d)))
+ (set2 ((enum-set-constructor universe2) '(b c)))
+ (projection (enum-set-projection set1 set2)))
+ (equal? (enum-set->list projection) '(a))))
+
+ (pass-if "projection onto superset universe"
+ (let* ((universe1 (make-enumeration '(a b c)))
+ (universe2 (make-enumeration '(a b c d)))
+ (set1 ((enum-set-constructor universe1) '(a c)))
+ (set2 ((enum-set-constructor universe2) '(b d)))
+ (projection (enum-set-projection set1 set2)))
+ (equal? (enum-set->list projection) '(a c))))
+
+ (pass-if "projection onto disjoint universe"
+ (let* ((universe1 (make-enumeration '(a b c)))
+ (universe2 (make-enumeration '(d e f)))
+ (set1 ((enum-set-constructor universe1) '(a c)))
+ (set2 ((enum-set-constructor universe2) '(d f)))
+ (projection (enum-set-projection set1 set2)))
+ (equal? (enum-set->list projection) '()))))
+
+(with-test-prefix "define-enumeration"
+ (pass-if "define-enumeration creates bindings"
+ (and (defined? 'foo-enumeration) (defined? 'make-foo-set)))
+
+ (pass-if "type-name syntax raises &syntax on non-member"
+ (guard (condition ((syntax-violation? condition) #t))
+ (begin (eval '(foo-enumeration a) (current-module)) #f)))
+
+ (pass-if "type-name evaluates to quote on member"
+ (guard (condition ((syntax-violation? condition) #f))
+ (eq? (eval '(foo-enumeration foo) (current-module)) 'foo)))
+
+ (pass-if "constructor-syntax raises &syntax on non-members"
+ (guard (condition ((syntax-violation? condition) #t))
+ (begin (eval '(make-foo-set foo bar not-baz) (current-module)) #f)))
+
+ (pass-if "constructor-syntax evaluates to new set"
+ (guard (condition ((syntax-violation? condition) #f))
+ (equal? (enum-set->list (eval '(make-foo-set foo bar)
+ (current-module)))
+ '(foo bar)))))
diff --git a/test-suite/tests/r6rs-eval.test b/test-suite/tests/r6rs-eval.test
new file mode 100644
index 0000000..30a2e00
--- /dev/null
+++ b/test-suite/tests/r6rs-eval.test
@@ -0,0 +1,28 @@
+;;; r6rs-eval.test --- Test suite for R6RS (rnrs eval)
+
+;; 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 test-rnrs-eval)
+ :use-module ((rnrs eval) :version (6))
+ :use-module (test-suite lib))
+
+(with-test-prefix "environment"
+ (pass-if "simple"
+ (eqv? (eval '(eval:car (eval:cons 2 4))
+ (environment '(prefix (only (rnrs base) car cons) eval:)))
+ 2)))
diff --git a/test-suite/tests/r6rs-exceptions.test
b/test-suite/tests/r6rs-exceptions.test
new file mode 100644
index 0000000..54a4ddb
--- /dev/null
+++ b/test-suite/tests/r6rs-exceptions.test
@@ -0,0 +1,98 @@
+;;; r6rs-exceptions.test --- Test suite for R6RS (rnrs exceptions)
+
+;; 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 test-rnrs-exceptions)
+ :use-module ((rnrs conditions) :version (6))
+ :use-module ((rnrs exceptions) :version (6))
+ :use-module (test-suite lib))
+
+(with-test-prefix "with-exception-handler"
+ (pass-if "handler invoked on raise"
+ (let ((success #f))
+ (call/cc
+ (lambda (continuation)
+ (with-exception-handler
+ (lambda (condition) (set! success #t) (continuation))
+ (lambda () (raise (make-violation))))))
+ success))
+
+ (pass-if "handler not invoked unless raise"
+ (let ((success #f))
+ (call/cc
+ (lambda (continuation)
+ (with-exception-handler
+ (lambda (condition) (continuation))
+ (lambda () (set! success #t)))))
+ success)))
+
+(with-test-prefix "raise"
+ (pass-if "raise causes &non-continuable after handler"
+ (let ((success #f))
+ (call/cc
+ (lambda (continuation)
+ (with-exception-handler
+ (lambda (condition)
+ (set! success (non-continuable-violation? condition))
+ (continuation))
+ (lambda ()
+ (with-exception-handler
+ (lambda (condition) #f)
+ (lambda () (raise (make-violation))))))))
+ success)))
+
+(with-test-prefix "raise-continuable"
+ (pass-if "raise-continuable invokes continuation after handler"
+ (let ((handled #f)
+ (continued #f))
+ (call/cc
+ (lambda (continuation)
+ (with-exception-handler
+ (lambda (condition) (set! handled #t))
+ (lambda ()
+ (raise-continuable (make-violation))
+ (set! continued #t)))))
+ (and handled continued))))
+
+(with-test-prefix "guard"
+ (pass-if "guard with matching cond without else"
+ (let ((success #f))
+ (guard (condition ((error? condition) (set! success #t)))
+ (raise (make-error)))
+ success))
+
+ (pass-if "guard without matching cond without else"
+ (let ((success #f))
+ (call/cc
+ (lambda (continuation)
+ (with-exception-handler
+ (lambda (condition) (set! success (error? condition)) (continuation))
+ (lambda ()
+ (guard (condition ((irritants-condition? condition) #f))
+ (raise (make-error)))))))
+ success))
+
+ (pass-if "guard with else and without matching cond"
+ (let ((success #f))
+ (guard (condition ((irritants-condition? condition) #f)
+ (else (set! success #t)))
+ (raise (make-error)))
+ success))
+
+ (pass-if "guard with cond => syntax"
+ (guard (condition (condition => error?)) (raise (make-error)))))
diff --git a/test-suite/tests/r6rs-files.test b/test-suite/tests/r6rs-files.test
new file mode 100644
index 0000000..df5dd22
--- /dev/null
+++ b/test-suite/tests/r6rs-files.test
@@ -0,0 +1,40 @@
+;;; r6rs-files.test --- Test suite for R6RS (rnrs unicode)
+
+;; 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 test-rnrs-files)
+ :use-module ((rnrs exceptions) :version (6))
+ :use-module ((rnrs files) :version (6))
+ :use-module (test-suite lib))
+
+(with-test-prefix "delete-file"
+ (pass-if "delete-file deletes file"
+ (let ((filename (port-filename (mkstemp! "T-XXXXXX"))))
+ (delete-file filename)
+ (not (file-exists? filename))))
+
+ (pass-if "delete-file raises &i/o-filename on error"
+ (let ((success #f))
+ (call/cc
+ (lambda (continuation)
+ (with-exception-handler
+ (lambda (condition)
+ (set! success (i/o-filename-error? condition))
+ (continuation))
+ (lambda () (delete-file "")))))
+ success)))
diff --git a/test-suite/tests/r6rs-hashtables.test
b/test-suite/tests/r6rs-hashtables.test
new file mode 100644
index 0000000..9d5c730
--- /dev/null
+++ b/test-suite/tests/r6rs-hashtables.test
@@ -0,0 +1,178 @@
+;;; r6rs-hashtables.test --- Test suite for R6RS (rnrs hashtables)
+
+;; 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 Lice6nse, 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 test-rnrs-hashtable)
+ :use-module (ice-9 receive)
+ :use-module ((rnrs hashtables) :version (6))
+ :use-module (srfi srfi-1)
+ :use-module (test-suite lib))
+
+(with-test-prefix "make-eq-hashtable"
+ (pass-if "eq hashtable compares keys with eq?"
+ (let ((eq-hashtable (make-eq-hashtable)))
+ (hashtable-set! eq-hashtable (list 'foo) #t)
+ (hashtable-set! eq-hashtable 'sym #t)
+ (and (not (hashtable-contains? eq-hashtable (list 'foo)))
+ (hashtable-contains? eq-hashtable 'sym)))))
+
+(with-test-prefix "make-eqv-hashtable"
+ (pass-if "eqv hashtable compares keys with eqv?"
+ (let ((eqv-hashtable (make-eqv-hashtable)))
+ (hashtable-set! eqv-hashtable (list 'foo) #t)
+ (hashtable-set! eqv-hashtable 4 #t)
+ (and (not (hashtable-contains? eqv-hashtable (list 'foo)))
+ (hashtable-contains? eqv-hashtable 4)))))
+
+(with-test-prefix "make-hashtable"
+ (pass-if "hashtable compares keys with custom equality function"
+ (let* ((abs-eqv? (lambda (x y) (eqv? (abs x) (abs y))))
+ (abs-hashtable (make-hashtable abs abs-eqv?)))
+ (hashtable-set! abs-hashtable -4 #t)
+ (and (not (hashtable-contains? abs-hashtable 6))
+ (hashtable-contains? abs-hashtable 4)))))
+
+(with-test-prefix "hashtable?"
+ (pass-if "hashtable? is #t on hashtables"
+ (let ((hashtable (make-eq-hashtable)))
+ (hashtable? hashtable)))
+
+ (pass-if "hashtable? is #f on non-hashtables"
+ (let ((not-hashtable (list)))
+ (not (hashtable? not-hashtable)))))
+
+(with-test-prefix "hashtable-size"
+ (pass-if "hashtable-size returns current size"
+ (let ((hashtable (make-eq-hashtable)))
+ (and (eqv? (hashtable-size hashtable) 0)
+ (hashtable-set! hashtable 'foo #t)
+ (eqv? (hashtable-size hashtable) 1)))))
+
+(with-test-prefix "hashtable-ref"
+ (pass-if "hashtable-ref returns value for bound key"
+ (let ((hashtable (make-eq-hashtable)))
+ (hashtable-set! hashtable 'sym 'foo)
+ (eq? (hashtable-ref hashtable 'sym 'bar) 'foo)))
+
+ (pass-if "hashtable-ref returns default for unbound key"
+ (let ((hashtable (make-eq-hashtable)))
+ (eq? (hashtable-ref hashtable 'sym 'bar) 'bar))))
+
+(with-test-prefix "hashtable-set!"
+ (pass-if "hashtable-set! returns unspecified"
+ (let ((hashtable (make-eq-hashtable)))
+ (unspecified? (hashtable-set! hashtable 'foo 'bar))))
+
+ (pass-if "hashtable-set! allows storing #f"
+ (let ((hashtable (make-eq-hashtable)))
+ (hashtable-set! hashtable 'foo #f)
+ (not (hashtable-ref hashtable 'foo 'bar)))))
+
+(with-test-prefix "hashtable-delete!"
+ (pass-if "hashtable-delete! removes association"
+ (let ((hashtable (make-eq-hashtable)))
+ (hashtable-set! hashtable 'foo 'bar)
+ (and (unspecified? (hashtable-delete! hashtable 'foo))
+ (not (hashtable-ref hashtable 'foo #f))))))
+
+(with-test-prefix "hashtable-contains?"
+ (pass-if "hashtable-contains? returns #t when association present"
+ (let ((hashtable (make-eq-hashtable)))
+ (hashtable-set! hashtable 'foo 'bar)
+ (let ((contains (hashtable-contains? hashtable 'foo)))
+ (and (boolean? contains) contains))))
+
+ (pass-if "hashtable-contains? returns #f when association not present"
+ (let ((hashtable (make-eq-hashtable)))
+ (not (hashtable-contains? hashtable 'foo)))))
+
+(with-test-prefix "hashtable-update!"
+ (pass-if "hashtable-update! adds return value of proc on bound key"
+ (let ((hashtable (make-eq-hashtable)))
+ (hashtable-set! hashtable 'foo 0)
+ (hashtable-update! hashtable 'foo (lambda (x) (+ x 1)) 100)
+ (eqv? (hashtable-ref hashtable 'foo #f) 1)))
+
+ (pass-if "hashtable-update! adds default value on unbound key"
+ (let ((hashtable (make-eq-hashtable)))
+ (hashtable-update! hashtable 'foo (lambda (x) (+ x 1)) 100)
+ (eqv? (hashtable-ref hashtable 'foo #f) 101))))
+
+(with-test-prefix "hashtable-copy"
+ (pass-if "hashtable-copy produces copy of hashtable"
+ (let ((hashtable (make-eq-hashtable)))
+ (hashtable-set! hashtable 'foo 1)
+ (hashtable-set! hashtable 'bar 2)
+ (let ((copied-table (hashtable-copy hashtable)))
+ (and (eqv? (hashtable-ref hashtable 'foo #f) 1)
+ (eqv? (hashtable-ref hashtable 'bar #f) 2)))))
+
+ (pass-if "hashtable-copy with mutability #f produces immutable copy"
+ (let ((copied-table (hashtable-copy (make-eq-hashtable) #f)))
+ (hashtable-set! copied-table 'foo 1)
+ (not (hashtable-ref copied-table 'foo #f)))))
+
+(with-test-prefix "hashtable-clear!"
+ (pass-if "hashtable-clear! removes all values from hashtable"
+ (let ((hashtable (make-eq-hashtable)))
+ (hashtable-set! hashtable 'foo 1)
+ (hashtable-set! hashtable 'bar 2)
+ (and (unspecified? (hashtable-clear! hashtable))
+ (eqv? (hashtable-size hashtable) 0)))))
+
+(with-test-prefix "hashtable-keys"
+ (pass-if "hashtable-keys returns all keys"
+ (let ((hashtable (make-eq-hashtable)))
+ (hashtable-set! hashtable 'foo #t)
+ (hashtable-set! hashtable 'bar #t)
+ (let ((keys (vector->list (hashtable-keys hashtable))))
+ (and (memq 'foo keys) (memq 'bar keys) #t)))))
+
+(with-test-prefix "hashtable-entries"
+ (pass-if "hashtable-entries returns all entries"
+ (let ((hashtable (make-eq-hashtable)))
+ (hashtable-set! hashtable 'foo 1)
+ (hashtable-set! hashtable 'bar 2)
+ (receive
+ (keys values)
+ (hashtable-entries hashtable)
+ (let f ((counter 0) (success #t))
+ (if (or (not success) (= counter 2))
+ success
+ (case (vector-ref keys counter)
+ ((foo) (f (+ counter 1) (eqv? (vector-ref values counter) 1)))
+ ((bar) (f (+ counter 1) (eqv? (vector-ref values counter) 2)))
+ (else f 0 #f))))))))
+
+(with-test-prefix "hashtable-equivalence-function"
+ (pass-if "hashtable-equivalence-function returns eqv function"
+ (let* ((abs-eqv? (lambda (x y) (eqv? (abs x) (abs y))))
+ (abs-hashtable (make-hashtable abs abs-eqv?)))
+ (eq? (hashtable-equivalence-function abs-hashtable) abs-eqv?))))
+
+(with-test-prefix "hashtable-hash-function"
+ (pass-if "hashtable-hash-function returns hash function"
+ (let ((abs-hashtable (make-hashtable abs eqv?)))
+ (eq? (hashtable-hash-function abs-hashtable) abs))))
+
+(with-test-prefix "hashtable-mutable?"
+ (pass-if "hashtable-mutable? is #t on mutable hashtables"
+ (hashtable-mutable? (hashtable-copy (make-eq-hashtable) #t)))
+
+ (pass-if "hashtable-mutable? is #f on immutable hashtables"
+ (not (hashtable-mutable? (hashtable-copy (make-eq-hashtable) #f)))))
diff --git a/test-suite/tests/r6rs-records-inspection.test
b/test-suite/tests/r6rs-records-inspection.test
new file mode 100644
index 0000000..8603626
--- /dev/null
+++ b/test-suite/tests/r6rs-records-inspection.test
@@ -0,0 +1,148 @@
+;;; r6rs-control.test --- Test suite for R6RS (rnrs control)
+
+;; 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 test-rnrs-records-procedural)
+ :use-module ((rnrs conditions) :version (6))
+ :use-module ((rnrs exceptions) :version (6))
+ :use-module ((rnrs records inspection) :version (6))
+ :use-module ((rnrs records procedural) :version (6))
+ :use-module (test-suite lib))
+
+(with-test-prefix "record?"
+ (pass-if "record? recognizes non-opaque records"
+ (let* ((rec (make-record-type-descriptor 'rec #f #f #f #f '#()))
+ (make-rec (record-constructor
+ (make-record-constructor-descriptor rec #f #f))))
+ (record? (make-rec))))
+
+ (pass-if "record? doesn't recognize opaque records"
+ (let* ((rec (make-record-type-descriptor 'rec #f #f #f #t '#()))
+ (make-rec (record-constructor
+ (make-record-constructor-descriptor rec #f #f))))
+ (not (record? (make-rec)))))
+
+ (pass-if "record? doesn't recognize non-records" (not (record? 'foo))))
+
+(with-test-prefix "record-rtd"
+ (pass-if "simple"
+ (let* ((rtd (make-record-type-descriptor 'rec #f #f #f #f '#()))
+ (make-rec (record-constructor
+ (make-record-constructor-descriptor rtd #f #f))))
+ (eq? (record-rtd (make-rec)) rtd)))
+
+ (pass-if "&assertion on opaque record"
+ (let* ((rtd (make-record-type-descriptor 'rec #f #f #f #t '#()))
+ (make-rec (record-constructor
+ (make-record-constructor-descriptor rtd #f #f)))
+ (success #f))
+ (call/cc
+ (lambda (continuation)
+ (with-exception-handler
+ (lambda (condition)
+ (set! success (assertion-violation? condition))
+ (continuation))
+ (lambda () (record-rtd (make-rec))))))
+ success)))
+
+(with-test-prefix "record-type-name"
+ (pass-if "simple"
+ (let* ((rtd (make-record-type-descriptor 'foo #f #f #f #f '#())))
+ (eq? (record-type-name rtd) 'foo))))
+
+(with-test-prefix "record-type-parent"
+ (pass-if "eq? to parent"
+ (let* ((rtd-parent (make-record-type-descriptor 'foo #f #f #f #f '#()))
+ (rtd (make-record-type-descriptor 'bar rtd-parent #f #f #f '#())))
+ (eq? (record-type-parent rtd) rtd-parent)))
+
+ (pass-if "#f when parent not present"
+ (let* ((rtd (make-record-type-descriptor 'foo #f #f #f #f '#())))
+ (not (record-type-parent rtd)))))
+
+(with-test-prefix "record-type-uid"
+ (pass-if "eq? to uid"
+ (let* ((uid (gensym))
+ (rtd (make-record-type-descriptor uid #f uid #f #f '#())))
+ (eq? (record-type-uid rtd) uid)))
+
+ (pass-if "#f when uid not present"
+ (let* ((rtd (make-record-type-descriptor 'foo #f #f #f #f '#())))
+ (not (record-type-uid rtd)))))
+
+(with-test-prefix "record-type-generative?"
+ (pass-if "#f when uid is not #f"
+ (let* ((uid (gensym))
+ (rtd (make-record-type-descriptor uid #f uid #f #f '#())))
+ (not (record-type-generative? rtd))))
+
+ (pass-if "#t when uid is #f"
+ (let* ((rtd (make-record-type-descriptor 'foo #f #f #f #f '#())))
+ (record-type-generative? rtd))))
+
+(with-test-prefix "record-type-sealed?"
+ (pass-if "#t when sealed? is #t"
+ (let* ((rtd (make-record-type-descriptor 'foo #f #f #t #f '#())))
+ (record-type-sealed? rtd)))
+
+ (pass-if "#f when sealed? is #f"
+ (let* ((rtd (make-record-type-descriptor 'foo #f #f #f #f '#())))
+ (not (record-type-sealed? rtd)))))
+
+(with-test-prefix "record-type-opaque?"
+ (pass-if "#t when opaque? is #t"
+ (let* ((rtd (make-record-type-descriptor 'foo #f #f #f #t '#())))
+ (record-type-opaque? rtd)))
+
+ (pass-if "#f when opaque? is #f"
+ (let* ((rtd (make-record-type-descriptor 'foo #f #f #f #f '#())))
+ (not (record-type-opaque? rtd))))
+
+ (pass-if "#t when parent is opaque"
+ (let* ((parent-rtd (make-record-type-descriptor 'foo #f #f #f #t '#()))
+ (rtd (make-record-type-descriptor 'bar parent-rtd #f #f #f '#())))
+ (record-type-opaque? rtd))))
+
+(with-test-prefix "record-type-field-names"
+ (pass-if "simple"
+ (let* ((rtd (make-record-type-descriptor 'foobar #f #f #f #f
+ '#((immutable foo)
+ (mutable bar)))))
+ (equal? (record-type-field-names rtd) '#(foo bar))))
+
+ (pass-if "parent fields not included"
+ (let* ((parent-rtd (make-record-type-descriptor 'foo #f #f #f #f
+ '#((mutable foo))))
+ (rtd (make-record-type-descriptor 'bar parent-rtd #f #f #f
+ '#((immutable bar)))))
+ (equal? (record-type-field-names rtd) '#(bar))))
+
+ (pass-if "subtype fields not included"
+ (let* ((parent-rtd (make-record-type-descriptor 'foo #f #f #f #f
+ '#((mutable foo))))
+ (rtd (make-record-type-descriptor 'bar parent-rtd #f #f #f
+ '#((immutable bar)))))
+ (equal? (record-type-field-names parent-rtd) '#(foo)))))
+
+(with-test-prefix "record-field-mutable?"
+ (pass-if "simple"
+ (let* ((rtd (make-record-type-descriptor 'foobar #f #f #f #f
+ '#((mutable foo)
+ (immutable bar)))))
+ (and (record-field-mutable? rtd 0)
+ (not (record-field-mutable? rtd 1))))))
diff --git a/test-suite/tests/r6rs-records-procedural.test
b/test-suite/tests/r6rs-records-procedural.test
new file mode 100644
index 0000000..a1621f1
--- /dev/null
+++ b/test-suite/tests/r6rs-records-procedural.test
@@ -0,0 +1,244 @@
+;;; r6rs-records-procedural.test --- Test suite for R6RS
+;;; (rnrs records procedural)
+
+;; 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 test-rnrs-records-procedural)
+ :use-module ((rnrs conditions) :version (6))
+ :use-module ((rnrs exceptions) :version (6))
+ :use-module ((rnrs records procedural) :version (6))
+ :use-module (test-suite lib))
+
+(define :point (make-record-type-descriptor
+ 'point #f #f #f #f '#((mutable x) (mutable y))))
+(define :point-cd (make-record-constructor-descriptor :point #f #f))
+
+(define :voxel (make-record-type-descriptor
+ 'voxel :point #f #f #f '#((mutable z))))
+(define :voxel-cd (make-record-constructor-descriptor :voxel :point-cd #f))
+
+(with-test-prefix "make-record-type-descriptor"
+ (pass-if "simple"
+ (let* ((:point-cd (make-record-constructor-descriptor :point #f #f))
+ (make-point (record-constructor :point-cd))
+ (point? (record-predicate :point))
+ (point-x (record-accessor :point 0))
+ (point-y (record-accessor :point 1))
+ (point-x-set! (record-mutator :point 0))
+ (point-y-set! (record-mutator :point 1))
+ (p1 (make-point 1 2)))
+ (point? p1)
+ (eqv? (point-x p1) 1)
+ (eqv? (point-y p1) 2)
+ (unspecified? (point-x-set! p1 5))
+ (eqv? (point-x p1) 5)))
+
+ (pass-if "sealed records cannot be subtyped"
+ (let* ((:sealed-point (make-record-type-descriptor
+ 'sealed-point #f #f #t #f '#((mutable x)
+ (mutable y))))
+ (success #f))
+ (call/cc
+ (lambda (continuation)
+ (with-exception-handler
+ (lambda (condition)
+ (set! success (assertion-violation? condition))
+ (continuation))
+ (lambda () (make-record-type-descriptor
+ 'sealed-point-subtype :sealed-point #f #f #f
+ '#((mutable z)))))))
+ success))
+
+ (pass-if "non-generative records with same uid are eq"
+ (let* ((:rtd-1 (make-record-type-descriptor
+ 'rtd1 #f 'my-uid #f #f '#((mutable foo) (immutable bar))))
+ (:rtd-2 (make-record-type-descriptor
+ 'rtd1 #f 'my-uid #f #f '#((mutable foo) (immutable bar)))))
+ (eq? :rtd-1 :rtd-2)))
+
+ (pass-if "&assertion raised on conflicting non-generative types"
+ (let* ((:rtd-1 (make-record-type-descriptor
+ 'rtd1 #f 'my-uid-2 #f #f '#((mutable foo) (immutable bar))))
+ (success 0)
+ (check-definition
+ (lambda (thunk)
+ (call/cc
+ (lambda (continuation)
+ (with-exception-handler
+ (lambda (condition)
+ (if (assertion-violation? condition)
+ (set! success (+ success 1)))
+ (continuation))
+ thunk))))))
+ (check-definition
+ (lambda ()
+ (make-record-type-descriptor
+ 'rtd1a #f 'my-uid-2 #f #f '#((mutable foo) (immutable bar)))))
+ (check-definition
+ (lambda ()
+ (make-record-type-descriptor
+ 'rtd1 :point 'my-uid-2 #f #f '#((mutable foo) (immutable bar)))))
+ (check-definition
+ (lambda ()
+ (make-record-type-descriptor
+ 'rtd1 #f 'my-uid-2 #t #f '#((mutable foo) (immutable bar)))))
+ (check-definition
+ (lambda ()
+ (make-record-type-descriptor
+ 'rtd1 #f 'my-uid-2 #f #t '#((mutable foo) (immutable bar)))))
+ (check-definition
+ (lambda () (make-record-type-descriptor 'rtd1 #f 'my-uid-2 #f #f '#())))
+ (check-definition
+ (lambda ()
+ (make-record-type-descriptor
+ 'rtd1 #f 'my-uid-2 #f #f '#((mutable foo) (immutable baz)))))
+ (check-definition
+ (lambda ()
+ (make-record-type-descriptor
+ 'rtd1 #f 'my-uid-2 #f #f '#((immutable foo) (immutable bar)))))
+ (eqv? success 7))))
+
+(with-test-prefix "make-record-constructor-descriptor"
+ (pass-if "simple protocol"
+ (let* ((:point-protocol (lambda (p) (lambda (x y) (p (+ x 1) (+ y 1)))))
+ (:point-protocol-cd (make-record-constructor-descriptor
+ :point #f :point-protocol))
+ (make-point (record-constructor :point-protocol-cd))
+ (point-x (record-accessor :point 0))
+ (point-y (record-accessor :point 1))
+ (point (make-point 1 2)))
+ (and (eqv? (point-x point) 2)
+ (eqv? (point-y point) 3))))
+
+ (pass-if "protocol delegates to parent with protocol"
+ (let* ((:point-protocol (lambda (p) (lambda (x y) (p (+ x 1) (+ y 1)))))
+ (:point-protocol-cd (make-record-constructor-descriptor
+ :point #f :point-protocol))
+ (:voxel-protocol (lambda (n)
+ (lambda (x y z)
+ (let ((p (n x y))) (p (+ z 100))))))
+ (:voxel-protocol-cd (make-record-constructor-descriptor
+ :voxel :point-protocol-cd :voxel-protocol))
+ (make-voxel (record-constructor :voxel-protocol-cd))
+ (point-x (record-accessor :point 0))
+ (point-y (record-accessor :point 1))
+ (voxel-z (record-accessor :voxel 0))
+ (voxel (make-voxel 1 2 3)))
+ (and (eqv? (point-x voxel) 2)
+ (eqv? (point-y voxel) 3)
+ (eqv? (voxel-z voxel) 103)))))
+
+(with-test-prefix "record-type-descriptor?"
+ (pass-if "simple"
+ (record-type-descriptor?
+ (make-record-type-descriptor 'test #f #f #f #f '#()))))
+
+(with-test-prefix "record-constructor"
+ (pass-if "simple"
+ (let* ((make-point (record-constructor :point-cd))
+ (point? (record-predicate :point))
+ (point-x (record-accessor :point 0))
+ (point-y (record-accessor :point 1))
+ (point (make-point 1 2)))
+ (and (point? point)
+ (eqv? (point-x point) 1)
+ (eqv? (point-y point) 2))))
+
+ (pass-if "construct record subtype"
+ (let* ((make-voxel (record-constructor :voxel-cd))
+ (voxel? (record-predicate :voxel))
+ (voxel-z (record-accessor :voxel 0))
+ (voxel (make-voxel 1 2 3)))
+ (and (voxel? voxel)
+ (eqv? (voxel-z voxel) 3)))))
+
+(with-test-prefix "record-predicate"
+ (pass-if "simple"
+ (let* ((make-point (record-constructor :point-cd))
+ (point (make-point 1 2))
+ (point? (record-predicate :point)))
+ (point? point)))
+
+ (pass-if "predicate returns true on subtype"
+ (let* ((make-voxel (record-constructor :voxel-cd))
+ (voxel (make-voxel 1 2 3))
+ (point? (record-predicate :point)))
+ (point? voxel)))
+
+ (pass-if "predicate returns false on supertype"
+ (let* ((make-point (record-constructor :point-cd))
+ (point (make-point 1 2))
+ (voxel? (record-predicate :voxel)))
+ (not (voxel? point)))))
+
+(with-test-prefix "record-accessor"
+ (pass-if "simple"
+ (let* ((make-point (record-constructor :point-cd))
+ (point (make-point 1 2))
+ (point-x (record-accessor :point 0))
+ (point-y (record-accessor :point 1)))
+ (and (eqv? (point-x point) 1)
+ (eqv? (point-y point) 2))))
+
+ (pass-if "accessor for supertype applied to subtype"
+ (let* ((make-voxel (record-constructor :voxel-cd))
+ (voxel (make-voxel 1 2 3))
+ (point-x (record-accessor :point 0))
+ (point-y (record-accessor :point 1)))
+ (and (eqv? (point-x voxel) 1)
+ (eqv? (point-y voxel) 2)))))
+
+(with-test-prefix "record-mutator"
+ (pass-if "simple"
+ (let* ((make-point (record-constructor :point-cd))
+ (point (make-point 1 2))
+ (point-set-x! (record-mutator :point 0))
+ (point-set-y! (record-mutator :point 1))
+ (point-x (record-accessor :point 0))
+ (point-y (record-accessor :point 1)))
+ (point-set-x! point 3)
+ (point-set-y! point 4)
+ (and (eqv? (point-x point) 3)
+ (eqv? (point-y point) 4))))
+
+ (pass-if "&assertion raised on request for immutable field"
+ (let* ((:immutable-point (make-record-type-descriptor
+ 'point #f #f #f #f '#((immutable x)
+ (immutable y))))
+ (success #f))
+ (call/cc
+ (lambda (continuation)
+ (with-exception-handler
+ (lambda (condition)
+ (set! success (assertion-violation? condition))
+ (continuation))
+ (lambda () (record-mutator :immutable-point 0)))))
+ success))
+
+ (pass-if "mutator for supertype applied to subtype"
+ (let* ((make-voxel (record-constructor :voxel-cd))
+ (voxel (make-voxel 1 2 3))
+ (point-set-x! (record-mutator :point 0))
+ (point-set-y! (record-mutator :point 1))
+ (point-x (record-accessor :point 0))
+ (point-y (record-accessor :point 1)))
+ (point-set-x! voxel 3)
+ (point-set-y! voxel 4)
+ (and (eqv? (point-x voxel) 3)
+ (eqv? (point-y voxel) 4)))))
+
diff --git a/test-suite/tests/r6rs-records-syntactic.test
b/test-suite/tests/r6rs-records-syntactic.test
new file mode 100644
index 0000000..64b2fbb
--- /dev/null
+++ b/test-suite/tests/r6rs-records-syntactic.test
@@ -0,0 +1,116 @@
+;;; r6rs-records-syntactic.test --- Test suite for R6RS (rnrs records
syntactic)
+
+;; 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 test-rnrs-records-syntactic)
+ :use-module ((rnrs records syntactic) :version (6))
+ :use-module ((rnrs records procedural) :version (6))
+ :use-module ((rnrs records inspection) :version (6))
+ :use-module (test-suite lib))
+
+(define-record-type simple-rtd)
+(define-record-type
+ (specified-rtd specified-rtd-constructor specified-rtd-predicate))
+(define-record-type parent-rtd (fields x y))
+(define-record-type child-parent-rtd-rtd
+ (parent-rtd (record-type-descriptor parent-rtd)
+ (record-constructor-descriptor parent-rtd))
+ (fields z))
+(define-record-type child-parent-rtd (parent parent-rtd) (fields z))
+(define-record-type mutable-fields-rtd
+ (fields (mutable mutable-bar)
+ (mutable mutable-baz mutable-baz-accessor mutable-baz-mutator)))
+(define-record-type immutable-fields-rtd
+ (fields immutable-foo
+ (immutable immutable-bar)
+ (immutable immutable-baz immutable-baz-accessor)))
+(define-record-type protocol-rtd
+ (fields (immutable x) (immutable y))
+ (protocol (lambda (p) (lambda (x y) (p (+ x 1) (+ y 1))))))
+(define-record-type sealed-rtd (sealed #t))
+(define-record-type opaque-rtd (opaque #t))
+(define-record-type nongenerative-rtd (nongenerative))
+(define-record-type nongenerative-uid-rtd (nongenerative foo))
+
+(with-test-prefix "simple record names"
+ (pass-if "define-record-type defines record type"
+ (defined? 'simple-rtd))
+
+ (pass-if "define-record-type defines record predicate"
+ (defined? 'simple-rtd?))
+
+ (pass-if "define-record-type defines record-constructor"
+ (defined? 'make-simple-rtd)))
+
+(with-test-prefix "fully-specified record names"
+ (pass-if "define-record-type defines named predicate"
+ (defined? 'specified-rtd-predicate))
+
+ (pass-if "define-record-type defines named constructor"
+ (defined? 'specified-rtd-constructor)))
+
+(pass-if "parent-rtd clause includes specified parent"
+ (eq? (record-type-parent child-parent-rtd-rtd) parent-rtd))
+
+(pass-if "parent clause includes specified parent"
+ (eq? (record-type-parent child-parent-rtd) parent-rtd))
+
+(pass-if "protocol clause includes specified protocol"
+ (let ((protocol-record (make-protocol-rtd 1 2)))
+ (and (eqv? (protocol-rtd-x protocol-record) 2)
+ (eqv? (protocol-rtd-y protocol-record) 3))))
+
+(pass-if "sealed clause produces sealed type"
+ (record-type-sealed? sealed-rtd))
+
+(pass-if "opaque clause produces opaque type"
+ (record-type-opaque? opaque-rtd))
+
+(with-test-prefix "nongenerative"
+ (pass-if "nongenerative clause produces nongenerative type"
+ (not (record-type-generative? nongenerative-rtd)))
+
+ (pass-if "nongenerative clause preserves specified uid"
+ (and (not (record-type-generative? nongenerative-uid-rtd))
+ (eq? (record-type-uid nongenerative-uid-rtd) 'foo))))
+
+(with-test-prefix "fields"
+ (pass-if "raw symbol produces accessor only"
+ (and (defined? 'immutable-fields-rtd-immutable-foo)
+ (not (defined? 'immutable-fields-rtd-immutable-foo-set!))))
+
+ (pass-if "(immutable x) form produces accessor only"
+ (and (defined? 'immutable-fields-rtd-immutable-bar)
+ (not (defined? 'immutable-fields-rtd-immutable-bar-set!))))
+
+ (pass-if "(immutable x y) form produces named accessor"
+ (defined? 'immutable-baz-accessor))
+
+ (pass-if "(mutable x) form produces accessor and mutator"
+ (and (defined? 'mutable-fields-rtd-mutable-bar)
+ (defined? 'mutable-fields-rtd-mutable-bar-set!)))
+
+ (pass-if "(mutable x y) form produces named accessor and mutator"
+ (and (defined? 'mutable-baz-accessor)
+ (defined? 'mutable-baz-mutator))))
+
+(pass-if "record-type-descriptor returns rtd"
+ (eq? (record-type-descriptor simple-rtd) simple-rtd))
+
+(pass-if "record-constructor-descriptor returns rcd"
+ (procedure? (record-constructor (record-constructor-descriptor simple-rtd))))
diff --git a/test-suite/tests/r6rs-unicode.test
b/test-suite/tests/r6rs-unicode.test
new file mode 100644
index 0000000..d8a69a1
--- /dev/null
+++ b/test-suite/tests/r6rs-unicode.test
@@ -0,0 +1,50 @@
+;;; r6rs-unicode.test --- Test suite for R6RS (rnrs unicode)
+
+;; 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 test-rnrs-unicode)
+ :use-module ((rnrs unicode) :version (6))
+ :use-module (test-suite lib))
+
+(with-test-prefix "char-foldcase"
+ (pass-if "basic case folding"
+ (and (eqv? (char-foldcase #\i) #\i)
+ (eqv? (char-foldcase #\337) #\337)
+ (eqv? (char-foldcase #\1643) #\1703)
+ (eqv? (char-foldcase #\1702) #\1703)))
+
+ (pass-if "Turkic characters"
+ (and (eqv? (char-foldcase #\460) #\460)
+ (eqv? (char-foldcase #\461) #\461))))
+
+(with-test-prefix "char-title-case?"
+ (pass-if "simple"
+ (and (not (char-title-case? #\I))
+ (char-title-case? #\705))))
+
+(with-test-prefix "string-foldcase"
+ (pass-if "basic case folding"
+ (and (equal? (string-foldcase "Hi") "hi")
+ (equal? (string-foldcase
+ (list->string '(#\1647 #\1621 #\1637 #\1643 #\1643)))
+ (list->string '(#\1707 #\1661 #\1677 #\1703 #\1703)))))
+
+ (pass-if "case folding expands string"
+ (or (equal? (string-foldcase (list->string '(#\S #\t #\r #\a #\337 #\e)))
+ "strasse")
+ (throw 'unresolved))))
hooks/post-receive
--
GNU Guile
| [Prev in Thread] |
Current Thread |
[Next in Thread] |
- [Guile-commits] GNU Guile branch, master, updated. release_1-9-10-168-gb766109,
Julian Graham <=