[PATCH 3/4] Work towards a more complete implementation of `(rnrs io ports)'

[Andreas Rottmann]

* module/rnrs/io/ports.scm: (file-options, buffer-mode, eol-style)
  (error-handling-mode, make-transcoder, native-transcoder)
  (latin-1-codec, utf-8-codec, utf-16-codec)
  (call-with-bytevector-output-port, open-file-input-port)
  (open-file-output-port, make-custom-textual-output-port)
  (flush-output-port, put-char, put-datum, put-string, get-char)
  (get-datum, get-line, get-string-all, lookahead-char)
  (standard-input-port, standard-output-port, standard-error-port):
  Define all of these.

  (call-with-port): Don't use `dynamic-wind', as it is against its
  specification in R6RS 8.2.6.

* module/rnrs.scm: Export procedures added.

* module/rnrs/io/simple.scm (call-with-input-file)
  (call-with-output-file): Define these in terms of R6RS procedures to
  get correct exception behavior.
---
 module/rnrs.scm           |   20 ++++-
 module/rnrs/io/ports.scm  |  238 ++++++++++++++++++++++++++++++++++++++++++--
 module/rnrs/io/simple.scm |   23 +++--
 3 files changed, 260 insertions(+), 21 deletions(-)

diff --git a/module/rnrs.scm b/module/rnrs.scm
index 14218f0..e10967b 100644
--- a/module/rnrs.scm
+++ b/module/rnrs.scm
@@ -160,15 +160,31 @@
 
          ;; (rnrs io ports)
 
+         file-options buffer-mode buffer-mode?
+         eol-style native-eol-style error-handling-mode
+         make-transcoder transcoder-codec native-transcoder
+         latin-1-codec utf-8-codec utf-16-codec
+         
          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
+         port-has-port-position? port-has-set-port-position!?
+          close-port 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
           open-string-input-port open-string-output-port
-
+          call-with-bytevector-output-port
+          call-with-string-output-port
+          latin-1-codec utf-8-codec utf-16-codec
+          open-file-input-port open-file-output-port
+          make-custom-textual-output-port
+          call-with-string-output-port
+         flush-output-port put-string
+          get-char get-datum get-line get-string-all lookahead-char
+          put-char put-datum put-string
+          standard-input-port standard-output-port standard-error-port
+          
          ;; (rnrs io simple)
          
          call-with-input-file call-with-output-file current-input-port
diff --git a/module/rnrs/io/ports.scm b/module/rnrs/io/ports.scm
index 2246049..31c1e29 100644
--- a/module/rnrs/io/ports.scm
+++ b/module/rnrs/io/ports.scm
@@ -29,16 +29,23 @@
 (library (rnrs io ports (6))
   (export eof-object eof-object?
 
+          ;; auxiliary types
+          file-options buffer-mode buffer-mode?
+          eol-style native-eol-style error-handling-mode
+          make-transcoder transcoder-codec native-transcoder
+          latin-1-codec utf-8-codec utf-16-codec
+           
           ;; input & output ports
           port? input-port? output-port?
           port-transcoder binary-port? transcoded-port
           port-position set-port-position!
           port-has-port-position? port-has-set-port-position!?
-          call-with-port
+          call-with-port close-port
 
           ;; input ports
           open-bytevector-input-port
           open-string-input-port
+          open-file-input-port
           make-custom-binary-input-port
 
           ;; binary input
@@ -49,11 +56,52 @@
           ;; output ports
           open-bytevector-output-port
           open-string-output-port
+          open-file-output-port
           make-custom-binary-output-port
-
+          call-with-bytevector-output-port
+          call-with-string-output-port
+          make-custom-textual-output-port
+          flush-output-port
+           
           ;; binary output
-          put-u8 put-bytevector)
-  (import (guile))
+          put-u8 put-bytevector
+
+          ;; textual input
+          get-char get-datum get-line get-string-all lookahead-char
+           
+          ;; textual output
+          put-char put-datum put-string
+
+          ;; standard ports
+          standard-input-port standard-output-port standard-error-port
+
+          ;; condition types
+          &i/o i/o-error? make-i/o-error
+          &i/o-read i/o-read-error? make-i/o-read-error
+          &i/o-write i/o-write-error? make-i/o-write-error
+          &i/o-invalid-position i/o-invalid-position-error?
+          make-i/o-invalid-position-error
+          &i/o-filename i/o-filename-error? make-i/o-filename-error
+          i/o-error-filename
+          &i/o-file-protection i/o-file-protection-error?
+          make-i/o-file-protection-error
+          &i/o-file-is-read-only i/o-file-is-read-only-error?
+          make-i/o-file-is-read-only-error
+          &i/o-file-already-exists i/o-file-already-exists-error?
+          make-i/o-file-already-exists-error
+          &i/o-file-does-not-exist i/o-file-does-not-exist-error?
+          make-i/o-file-does-not-exist-error
+          &i/o-port i/o-port-error? make-i/o-port-error
+          i/o-error-port)
+  (import (only (rnrs base) assertion-violation)
+          (rnrs enums)
+          (rnrs records syntactic)
+          (rnrs exceptions)
+          (rnrs conditions)
+          (rnrs files) ;for the condition types
+          (srfi srfi-8)
+          (ice-9 rdelim)
+          (except (guile) raise))
 
 (load-extension (string-append "libguile-" (effective-version))
                 "scm_init_r6rs_ports")
