mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-06-10 14:00:21 +02:00
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.
This commit is contained in:
Julian Graham
parent
805b4179bf
commit
0113507eee
6 changed files with 296 additions and 6 deletions
|
|
@ -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 \
|
||||
|
|
|
|||
|
|
@ -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))
|
||||
)
|
||||
|
|
|
|||
125
module/rnrs/6/files.scm
Normal file
125
module/rnrs/6/files.scm
Normal file
|
|
@ -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))
|
||||
)
|
||||
|
|
@ -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))
|
||||
)
|
||||
|
|
|
|||
|
|
@ -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 \
|
||||
|
|
|
|||
40
test-suite/tests/r6rs-files.test
Normal file
40
test-suite/tests/r6rs-files.test
Normal file
|
|
@ -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)))
|
||||
Loading…
Add table
Add a link
Reference in a new issue