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=4123ca6b01730f59d3cbb6153c92ea926edc34a3 The branch, wip-r6rs-libraries has been updated via 4123ca6b01730f59d3cbb6153c92ea926edc34a3 (commit) via 6c7209e9e5ec1531065fa93398890215d1e8a0d2 (commit) via dd28a40f4f6ad153b75bb819368499fe74533047 (commit) from dbf667f9777c1ac37e904e8192895f1a2b51dbfc (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 4123ca6b01730f59d3cbb6153c92ea926edc34a3 Author: Julian Graham <julian.gra...@aya.yale.edu> 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 6c7209e9e5ec1531065fa93398890215d1e8a0d2 Author: Julian Graham <julian.gra...@aya.yale.edu> 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 dd28a40f4f6ad153b75bb819368499fe74533047 Author: Julian Graham <julian.gra...@aya.yale.edu> 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. ----------------------------------------------------------------------- Summary of changes: module/Makefile.am | 3 + module/rnrs/6/conditions.scm | 36 +++++- module/rnrs/6/files.scm | 125 ++++++++++++++++++++ module/{srfi/srfi-8.scm => rnrs/6/programs.scm} | 21 +--- module/rnrs/6/{control.scm => sorting.scm} | 20 +-- module/rnrs/io/6/simple.scm | 99 +++++++++++++++- test-suite/Makefile.am | 1 + .../tests/{r6rs-control.test => r6rs-files.test} | 32 +++-- 8 files changed, 290 insertions(+), 47 deletions(-) create mode 100644 module/rnrs/6/files.scm copy module/{srfi/srfi-8.scm => rnrs/6/programs.scm} (67%) copy module/rnrs/6/{control.scm => sorting.scm} (65%) copy test-suite/tests/{r6rs-control.test => r6rs-files.test} (54%) diff --git a/module/Makefile.am b/module/Makefile.am index 2ef342d..52ca7e8 100644 --- a/module/Makefile.am +++ b/module/Makefile.am @@ -260,8 +260,11 @@ 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 \ + rnrs/6/sorting.scm \ rnrs/6/syntax-case.scm \ rnrs/6/unicode.scm \ rnrs/arithmetic/6/bitwise.scm \ diff --git a/module/rnrs/6/conditions.scm b/module/rnrs/6/conditions.scm index 5916f51..b6630c8 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 0000000..da806d4 --- /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/srfi/srfi-8.scm b/module/rnrs/6/programs.scm similarity index 67% copy from module/srfi/srfi-8.scm copy to module/rnrs/6/programs.scm index ced1238..4daa781 100644 --- a/module/srfi/srfi-8.scm +++ b/module/rnrs/6/programs.scm @@ -1,6 +1,6 @@ -;;; srfi-8.scm --- receive +;;; programs.scm --- The R6RS process management library -;; Copyright (C) 2000, 2001, 2002, 2006 Free Software Foundation, Inc. +;; 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 @@ -15,17 +15,8 @@ ;; 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 + -;;; Commentary: - -;; This module is fully documented in the Guile Reference Manual. - -;;; Code: - -(define-module (srfi srfi-8) - :use-module (ice-9 receive) - :re-export-syntax (receive)) - -(cond-expand-provide (current-module) '(srfi-8)) - -;;; srfi-8.scm ends here +(library (rnrs programs (6)) + (export command-line exit) + (import (only (guile) command-line exit))) diff --git a/module/rnrs/6/control.scm b/module/rnrs/6/sorting.scm similarity index 65% copy from module/rnrs/6/control.scm copy to module/rnrs/6/sorting.scm index 69351c6..08f44b8 100644 --- a/module/rnrs/6/control.scm +++ b/module/rnrs/6/sorting.scm @@ -1,4 +1,4 @@ -;;; control.scm --- The R6RS control structures library +;;; sorting.scm --- The R6RS sorting library ;; Copyright (C) 2010 Free Software Foundation, Inc. ;; @@ -17,17 +17,11 @@ ;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA -(library (rnrs control (6)) - (export when unless do case-lambda) +(library (rnrs sorting (6)) + (export list-sort vector-sort vector-sort!) (import (rnrs base (6)) - (only (guile) do case-lambda)) + (only (guile) *unspecified* stable-sort sort!)) - (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 ...)))))) + (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/io/6/simple.scm b/module/rnrs/io/6/simple.scm index cf6c130..fab7da6 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 0ea70b3..3e10dc9 100644 --- a/test-suite/Makefile.am +++ b/test-suite/Makefile.am @@ -72,6 +72,7 @@ SCM_TESTS = tests/alist.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-control.test b/test-suite/tests/r6rs-files.test similarity index 54% copy from test-suite/tests/r6rs-control.test copy to test-suite/tests/r6rs-files.test index 0f099a0..df5dd22 100644 --- a/test-suite/tests/r6rs-control.test +++ b/test-suite/tests/r6rs-files.test @@ -1,4 +1,4 @@ -;;; r6rs-control.test --- Test suite for R6RS (rnrs control) +;;; r6rs-files.test --- Test suite for R6RS (rnrs unicode) ;; Copyright (C) 2010 Free Software Foundation, Inc. ;; @@ -17,18 +17,24 @@ ;; 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)) +(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 "when" - (pass-if "when true" - (eq? (when (> 3 2) 'greater) 'greater)) - (pass-if "when false" - (unspecified? (when (< 3 2) 'greater)))) +(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)))) -(with-test-prefix "unless" - (pass-if "unless true" - (unspecified? (unless (> 3 2) 'less))) - (pass-if "unless false" - (eq? (unless (< 3 2) 'less) 'less))) + (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))) hooks/post-receive -- GNU Guile
