mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-20 18:50:21 +02:00
Code Activity

Modernize soft ports

Browse source 
* doc/ref/api-io.texi (Soft Ports): Update docs.
* module/ice-9/boot-9.scm (make-soft-port): Don't eagerly load soft
ports.
* module/ice-9/soft-ports.scm (deprecated-make-soft-port): Rename from
make-soft-port.
(make-soft-port): New interface.
This commit is contained in:
Andy Wingo 2023-05-31 10:28:50 +02:00
parent 075599e5b0
commit f320ce8979
3 changed files with 178 additions and 34 deletions
Download patch file Download diff file Expand all files Collapse all files

10
module/ice-9/boot-9.scm
View file

@ -4700,12 +4700,14 @@ R7RS."
;;; make-soft-port in the default environment. FIXME: we should
;;; figure out how to deprecate this.
;;; make-soft-port in the default environment. FIXME: Deprecate, make
;;; callers import (ice-9 soft-port).
;;;
;; FIXME:
(module-use! the-scm-module (resolve-interface '(ice-9 soft-ports)))
(define (make-soft-port pv modes)
((module-ref (resolve-interface '(ice-9 soft-ports))
'deprecated-make-soft-port)
pv modes))

127
module/ice-9/soft-ports.scm
View file

@ -29,15 +29,16 @@
#:use-module (ice-9 match)
#:use-module (rnrs bytevectors)
#:use-module (rnrs bytevectors gnu)
#:export (make-soft-port))
#:export (deprecated-make-soft-port)
#:replace (make-soft-port))
(define (type-error proc expecting val)
(scm-error 'wrong-type-arg proc "Wrong type (expecting `~S'): ~S"
(list expecting val) (list val)))
(define (soft-port-read %get-char)
(define (deprecated-soft-port-read %get-char)
(unless (procedure? %get-char)
(type-error "soft-port-read" "procedure" %get-char))
(type-error "deprecated-soft-port-read" "procedure" %get-char))
(define encode-buf-size 10)
(define buffer (make-bytevector encode-buf-size))
(define buffer-pos 0)
@ -71,12 +72,12 @@
(set! buffer-pos (+ buffer-pos to-copy))
to-copy))))
(define (soft-port-write %put-string %flush)
(define (deprecated-soft-port-write %put-string %flush)
(unless (procedure? %put-string)
(type-error "soft-port-write" "procedure" %put-string))
(type-error "deprecated-soft-port-write" "procedure" %put-string))
(when %flush
(unless (procedure? %flush)
(type-error "soft-port-write" "procedure" %flush)))
(type-error "deprecated-soft-port-write" "procedure" %flush)))
(lambda (port bv start count)
(let* ((bytes (bytevector-slice bv start count))
(str (call-with-input-bytevector
@ -91,18 +92,19 @@
(if %flush (%flush))
count)))
(define (soft-port-close %close)
(define (deprecated-soft-port-close %close)
(unless (procedure? %close)
(type-error "soft-port-close" "procedure" %close))
(lambda (port) (%close)))
(define (soft-port-input-waiting? %input-ready)
(define (deprecated-soft-port-input-waiting? %input-ready)
(unless (procedure? %input-ready)
(type-error "soft-port-close" "procedure" %input-ready))
(type-error "deprecated-soft-port-close" "procedure" %input-ready))
(lambda (port) (< 0 (%input-ready))))
(define (%make-soft-port %put-char %put-string %flush %get-char %close
%input-ready reading? writing? buffering)
(define (%deprecated-make-soft-port %put-char %put-string %flush %get-char
%close %input-ready
reading? writing? buffering)
(cond
((not (or reading? writing?))
(%make-void-port ""))
@ -110,13 +112,12 @@
(let ((port
(make-custom-port
#:id "soft-port"
#:read (and reading? (soft-port-read %get-char))
#:write (and writing? (soft-port-write %put-string %flush))
#:read (and reading? (deprecated-soft-port-read %get-char))
#:write (and writing? (deprecated-soft-port-write %put-string %flush))
#:seek (lambda (port offset whence)
(error "soft ports are not seekable"))
#:close (if %close
(soft-port-close %close)
(lambda (port) (values)))
#:close (and %close
(deprecated-soft-port-close %close))
#:get-natural-buffer-sizes (lambda (port read-size write-size)
;; The in-practice expectation
;; is that soft ports have
@ -124,14 +125,14 @@
(values read-size 1))
#:random-access? (lambda (port) #f)
#:input-waiting? (if %input-ready
(soft-port-input-waiting? %input-ready)
(deprecated-soft-port-input-waiting? %input-ready)
(lambda (port) #t))
#:close-on-gc? #t)))
(when buffering
(setvbuf port buffering))
port))))
(define (make-soft-port vtable modes)
(define (deprecated-make-soft-port vtable modes)
"Return a port capable of receiving or delivering characters as
specified by the @var{modes} string (@pxref{File Ports, open-file}).
@var{pv} must be a vector of length 5 or 6. Its components are as
@ -191,9 +192,89 @@ For example:
(else #f))))
(match vtable
(#(%put-char %put-string %flush %get-char %close)
(%make-soft-port %put-char %put-string %flush %get-char %close #f
reading? writing? buffering))
(%deprecated-make-soft-port %put-char %put-string %flush %get-char %close
#f reading? writing? buffering))
(#(%put-char %put-string %flush %get-char %close %chars-waiting)
(%make-soft-port %put-char %put-string %flush %get-char %close
%chars-waiting
reading? writing? buffering))))
(%deprecated-make-soft-port %put-char %put-string %flush %get-char %close
%chars-waiting reading? writing? buffering))))
(define (soft-port-read read-string)
(unless (procedure? read-string)
(type-error "soft-port-read" "procedure" read-string))
(define-values (transcoder get-bytes) (open-bytevector-output-port))
(define buffer #f)
(define buffer-pos 0)
(lambda (port bv start count)
(unless (and buffer (< buffer-pos (bytevector-length buffer)))
(let* ((str (read-string)))
(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)
(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 (soft-port-write write-string)
(unless (procedure? write-string)
(type-error "soft-port-write" "procedure" write-string))
(lambda (port bv start count)
(write-string
(call-with-input-bytevector
(bytevector-slice bv start count)
(lambda (bport)
(set-port-encoding! bport (port-encoding port))
(set-port-conversion-strategy!
bport
(port-conversion-strategy port))
(get-string-all bport))))
count))
(define* (make-soft-port #:key
(id "soft-port")
(read-string #f)
(write-string #f)
(input-waiting? #f)
(close #f)
(close-on-gc? #f))
"Return a new port. If the @var{read-string} keyword argument is
present, the port will be an input port. If @var{write-string} is
present, the port will be an output port. If both are supplied, the
port will be open for input and output.
When the port's internal buffers are empty, @var{read-string} will be
called with no arguments, and should return a string. Returning \"\"
indicates end-of-stream. Similarly when a port flushes its write
buffer, the characters in that buffer will be passed to the
@var{write-string} procedure as its single argument. @var{write-string}
returns unspecified values.
If supplied, @var{input-waiting?} should return @code{#t} if the soft
port has input which would be returned directly by @var{read-string}.
If supplied, @var{close} will be called when the port is closed, with no
arguments. If @var{close-on-gc?} is @code{#t}, @var{close} will
additionally be called when the port becomes unreachable, after flushing
any pending write buffers."
(unless (or read-string write-string)
(error "Expected at least one of #:read-string, #:write-string"))
(when (and input-waiting? (not read-string))
(error "Supplying #:input-waiting? requires a #:read-string"))
(make-custom-port
#:id id
#:read (and read-string (soft-port-read read-string))
#:write (and write-string (soft-port-write write-string))
#:close (and close (lambda (port) (close)))
#:input-waiting? (and input-waiting?
(lambda (port) (input-waiting?)))
#:close-on-gc? close-on-gc?
#:encoding 'UTF-8))