mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-04-29 19:30:36 +02:00
Code Activity

Implement R6RS custom textual ports

Browse source 
* 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.
This commit is contained in:
Andy Wingo 2023-05-28 14:20:34 +02:00
parent 5bdc663af9
commit 075599e5b0
5 changed files with 346 additions and 32 deletions
Download patch file Download diff file Expand all files Collapse all files

73
doc/ref/api-io.texi
View file

@ -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

8
doc/ref/r6rs.texi
View file

@ -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

158
module/ice-9/textual-ports.scm
View file

@ -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!)))

20
module/rnrs/io/ports.scm
View file

@ -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."

119
test-suite/tests/r6rs-ports.test
View file

@ -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)