@@ -61,6 +109,78 @@
 
 
 ;;;
+;;; Auxiliary types
+;;;
+
+(define-enumeration file-option
+  (no-create no-fail no-truncate)
+  file-options)
+
+(define-enumeration buffer-mode
+  (none line block)
+  buffer-modes)
+
+(define (buffer-mode? symbol)
+  (enum-set-member? symbol (enum-set-universe (buffer-modes))))
+
+(define-enumeration eol-style
+  (lf cr crlf nel crnel ls)
+  eol-styles)
+
+(define (native-eol-style)
+  (eol-style lf))
+
+(define-enumeration error-handling-mode
+  (ignore raise replace)
+  error-handling-modes)
+
+(define-record-type (transcoder %make-transcoder transcoder?)
+  (fields codec eol-style error-handling-mode))
+
+(define* (make-transcoder codec
+                          #:optional
+                          (eol-style (native-eol-style))
+                          (handling-mode (error-handling-mode replace)))
+  (%make-transcoder codec eol-style handling-mode))
+
+(define (native-transcoder)
+  (make-transcoder (or (fluid-ref %default-port-encoding)
+                       (latin-1-codec))))
+
+(define (latin-1-codec)
+  "ISO-8859-1")
+
+(define (utf-8-codec)
+  "UTF-8")
+
+(define (utf-16-codec)
+  "UTF-16")
+
+
+;;;
+;;; Internal helpers
+;;;
+
+(define (with-i/o-filename-conditions filename thunk)
+  (catch 'system-error
+         thunk
+         (lambda args
+           (let ((errno (system-error-errno args)))
+             (let ((construct-condition
+                    (cond ((= errno EACCES)
+                           make-i/o-file-protection-error)
+                          ((= errno EEXIST)
+                           make-i/o-file-already-exists-error)
+                          ((= errno ENOENT)
+                           make-i/o-file-does-not-exist-error)
+                          ((= errno EROFS)
+                           make-i/o-file-is-read-only-error)
+                          (else
+                           make-i/o-filename-error))))
+               (raise (construct-condition filename)))))))
+
+
+;;;
 ;;; Input and output ports.
 ;;;
 
