From 075599e5b066e3f6f1a96339d0947ede923b68ff Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Sun, 28 May 2023 14:20:34 +0200 Subject: [PATCH] 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. --- doc/ref/api-io.texi | 73 +++++++++++--- doc/ref/r6rs.texi | 8 +- module/ice-9/textual-ports.scm | 158 ++++++++++++++++++++++++++++++- module/rnrs/io/ports.scm | 20 ++-- test-suite/tests/r6rs-ports.test | 119 ++++++++++++++++++++++- 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)