summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorAndy Wingo <wingo@pobox.com>2023-05-28 14:20:34 +0200
committerAndy Wingo <wingo@pobox.com>2023-06-08 10:21:02 +0200
commit075599e5b066e3f6f1a96339d0947ede923b68ff (patch)
tree45b51cb1e18e3a148b1a0a293637cce6172df898
parent5bdc663af902c986c09adf25e7ac583b6f764bb2 (diff)
downloadguile-075599e5b066e3f6f1a96339d0947ede923b68ff.tar.gz
Implement R6RS custom textual ports
* module/ice-9/textual-ports.scm (custom-textual-port-read+flush-input): (custom-textual-port-write): (custom-textual-port-seek): (custom-textual-port-close): (custom-textual-port-random-access?): (make-custom-textual-input-port): (make-custom-textual-output-port): (make-custom-textual-input/output-port): New procedures. * doc/ref/api-io.texi (Ports): Update docs. * doc/ref/r6rs.texi (rnrs io ports): Mention custom textual port interfaces. * module/rnrs/io/ports.scm: Re-export custom textual port interfaces from (ice-9 textual-ports). * test-suite/tests/r6rs-ports.test: Add minimal tests for textual ports.
-rw-r--r--doc/ref/api-io.texi73
-rw-r--r--doc/ref/r6rs.texi8
-rw-r--r--module/ice-9/textual-ports.scm158
-rw-r--r--module/rnrs/io/ports.scm20
-rw-r--r--test-suite/tests/r6rs-ports.test119
5 files changed, 346 insertions, 32 deletions
diff --git a/doc/ref/api-io.texi b/doc/ref/api-io.texi
index 5d5dfa58b..70959037e 100644
--- a/doc/ref/api-io.texi
+++ b/doc/ref/api-io.texi
@@ -45,7 +45,7 @@ example, we might display a string to a file like this:
There are also string ports, for taking input from a string, or
collecting output to a string; bytevector ports, for doing the same but
-using a bytevector as a source or sink of data; and soft ports, for
+using a bytevector as a source or sink of data; and custom ports, for
arranging to call Scheme functions to provide input or handle output.
@xref{Port Types}.
@@ -1390,20 +1390,27 @@ away from its default. @xref{Encoding}.
@subsubsection Custom Ports
Custom ports allow the user to provide input and handle output via
-user-supplied procedures. Guile currently only provides custom binary
-ports, not textual ports; for custom textual ports, @xref{Soft Ports}.
-We should add the R6RS custom textual port interfaces though.
-Contributions are appreciated.
+user-supplied procedures. The most basic of these operates on the level
+of bytes, calling user-supplied functions to supply bytes for input and
+accept bytes for output. In Guile, textual ports are built on top of
+binary ports, encoding and decoding their codepoint sequences from the
+bytes; the higher-level textual layer for custom ports allows users to
+deal in characters instead of bytes.
+
+Before using these procedures, import the appropriate module:
+
+@example
+(use-modules (ice-9 binary-ports))
+(use-modules (ice-9 textual-ports))
+@end example
@cindex custom binary input ports
@deffn {Scheme Procedure} make-custom-binary-input-port id read! get-position set-position! close
-Return a new custom binary input port@footnote{This is similar in spirit
-to Guile's @dfn{soft ports} (@pxref{Soft Ports}).} named @var{id} (a
-string) whose input is drained by invoking @var{read!} and passing it a
-bytevector, an index where bytes should be written, and the number of
-bytes to read. The @code{read!} procedure must return an integer
-indicating the number of bytes read, or @code{0} to indicate the
-end-of-file.
+Return a new custom binary input port named @var{id} (a string) whose
+input is drained by invoking @var{read!} and passing it a bytevector, an
+index where bytes should be written, and the number of bytes to read.
+The @code{read!} procedure must return an integer indicating the number
+of bytes read, or @code{0} to indicate the end-of-file.
Optionally, if @var{get-position} is not @code{#f}, it must be a thunk
that will be called when @code{port-position} is invoked on the custom
@@ -1477,13 +1484,50 @@ random-access, causing the buffer to be flushed between reads and
writes.
@end deffn
+@cindex custom textual ports
+@cindex custom textual input ports
+@cindex custom textual output ports
+@cindex custom textual input/output ports
+@deffn {Scheme Procedure} make-custom-textual-input-port id read! get-position set-position! close
+@deffnx {Scheme Procedure} make-custom-textual-output-port id write! get-position set-position! close
+@deffnx {Scheme Procedure} make-custom-textual-input/output-port id read! write! get-position set-position! close
+Like their custom binary port counterparts, but for textual ports.
+Concretely this means that instead of being passed a bytevector, the
+@var{read} function is passed a mutable string to fill, and likewise for
+the buffer supplied to @var{write}. Port positions are still expressed
+in bytes, however.
+
+If string ports were not supplied with Guile, we could implement them
+With custom textual ports:
+@example
+(define (open-string-input-port source)
+ (define position 0)
+ (define length (string-length source))
+
+ (define (read! dst start count)
+ (let ((count (min count (- length position))))
+ (string-copy! dst start source position (+ position count))
+ (set! position (+ position count))
+ count))
+
+ (make-custom-textual-input-port "strport" read! #f #f #f))
+
+(read (open-string-input-port "hello"))
+@end example
+@end deffn
+
@node Soft Ports
@subsubsection Soft Ports
@cindex Soft port
@cindex Port, soft
-A @dfn{soft port} is a port based on a vector of procedures capable of
-accepting or delivering characters. It allows emulation of I/O ports.
+Soft ports are what Guile had before it had custom binary and textual
+ports. Probably you want to use one of those instead. @xref{Custom
+Ports}.
+
+But since you are still here, a @dfn{soft port} is a port based on a
+vector of procedures capable of accepting or delivering characters. It
+allows emulation of I/O ports.
@deffn {Scheme Procedure} make-soft-port pv modes
Return a port capable of receiving or delivering characters as
@@ -1532,7 +1576,6 @@ For example:
@end lisp
@end deffn
-
@node Void Ports
@subsubsection Void Ports
@cindex Void port
diff --git a/doc/ref/r6rs.texi b/doc/ref/r6rs.texi
index fe969f01f..9f81dafe5 100644
--- a/doc/ref/r6rs.texi
+++ b/doc/ref/r6rs.texi
@@ -1,7 +1,7 @@
@c -*-texinfo-*-
@c This is part of the GNU Guile Reference Manual.
@c Copyright (C) 2010, 2011, 2012, 2013,
-@c 2014, 2019, 2021 Free Software Foundation, Inc.
+@c 2014, 2019, 2021, 2023 Free Software Foundation, Inc.
@c See the file guile.texi for copying conditions.
@node R6RS Support
@@ -1782,6 +1782,12 @@ respectively. Whether the port supports the @code{port-position} and
@xref{Custom Ports}.
@end deffn
+@deffn {Scheme Procedure} make-custom-textual-input-port id read! get-position set-position! close
+@deffnx {Scheme Procedure} make-custom-textual-output-port id write! get-position set-position! close
+@deffnx {Scheme Procedure} make-custom-textual-input/output-port id read! write! get-position set-position! close
+@xref{Custom Ports}.
+@end deffn
+
@deffn {Scheme Procedure} get-u8 port
@deffnx {Scheme Procedure} lookahead-u8 port
@deffnx {Scheme Procedure} get-bytevector-n port count
diff --git a/module/ice-9/textual-ports.scm b/module/ice-9/textual-ports.scm
index ba30a8b1f..ac551be7a 100644
--- a/module/ice-9/textual-ports.scm
+++ b/module/ice-9/textual-ports.scm
@@ -1,6 +1,6 @@
;;;; textual-ports.scm --- Textual I/O on ports
-;;;; Copyright (C) 2016 Free Software Foundation, Inc.
+;;;; Copyright (C) 2016, 2023 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
@@ -23,7 +23,11 @@
(define-module (ice-9 textual-ports)
#:use-module (ice-9 ports internal)
#:use-module (ice-9 binary-ports)
+ #:use-module (ice-9 custom-ports)
+ #:use-module (ice-9 match)
#:use-module (ice-9 rdelim)
+ #:use-module (rnrs bytevectors)
+ #:use-module (rnrs bytevectors gnu)
#:re-export (get-string-n!
put-char
put-string)
@@ -33,7 +37,10 @@
lookahead-char
get-string-n
get-string-all
- get-line))
+ get-line
+ make-custom-textual-input-port
+ make-custom-textual-output-port
+ make-custom-textual-input/output-port))
(define (get-char port)
(read-char port))
@@ -68,3 +75,150 @@ the characters read."
(cond ((eof-object? rv) rv)
((= rv count) s)
(else (substring/shared s 0 rv)))))
+
+(define (type-error proc expecting val)
+ (scm-error 'wrong-type-arg proc "Wrong type (expecting `~S'): ~S"
+ (list expecting val) (list val)))
+
+(define (custom-textual-port-read+flush-input read)
+ (unless (procedure? read)
+ (type-error "custom-textual-port-read" "procedure" read))
+ (define-values (transcoder get-bytes) (open-bytevector-output-port))
+ (define buffer #f)
+ (define buffer-pos 0)
+ (define (%read port bv start count)
+ (unless (and buffer (< buffer-pos (bytevector-length buffer)))
+ (let* ((str (make-string (max (port-read-buffering port) 1)))
+ (chars (read str 0 (string-length str))))
+ (unless (and (exact-integer? chars) (<= 0 chars (string-length str)))
+ (scm-error 'out-of-range "custom-textual-port-read"
+ "Value out of range: ~S" (list chars) (list chars)))
+ (unless (eq? (port-encoding port) (port-encoding transcoder))
+ (set-port-encoding! transcoder (port-encoding port)))
+ (unless (eq? (port-conversion-strategy port)
+ (port-conversion-strategy transcoder))
+ (set-port-conversion-strategy! transcoder
+ (port-conversion-strategy port)))
+ (put-string transcoder str 0 chars)
+ (set! buffer (get-bytes))
+ (set! buffer-pos 0)))
+
+ (let ((to-copy (min count (- (bytevector-length buffer) buffer-pos))))
+ (bytevector-copy! buffer buffer-pos bv start to-copy)
+ (if (= (bytevector-length buffer) (+ buffer-pos to-copy))
+ (set! buffer #f)
+ (set! buffer-pos (+ buffer-pos to-copy)))
+ to-copy))
+ (define (%flush-input)
+ (get-bytes)
+ (set! buffer #f))
+ (values %read %flush-input))
+
+(define (custom-textual-port-write write)
+ (unless (procedure? write)
+ (type-error "custom-textual-port-write" "procedure" write))
+ (lambda (port bv start count)
+ (let* ((bytes (bytevector-slice bv start count))
+ (str (call-with-input-bytevector
+ bytes
+ (lambda (bport)
+ (set-port-encoding! bport (port-encoding port))
+ (set-port-conversion-strategy!
+ bport
+ (port-conversion-strategy port))
+ (get-string-all bport))))
+ (len (string-length str)))
+ (let lp ((written 0))
+ (cond
+ ((= written len) count)
+ (else
+ (let ((to-write (- len written)))
+ (let ((res (write str written to-write)))
+ (unless (and (exact-integer? res) (<= 0 res to-write))
+ (scm-error 'out-of-range "custom-textual-port-write"
+ "Value out of range: ~S" (list res) (list res)))
+ (lp (+ written res))))))))))
+
+(define (custom-textual-port-seek get-position set-position! flush-input)
+ (when get-position
+ (unless (procedure? get-position)
+ (type-error "custom-textual-port-seek" "procedure" get-position)))
+ (when set-position!
+ (unless (procedure? set-position!)
+ (type-error "custom-textual-port-seek" "procedure" set-position!)))
+
+ (define (seek port offset whence)
+ (cond
+ ((eqv? whence SEEK_CUR)
+ (unless get-position
+ (type-error "custom-textual-port-seek"
+ "R6RS custom textual port with `port-position` support"
+ port))
+ (if (zero? offset)
+ (get-position)
+ (seek port (+ (get-position) offset) SEEK_SET)))
+ ((eqv? whence SEEK_SET)
+ (unless set-position!
+ (type-error "custom-textual-port-seek"
+ "Seekable R6RS custom textual port"
+ port))
+ (flush-input)
+ (set-position! offset)
+ ;; Assume setting the position succeeds.
+ offset)
+ ((eqv? whence SEEK_END)
+ (error "R6RS custom textual ports do not support `SEEK_END'"))))
+ seek)
+
+(define (custom-textual-port-close close)
+ (match close
+ (#f (lambda (port) #t))
+ ((? procedure?) (lambda (port) (close)))
+ (_ (type-error "custom-textual-port-close" "procedure" close))))
+
+(define (custom-textual-port-random-access? set-position!)
+ (if set-position!
+ (lambda (port) #t)
+ (lambda (port) #f)))
+
+(define (make-custom-textual-input-port id read get-position set-position!
+ close)
+ (unless (string? id)
+ (type-error "make-custom-textual-input-port" "string" id))
+ (define-values (%read %flush-input)
+ (custom-textual-port-read+flush-input read))
+ (make-custom-port #:id id
+ #:read %read
+ #:seek (custom-textual-port-seek get-position set-position!
+ %flush-input)
+ #:close (custom-textual-port-close close)
+ #:random-access?
+ (custom-textual-port-random-access? set-position!)))
+
+(define (make-custom-textual-output-port id write get-position set-position!
+ close)
+ (unless (string? id)
+ (type-error "make-custom-textual-output-port" "string" id))
+ (define (flush-input) #t)
+ (make-custom-port #:id id
+ #:write (custom-textual-port-write write)
+ #:seek (custom-textual-port-seek get-position set-position!
+ flush-input)
+ #:close (custom-textual-port-close close)
+ #:random-access?
+ (custom-textual-port-random-access? set-position!)))
+
+(define (make-custom-textual-input/output-port id read write get-position
+ set-position! close)
+ (unless (string? id)
+ (type-error "make-custom-textual-input/output-port" "string" id))
+ (define-values (%read %flush-input)
+ (custom-textual-port-read+flush-input read))
+ (make-custom-port #:id id
+ #:read %read
+ #:write (custom-textual-port-write write)
+ #:seek (custom-textual-port-seek get-position set-position!
+ %flush-input)
+ #:close (custom-textual-port-close close)
+ #:random-access?
+ (custom-textual-port-random-access? set-position!)))
diff --git a/module/rnrs/io/ports.scm b/module/rnrs/io/ports.scm
index 71d1b394d..d7cb89e36 100644
--- a/module/rnrs/io/ports.scm
+++ b/module/rnrs/io/ports.scm
@@ -1,6 +1,6 @@
;;;; ports.scm --- R6RS port API -*- coding: utf-8 -*-
-;;;; Copyright (C) 2009-2011, 2013, 2019 Free Software Foundation, Inc.
+;;;; Copyright (C) 2009-2011, 2013, 2019, 2023 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
@@ -52,6 +52,7 @@
open-string-input-port
open-file-input-port
make-custom-binary-input-port
+ make-custom-textual-input-port
;; binary input
get-u8 lookahead-u8
@@ -72,6 +73,7 @@
;; input/output ports
open-file-input/output-port
make-custom-binary-input/output-port
+ make-custom-textual-input/output-port
;; binary output
put-u8 put-bytevector
@@ -110,6 +112,10 @@
&i/o-encoding i/o-encoding-error?
make-i/o-encoding-error i/o-encoding-error-char)
(import (ice-9 binary-ports)
+ (only (ice-9 textual-ports)
+ make-custom-textual-input-port
+ make-custom-textual-output-port
+ make-custom-textual-input/output-port)
(only (rnrs base) assertion-violation)
(only (ice-9 ports internal)
port-write-buffer port-buffer-bytevector port-line-buffered?)
@@ -410,18 +416,6 @@ return the characters accumulated in that port."
(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 (output-port-buffer-mode port)
"Return @code{none} if @var{port} is unbuffered, @code{line} if it is
line buffered, or @code{block} otherwise."
diff --git a/test-suite/tests/r6rs-ports.test b/test-suite/tests/r6rs-ports.test
index c42783465..46b2a4307 100644
--- a/test-suite/tests/r6rs-ports.test
+++ b/test-suite/tests/r6rs-ports.test
@@ -1,6 +1,6 @@
;;;; r6rs-ports.test --- R6RS I/O port tests. -*- coding: utf-8; -*-
;;;;
-;;;; Copyright (C) 2009-2012, 2013-2015, 2018 Free Software Foundation, Inc.
+;;;; Copyright (C) 2009-2012,2013-2015,2018-2021,2023 Free Software Foundation, Inc.
;;;; Ludovic Courtès
;;;;
;;;; This library is free software; you can redistribute it and/or
@@ -1650,6 +1650,123 @@ not `set-port-position!'"
(error-handling-mode replace)))
(make-transcoder "ascii"))))))
+(with-test-prefix "custom textual ports"
+ (let ((log '()))
+ (define (log! tag args)
+ (set! log (acons tag args log)))
+ (define (log-calls tag) (lambda args (log! tag args)))
+ (define (call-with-logged-calls thunk)
+ (log! 'result (list (thunk)))
+ (let ((result (reverse log)))
+ (set! log '())
+ result))
+
+ (define-syntax-rule (pass-if-log-matches id expected expr)
+ (pass-if id
+ (match (call-with-logged-calls (lambda () expr))
+ (expected #t)
+ (unexpected (error "unexpected output" 'expected unexpected)))))
+
+ (define (test-input-port id make-port)
+ (define (call-with-input-string str proc)
+ (define pos 0)
+ (proc
+ (make-port id
+ (lambda (buf start count)
+ (let ((count (min count (- (string-length str) pos))))
+ (log! 'read (list count))
+ (string-copy! buf start str pos (+ pos count))
+ (set! pos (+ pos count))
+ count))
+ (log-calls 'get-position)
+ (log-calls 'set-position)
+ (log-calls 'close))))
+
+ (with-test-prefix id
+ (pass-if-log-matches
+ "make"
+ (('result #t))
+ (input-port? (make-port
+ "hey"
+ (log-calls 'read)
+ (log-calls 'get-position)
+ (log-calls 'set-position)
+ (log-calls 'close))))
+
+ (pass-if-log-matches
+ "inputting \"foo\""
+ (('read 3)
+ ('read 0)
+ ('result "foo"))
+ (call-with-input-string "foo" get-string-all))
+
+ (let ((big-str (make-string 2000 #\a)))
+ (pass-if-log-matches
+ "inputting 2000 a's"
+ (('read 1024)
+ ('read 976)
+ ('read 0)
+ ('result (? (lambda (x) (equal? x big-str)))))
+ (call-with-input-string big-str get-string-all)))))
+
+ (define (test-output-port id make-port)
+ (define (call-with-output-string proc)
+ (define out '())
+ (define port
+ (make-port id
+ (lambda (buf start count)
+ (log! 'write (list count))
+ (set! out (cons (substring buf start count) out))
+ count)
+ (log-calls 'get-position)
+ (log-calls 'set-position)
+ (log-calls 'close)))
+ (proc port)
+ (close-port port)
+ (string-concatenate-reverse out))
+
+ (with-test-prefix id
+ (pass-if-log-matches
+ "make"
+ (('result #t))
+ (output-port? (make-port
+ "hey"
+ (log-calls 'write)
+ (log-calls 'get-position)
+ (log-calls 'set-position)
+ (log-calls 'close)))))
+
+ (with-test-prefix id
+ (pass-if-log-matches
+ "output \"foo\""
+ (('write 3)
+ ('close)
+ ('result "foo"))
+ (call-with-output-string
+ (lambda (port) (put-string port "foo"))))
+
+ (let ((big-str (make-string 2000 #\a)))
+ (pass-if-log-matches
+ "writing 2000 a's"
+ (('write 1024)
+ ('write 976)
+ ('close)
+ ('result (? (lambda (x) (equal? x big-str)))))
+ (call-with-output-string
+ (lambda (port) (put-string port big-str)))))))
+
+ (test-input-port "input port" make-custom-textual-input-port)
+ (test-input-port "input+ port"
+ (lambda (id read get-pos set-pos close)
+ (make-custom-textual-input/output-port
+ id read (log-calls 'write) get-pos set-pos close)))
+
+ (test-output-port "output port" make-custom-textual-output-port)
+ (test-output-port "output+ port"
+ (lambda (id write get-pos set-pos close)
+ (make-custom-textual-input/output-port
+ id (log-calls 'read) write get-pos set-pos close)))))
+
;;; Local Variables:
;;; mode: scheme
;;; eval: (put 'guard 'scheme-indent-function 1)