@@ -100,19 +220,33 @@ read from/written to in @var{port}."
 (define (call-with-port port proc)
   "Call @var{proc}, passing it @var{port} and closing @var{port} upon exit of
 @var{proc}.  Return the return values of @var{proc}."
-  (dynamic-wind
-      (lambda ()
-        #t)
-      (lambda ()
-        (proc port))
-      (lambda ()
-        (close-port port))))
+  (call-with-values
+      (lambda () (proc port))
+    (lambda vals
+      (close-port port)
+      (apply values vals))))
+
+(define* (call-with-bytevector-output-port proc #:optional (transcoder #f))
+  (receive (port extract) (open-bytevector-output-port transcoder)
+    (call-with-port port proc)
+    (extract)))
 
 (define (open-string-input-port str)
   "Open an input port that will read from @var{str}."
   (with-fluids ((%default-port-encoding "UTF-8"))
     (open-input-string str)))
 
+(define* (open-file-input-port filename
+                               #:optional
+                               (file-options (file-options))
+                               (buffer-mode (buffer-mode block))
+                               maybe-transcoder)
+  (let ((port (with-i/o-filename-conditions filename
+                (lambda () (open filename O_RDONLY)))))
+    (cond (maybe-transcoder
+           (set-port-encoding! port (transcoder-codec maybe-transcoder))))
+    port))
+
 (define (open-string-output-port)
   "Return two values: an output port that will collect characters written to it
 as a string, and a thunk to retrieve the characters associated with that port."
@@ -121,6 +255,88 @@ as a string, and a thunk to retrieve the characters 
associated with that port."
     (values port
             (lambda () (get-output-string port)))))
 
+(define* (open-file-output-port filename
+                                #:optional
+                                (file-options (file-options))
+                                (buffer-mode (buffer-mode block))
+                                maybe-transcoder)
+  (let* ((flags (logior O_WRONLY
+                        (if (enum-set-member? 'no-create file-options)
+                            0
+                            O_CREAT)
+                        (if (enum-set-member? 'no-truncate file-options)
+                            0
+                            O_TRUNC)))
+         (port (with-i/o-filename-conditions filename
+                 (lambda () (open filename flags)))))
+    (cond (maybe-transcoder
+           (set-port-encoding! port (transcoder-codec maybe-transcoder))))
+    port))
+
+(define (call-with-string-output-port proc)
+  "Call @var{proc}, passing it a string output port. When @var{proc} returns,
+return the characters accumulated in that port."
+  (let ((port (open-output-string)))
+    (proc port)
+    (get-output-string port)))
+
+(define (make-custom-textual-output-port id
+                                         write!
+                                         get-position
+                                         set-position!
+                                         close)
+  (make-soft-port (vector (lambda (c) (write! (string c) 0 1))
+                          (lambda (s) (write! s 0 (string-length s)))
+                          #f ;flush
+                          #f ;read character
+                          close)
+                  "w"))
+
+(define (flush-output-port port)
+  (force-output port))
+
+(define (put-char port char)
+  (write-char char port))
+
+(define (put-datum port datum)
+  (write datum port))
+
+(define* (put-string port s #:optional start count)
+  (cond ((not (string? s))
+         (assertion-violation 'put-string "expected string" s))
+        ((and start count)
+         (display (substring/shared s start (+ start count)) port))
+        (start
+         (display (substring/shared s start (string-length s)) port))
+        (else
+         (display s port))))
+
+(define (get-char port)
+  (read-char port))
+
+(define (get-datum port)
+  (read port))
+
+(define (get-line port)
+  (read-line port 'trim))
+
+(define (get-string-all port)
+  (read-delimited "" port 'concat))
+
+(define (lookahead-char port)
+  (peek-char port))
+
+
+
+(define (standard-input-port)
+  (dup->inport 0))
+
+(define (standard-output-port)
+  (dup->outport 1))
+
+(define (standard-error-port)
+  (dup->outport 2))
+
 )
 
 ;;; ports.scm ends here
diff --git a/module/rnrs/io/simple.scm b/module/rnrs/io/simple.scm
index 17acdf1..59e614d 100644
--- a/module/rnrs/io/simple.scm
+++ b/module/rnrs/io/simple.scm
@@ -83,15 +83,16 @@
          i/o-port-error?
          i/o-error-port)         
 
-  (import (only (rnrs io ports) eof-object 
-                               eof-object? 
- 
-                                input-port? 
-                               output-port?)
+  (import (only (rnrs io ports)
+                call-with-port
+                open-file-input-port
+                open-file-output-port
+                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
@@ -115,5 +116,11 @@
          (rnrs base (6))
           (rnrs files (6)) ;for the condition types
           )
+
+  (define (call-with-input-file filename proc)
+    (call-with-port (open-file-input-port filename) proc))
+
+  (define (call-with-output-file filename proc)
+    (call-with-port (open-file-output-port filename) proc))
   
 )
-- 
1.7.2.3