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.

6 files changed, 296 insertions, 6 deletions

diff --git a/module/Makefile.am b/module/Makefile.am
index 5d220bd10..957ac60bd 100644
--- a/module/Makefile.am
+++ b/module/Makefile.am
@@ -260,6 +260,7 @@ RNRS_SOURCES =					\
   rnrs/6/conditions.scm				\
   rnrs/6/control.scm				\
   rnrs/6/exceptions.scm				\
+  rnrs/6/files.scm				\
   rnrs/6/hashtables.scm				\
   rnrs/6/lists.scm				\
   rnrs/6/programs.scm				\
diff --git a/module/rnrs/6/conditions.scm b/module/rnrs/6/conditions.scm
index 5916f51e7..b6630c88f 100644
--- a/module/rnrs/6/conditions.scm
+++ b/module/rnrs/6/conditions.scm
@@ -104,7 +104,7 @@
 	 (let*
 	   ((fields (let* ((field-spec-syntax #'((field accessor) ...))
 			  (field-specs (syntax->datum field-spec-syntax)))
-		     (list->vector (map (lambda (field-spec) 
+		     (list->vector (map (lambda (field-spec)
 					  (cons 'immutable field-spec))
 					field-specs))))
 	    (fields-syntax (datum->syntax stx fields)))
@@ -123,8 +123,8 @@
 		   (if (>= counter (vector-length fields))
 		       accessors
 		       (f (cons #`(define #,(datum->syntax 
-					     stx (cadr (vector-ref fields 
-								   counter)))
+					     stx (caddr (vector-ref fields 
+								    counter)))
 				    (record-accessor condition-type #,counter))
 				accessors)
 			  (+ counter 1))))))))))
@@ -212,4 +212,32 @@
     (subform syntax-violation-subform))
 
   (define-condition-type &undefined &violation
-    make-undefined-violation 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/files.scm b/module/rnrs/6/files.scm
new file mode 100644
index 000000000..da806d4bb
--- /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/io/6/simple.scm b/module/rnrs/io/6/simple.scm
index cf6c1307d..fab7da654 100644
--- a/module/rnrs/io/6/simple.scm
+++ b/module/rnrs/io/6/simple.scm
@@ -46,7 +46,43 @@
 	  write-char
 	  newline
 	  display
-	  write)
+	  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? 
  
@@ -74,4 +110,63 @@
 			write-char
 			newline
 			display
-			write)))
+			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/test-suite/Makefile.am b/test-suite/Makefile.am
index 2eb1232dd..3a7e67650 100644
--- a/test-suite/Makefile.am
+++ b/test-suite/Makefile.am
@@ -78,6 +78,7 @@ SCM_TESTS = tests/00-initial-env.test		\
 	    tests/r5rs_pitfall.test		\
 	    tests/r6rs-arithmetic-bitwise.test	\
 	    tests/r6rs-control.test		\
+	    tests/r6rs-files.test		\
 	    tests/r6rs-hashtables.test		\
 	    tests/r6rs-ports.test		\
 	    tests/r6rs-records-inspection.test	\
diff --git a/test-suite/tests/r6rs-files.test b/test-suite/tests/r6rs-files.test
new file mode 100644
index 000000000..df5dd22e2
--- /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)))