573 lines
18 KiB
Scheme
573 lines
18 KiB
Scheme
;;; A Unix file port system to completely replace S48 file ports.
|
|
;;; We use S48 extensible ports.
|
|
;;; Copyright (c) 1993 by Olin Shivers.
|
|
|
|
;(define-record fdport-data
|
|
; fd ; Unix file descriptor - integer.
|
|
; (closed? #f) ; Is port closed.
|
|
; (peek-char #f)
|
|
; revealed ; REVEALED & OLD-REVEALED are for keeping
|
|
; (old-revealed 0)) ; track of whether the FD value has escaped.
|
|
|
|
(define-record fdport-data
|
|
channel
|
|
revealed)
|
|
|
|
;;; We could flush the PEEK-CHAR field and use stdio ungetc(), but it
|
|
;;; is only guaranteed for buffered streams. Too bad...
|
|
|
|
;Arbitrary, for now.
|
|
(define buffer-size 255)
|
|
|
|
;(define (alloc-input-fdport fd revealed)
|
|
; (make-port input-fdport-handler open-input-port-status (make-lock) #f
|
|
; (make-fdport-data fd revealed)
|
|
; (make-code-vector buffer-size (char->ascii #\!)) 0
|
|
; 0 #f))
|
|
|
|
(define (alloc-input-fdport fd revealed)
|
|
(make-input-port input-fdport-handler
|
|
(make-fdport-data (make-input-fdchannel fd) revealed)
|
|
(make-code-vector buffer-size 0) 0 0))
|
|
|
|
;Have to use make-port, make-output-port wants to use code-vectors
|
|
;(define (alloc-output-fdport fd revealed)
|
|
; (make-port output-fdport-handler open-output-port-status (make-lock) #f
|
|
; (make-fdport-data fd revealed) (make-string buffer-size) 0
|
|
; buffer-size #f))
|
|
|
|
(define (alloc-output-fdport fd revealed)
|
|
(make-output-port output-fdport-handler
|
|
(make-fdport-data (make-output-fdchannel fd) revealed)
|
|
(make-code-vector buffer-size 0) 0 buffer-size))
|
|
|
|
;(define (make-input-fdport fd revealed)
|
|
; (let ((p (alloc-input-fdport fd revealed)))
|
|
; (%install-port fd p revealed)
|
|
; (add-finalizer! p (lambda (x) (close-fdport* (fdport-data x))))
|
|
; p))
|
|
|
|
(define make-input-fdport alloc-input-fdport)
|
|
|
|
;(define (make-output-fdport fd revealed)
|
|
; (let ((p (alloc-output-fdport fd revealed)))
|
|
; (%install-port fd p revealed)
|
|
; (periodically-force-output! p)
|
|
; (add-finalizer! p (lambda (x) (close-fdport* (fdport-data x))))
|
|
; p))
|
|
|
|
(define (make-output-fdport fd revealed)
|
|
(let ((p (alloc-output-fdport fd revealed)))
|
|
(periodically-force-output! p)
|
|
p))
|
|
|
|
;(define (fdport? x)
|
|
; (cond ((or (and (extensible-input-port? x)
|
|
; (extensible-input-port-local-data x))
|
|
; (and (extensible-output-port? x)
|
|
; (extensible-output-port-local-data x)))
|
|
; => (lambda (d) (fdport-data? d)))
|
|
; (else #f)))
|
|
|
|
(define (fdport? x)
|
|
(cond ((or (and (input-port? x) (port-data x))
|
|
(and (output-port? x) (port-data x)))
|
|
=> (lambda (d) (fdport-data? d)))
|
|
(else #f)))
|
|
|
|
|
|
;;; Basic methods
|
|
;;; -------------
|
|
|
|
(define fdport-null-method (lambda (x) x #f))
|
|
|
|
;;; CLOSE-FDPORT*, FLUSH-FDPORT* defined in syscalls.scm.
|
|
;;; (So you must load that file before loading this file.)
|
|
|
|
;(define (fdport*-read-char data)
|
|
; (check-arg open-fdport-data? data fdport*-read-char)
|
|
; (cond ((fdport-data:peek-char data) =>
|
|
; (lambda (char)
|
|
; (set-fdport-data:peek-char data #f)
|
|
; char))
|
|
; (else
|
|
; (or (%fdport*-read-char data) eof-object))))
|
|
|
|
(define (fdport*-read-char data)
|
|
(check-arg open-fdport-data? data fdport*-read-char)
|
|
(or (%fdport*-read-char data) (eof-object)))
|
|
|
|
;(define (fdport*-peek-char data)
|
|
; (check-arg open-fdport-data? data fdport*-peek-char)
|
|
; (or (fdport-data:peek-char data)
|
|
; (cond ((%fdport*-read-char data) =>
|
|
; (lambda (char)
|
|
; (set-fdport-data:peek-char data char)
|
|
; char))
|
|
; (else eof-object))))
|
|
|
|
;(define (fdport*-char-ready? data)
|
|
; (check-arg open-fdport-data? data fdport*-char-ready?)
|
|
; (or (fdport-data:peek-char data)
|
|
; (%fdport*-char-ready? data)))
|
|
|
|
(define (fdport*-char-ready? data)
|
|
(check-arg open-fdport-data? data fdport*-char-ready?)
|
|
(%fdport*-char-ready? data))
|
|
|
|
(define (fdport*-write-char data char)
|
|
(check-arg open-fdport-data? data fdport*-write-char)
|
|
(if (not (fdport-data:closed? data))
|
|
(%fdport*-write-char data char))
|
|
#f) ; Bogus fix -- otherwise %fdport*-...'s 0-value return blows up S48.
|
|
|
|
(define (fdport*-write-string data string)
|
|
(check-arg open-fdport-data? data fdport*-write-string)
|
|
(generic-write-string string 0 (string-length string) ; from rw.scm
|
|
write-fdport*-substring/errno data)
|
|
#f)
|
|
|
|
;(define input-fdport-methods
|
|
; (make-input-port-methods close-fdport*
|
|
; fdport*-read-char
|
|
; fdport*-peek-char
|
|
; fdport*-char-ready?
|
|
; fdport-null-method ; current-column
|
|
; fdport-null-method)) ; current-row
|
|
|
|
(define input-fdport-reader
|
|
(lambda (fdport buffer start-index needed-bytes)
|
|
(let* ((buffer-length (if (string? buffer) string-length
|
|
code-vector-length))
|
|
(buffer-set! (if (string? buffer) string-set! code-vector-set!))
|
|
(max-size (buffer-length buffer)))
|
|
(if (number? needed-bytes)
|
|
(let ((max-read (modulo (+ start-index needed-bytes) max-size)))
|
|
(let fill-buffer ((current-index start-index))
|
|
(if (eq? current-index max-read)
|
|
needed-bytes
|
|
(if (fdport*-char-ready? fdport)
|
|
(let ((found-char (fdport*-read-char fdport)))
|
|
(if (eof-object? found-char)
|
|
found-char
|
|
(begin
|
|
(buffer-set! buffer current-index
|
|
(char->ascii found-char))
|
|
(fill-buffer (modulo (+ current-index 1)
|
|
max-size)))))
|
|
(begin
|
|
(relinquish-timeslice)
|
|
(fill-buffer current-index))))))
|
|
(let ((immediate-get
|
|
(lambda ()
|
|
(let fill-buffer ((current-index start-index))
|
|
(if (and (< current-index max-size)
|
|
(fdport*-char-ready? fdport))
|
|
(begin
|
|
(let ((found-char (fdport*-read-char fdport)))
|
|
(if (not (eof-object? found-char))
|
|
(begin
|
|
(buffer-set! buffer current-index
|
|
(char->ascii found-char))
|
|
(fill-buffer (+ current-index 1)))
|
|
found-char)))
|
|
(- current-index start-index))))))
|
|
(cond
|
|
((eq? needed-bytes 'immediate) (immediate-get))
|
|
((eq? needed-bytes 'any)
|
|
(let fill-buffer ()
|
|
(if (fdport*-char-ready? fdport)
|
|
(immediate-get)
|
|
(begin
|
|
(relinquish-timeslice)
|
|
(fill-buffer)))))))))))
|
|
|
|
(define null-func (lambda args #t))
|
|
|
|
(define input-fdport-handler
|
|
(make-port-handler
|
|
(lambda (fdport)
|
|
(list 'fdport (fdport-data:fd fdport)))
|
|
close-fdport*
|
|
input-fdport-reader))
|
|
|
|
;(define output-fdport-methods
|
|
; (make-output-port-methods close-fdport*
|
|
; fdport*-write-char
|
|
; fdport*-write-string
|
|
; (lambda (d) ; force output
|
|
; (flush-fdport* d)
|
|
; #f) ; bogus workaround.
|
|
; fdport-null-method ; fresh-line
|
|
; fdport-null-method ; current-column
|
|
; fdport-null-method)) ; current-row
|
|
|
|
(define output-fdport-writer
|
|
(lambda (fdport buffer start-index needed-bytes)
|
|
(let* ((buffer-length (string-length buffer))
|
|
(to-print
|
|
(if (> (+ start-index needed-bytes) buffer-length)
|
|
(string-append (substring buffer start-index buffer-length)
|
|
(substring buffer 0
|
|
(- (+ start-index needed-bytes)
|
|
buffer-length)))
|
|
(substring buffer start-index (+ start-index needed-bytes)))))
|
|
(fdport*-write-string fdport to-print))))
|
|
|
|
(define output-fdport-handler
|
|
(make-port-handler
|
|
(lambda (fdport)
|
|
(list 'fdport (fdport-data:fd fdport)))
|
|
close-fdport*
|
|
output-fdport-writer))
|
|
|
|
(define unbuffered-output-fdport-handler
|
|
(make-port-handler
|
|
(lambda (fdport)
|
|
(list 'fdport (fdport-data:fd fdport)))
|
|
close-fdport*
|
|
fdport*-write-char))
|
|
|
|
;(define (fdport-data port)
|
|
; (let ((d ((cond ((extensible-input-port? port)
|
|
; extensible-input-port-local-data)
|
|
; ((extensible-output-port? port)
|
|
; extensible-output-port-local-data)
|
|
; (else (error "Illegal value" port)))
|
|
; port)))
|
|
; (if (and d (fdport-data? d)) d
|
|
; (error "fport closed" port))))
|
|
|
|
(define fdport-data port-data)
|
|
; That was easy.
|
|
|
|
(define (%fdport-seek/errno port offset whence)
|
|
(%fdport*-seek/errno (fdport-data port) offset whence))
|
|
|
|
(define (%fdport-tell/errno port)
|
|
(%fdport*-tell/errno (fdport-data port)))
|
|
|
|
(define (%fdport-set-buffering/errno port policy size)
|
|
(%fdport*-set-buffering/errno (fdport-data port) policy size))
|
|
|
|
(define (set-port-buffering port policy . maybe-size)
|
|
(let* ((size (if (pair? maybe-size)
|
|
(if (pair? (cdr maybe-size))
|
|
(error "Too many arguments." set-port-buffering)
|
|
(check-arg (lambda (s) (and (integer? s)
|
|
(<= 0 s)))
|
|
(car maybe-size)
|
|
set-port-buffering))
|
|
-1))
|
|
(policy (if (zero? size) bufpol/none policy))
|
|
(err (%fdport-set-buffering/errno port policy size)))
|
|
(if err (errno-error err set-port-buffering port policy size))))
|
|
|
|
|
|
;;; Open & Close
|
|
;;; ------------
|
|
|
|
(define (open-file fname flags . maybe-mode)
|
|
(let ((fd (apply open-fdes fname flags maybe-mode))
|
|
(access (bitwise-and flags open/access-mask)))
|
|
((if (or (= access open/read) (= access open/read+write))
|
|
make-input-fdport
|
|
make-output-fdport)
|
|
fd 0)))
|
|
|
|
(define (open-input-file fname . maybe-flags)
|
|
(let ((flags (:optional maybe-flags 0)))
|
|
(open-file fname (deposit-bit-field flags open/access-mask open/read))))
|
|
|
|
(define (open-output-file fname . rest)
|
|
(let* ((flags (if (pair? rest) (car rest)
|
|
(bitwise-ior open/create open/truncate))) ; default
|
|
(maybe-mode (if (null? rest) '() (cdr rest)))
|
|
(flags (deposit-bit-field flags open/access-mask open/write)))
|
|
(apply open-file fname flags maybe-mode)))
|
|
|
|
|
|
;;; All these revealed-count-hacking procs have atomicity problems.
|
|
;;; They need to run uninterrupted.
|
|
|
|
(define (increment-revealed-count port delta)
|
|
(let* ((data (fdport-data port))
|
|
(count (fdport-data:revealed data))
|
|
(newcount (+ count delta)))
|
|
(set-fdport-data:revealed data newcount)
|
|
(if (and (zero? count) (> newcount 0)) ; We just became revealed,
|
|
(%set-cloexec (fdport-data:fd data) #f)))) ; so don't close on exec().
|
|
|
|
(define (release-port-handle port)
|
|
(check-arg fdport? port port->fdes)
|
|
(let* ((data (fdport-data port))
|
|
(rev (fdport-data:revealed data)))
|
|
(if (zero? rev)
|
|
(set-fdport-data:old-revealed data
|
|
(- (fdport-data:old-revealed data) 1))
|
|
(let ((new-rev (- rev 1)))
|
|
(set-fdport-data:revealed data new-rev)
|
|
(if (zero? new-rev) ; We just became unrevealed, so
|
|
(%set-cloexec (fdport-data:fd data) #t)))))); the fd can be closed on exec.
|
|
|
|
(define (port-revealed port)
|
|
(let ((count (fdport-data:revealed
|
|
(fdport-data
|
|
(check-arg fdport? port port-revealed)))))
|
|
(and (not (zero? count)) count)))
|
|
|
|
(define (fdes->port fd port-maker) ; local proc.
|
|
(cond ((%maybe-fdes->port fd) =>
|
|
(lambda (p)
|
|
(increment-revealed-count p 1)
|
|
p))
|
|
(else (port-maker fd 1))))
|
|
|
|
(define (fdes->inport fd) (fdes->port fd make-input-fdport))
|
|
(define (fdes->outport fd) (fdes->port fd make-output-fdport))
|
|
|
|
(define (port->fdes port)
|
|
(check-arg open-fdport? port port->fdes)
|
|
(let ((data (fdport-data port)))
|
|
(increment-revealed-count port 1)
|
|
(fdport-data:fd data)))
|
|
|
|
(define (call/fdes fd/port proc)
|
|
(cond ((integer? fd/port)
|
|
(proc fd/port))
|
|
|
|
((fdport? fd/port)
|
|
(let ((port fd/port))
|
|
(dynamic-wind
|
|
(lambda ()
|
|
(if (not port) (error "Can't throw back into call/fdes.")))
|
|
(lambda () (proc (port->fdes port)))
|
|
(lambda ()
|
|
(release-port-handle port)
|
|
(set! port #f)))))
|
|
|
|
(else (error "Not a file descriptor or fdport." fd/port))))
|
|
|
|
;;; Don't mess with the revealed count in the port case
|
|
;;; -- just sneakily grab the fdes and run.
|
|
|
|
(define (sleazy-call/fdes fd/port proc)
|
|
(proc (cond ((integer? fd/port) fd/port)
|
|
((fdport? fd/port) (fdport-data:fd (fdport-data fd/port)))
|
|
(else (error "Not a file descriptor or fdport." fd/port)))))
|
|
|
|
|
|
;;; Random predicates and arg checkers
|
|
;;; ----------------------------------
|
|
|
|
(define (open-fdport-data? x)
|
|
(and (fdport-data? x)
|
|
(not (fdport-data:closed? x))))
|
|
|
|
;(define (open-fdport? x)
|
|
; (cond ((or (and (extensible-input-port? x)
|
|
; (extensible-input-port-local-data x))
|
|
; (and (extensible-output-port? x)
|
|
; (extensible-output-port-local-data x)))
|
|
; => (lambda (d) (and (fdport-data? d) (not (fdport-data:closed? d)))))
|
|
; (else #f)))
|
|
|
|
(define (open-fdport? x)
|
|
(and (fdport? x) (or (open-output-port? x) (open-input-port? x))))
|
|
|
|
;(define (extensible-port-local-data xport)
|
|
; ((if (extensible-input-port? xport)
|
|
; extensible-input-port-local-data
|
|
; extensible-output-port-local-data)
|
|
; xport))
|
|
|
|
(define (fdport-open? port)
|
|
(check-arg fdport? port fdport-open?)
|
|
(not (fdport-data:closed? (port-data port))))
|
|
|
|
|
|
;;; Initialise the system
|
|
;;; ---------------------
|
|
|
|
(define old-inport #f) ; Just because.
|
|
(define old-outport #f)
|
|
(define old-errport #f)
|
|
|
|
(define (init-fdports!)
|
|
(%init-fdports!)
|
|
(if (not (fdport? (current-input-port)))
|
|
(set! old-inport (current-input-port)))
|
|
(if (not (fdport? (current-output-port)))
|
|
(set! old-outport (current-output-port)))
|
|
(if (not (fdport? (current-error-port)))
|
|
(set! old-errport (current-error-port)))
|
|
(let ((iport (fdes->inport 0))
|
|
(oport (fdes->outport 1)))
|
|
(set-port-buffering iport bufpol/none) ; Stdin is unbuffered.
|
|
(set-port-buffering oport bufpol/none)
|
|
(set-fluid! $current-input-port iport)
|
|
(set-fluid! $current-output-port oport)
|
|
(set-fluid! $current-error-port (fdes->outport 2))))
|
|
|
|
|
|
;;; Generic port operations
|
|
;;; -----------------------
|
|
|
|
;;; (close-after port f)
|
|
;;; Apply F to PORT. When F returns, close PORT, then return F's result.
|
|
;;; Does nothing special if you throw out or throw in.
|
|
|
|
(define (close-after port f)
|
|
(receive vals (f port)
|
|
(close port)
|
|
(apply values vals)))
|
|
|
|
(define (close port/fd)
|
|
((cond ((integer? port/fd) close-fdes)
|
|
((output-port? port/fd) close-output-port)
|
|
((input-port? port/fd) close-input-port)
|
|
(else (error "Not file-descriptor or port" port/fd))) port/fd))
|
|
|
|
;;; If this fd has an associated input or output port,
|
|
;;; move it to a new fd, freeing this one up.
|
|
|
|
(define (evict-ports fd)
|
|
(cond ((%maybe-fdes->port fd) => ; Shouldn't bump the revealed count.
|
|
(lambda (port)
|
|
(%move-fdport (%dup fd) port 0)))))
|
|
|
|
(define (close-fdes fd)
|
|
(evict-ports fd)
|
|
(%close-fdes fd))
|
|
|
|
|
|
;;; Extend R4RS i/o ops to handle file descriptors.
|
|
;;; -----------------------------------------------
|
|
|
|
(define s48-char-ready? (structure-ref scheme char-ready?))
|
|
(define s48-read-char (structure-ref scheme read-char))
|
|
|
|
(define-simple-syntax
|
|
(define-r4rs-input (name arg ...) stream s48name body ...)
|
|
(define (name arg ... . maybe-i/o)
|
|
(let ((stream (:optional maybe-i/o (current-input-port))))
|
|
(cond ((input-port? stream) (s48name arg ... stream))
|
|
((integer? stream) body ...)
|
|
(else (error "Not a port or file descriptor" stream))))))
|
|
|
|
(define-r4rs-input (char-ready?) input s48-char-ready?
|
|
(%char-ready-fdes? input))
|
|
|
|
(define-r4rs-input (read-char) input s48-read-char
|
|
(read-fdes-char input))
|
|
|
|
;structure refs changed to get reference from scheme -dalbertz
|
|
(define s48-display (structure-ref scheme display))
|
|
(define s48-newline (structure-ref scheme newline))
|
|
(define s48-write (structure-ref scheme write))
|
|
(define s48-write-char (structure-ref scheme write-char))
|
|
(define s48-format (structure-ref formats format))
|
|
(define s48-force-output (structure-ref i/o force-output))
|
|
|
|
(define-simple-syntax
|
|
(define-r4rs-output (name arg ...) stream s48name body ...)
|
|
(define (name arg ... . maybe-i/o)
|
|
(let ((stream (:optional maybe-i/o (current-output-port))))
|
|
(cond ((output-port? stream) (s48name arg ... stream))
|
|
((integer? stream) body ...)
|
|
(else (error "Not a port or file descriptor" stream))))))
|
|
|
|
;;; This one depends upon S48's string ports.
|
|
(define-r4rs-output (display object) output s48-display
|
|
(let ((sp (make-string-output-port)))
|
|
(display object sp)
|
|
(write-string (string-output-port-output sp) output)))
|
|
|
|
(define-r4rs-output (newline) output s48-newline
|
|
(write-fdes-char #\newline output))
|
|
|
|
(define-r4rs-output (write object) output s48-write
|
|
(let ((sp (make-string-output-port)))
|
|
(write object sp)
|
|
(write-string (string-output-port-output sp) output)))
|
|
|
|
(define-r4rs-output (write-char char) output s48-write-char
|
|
(write-fdes-char char output))
|
|
|
|
;;; S48's force-output doesn't default to forcing (current-output-port).
|
|
(define-r4rs-output (force-output) output s48-force-output
|
|
(values)) ; Do nothing if applied to a file descriptor.
|
|
|
|
|
|
(define (format dest cstring . args)
|
|
(if (integer? dest)
|
|
(write-string (apply s48-format #f cstring args) dest)
|
|
(apply s48-format dest cstring args)))
|
|
|
|
;;; with-current-foo-port procs
|
|
;;; ---------------------------
|
|
|
|
(define (with-current-input-port* port thunk)
|
|
(let-fluid $current-input-port port thunk))
|
|
|
|
(define (with-current-output-port* port thunk)
|
|
(let-fluid $current-output-port port thunk))
|
|
|
|
(define (with-current-error-port* port thunk)
|
|
(let-fluid $current-error-port port thunk))
|
|
|
|
(define-simple-syntax (with-current-input-port port body ...)
|
|
(with-current-input-port* port (lambda () body ...)))
|
|
|
|
(define-simple-syntax (with-current-output-port port body ...)
|
|
(with-current-output-port* port (lambda () body ...)))
|
|
|
|
(define-simple-syntax (with-current-error-port port body ...)
|
|
(with-current-error-port* port (lambda () body ...)))
|
|
|
|
|
|
;;; set-foo-port! procs
|
|
;;; -------------------
|
|
;;; Side-effecting variants of with-current-input-port* and friends.
|
|
|
|
(define (set-current-input-port! port) (set-fluid! $current-input-port port))
|
|
(define (set-current-output-port! port) (set-fluid! $current-output-port port))
|
|
(define (set-current-error-port! port) (set-fluid! $current-error-port port))
|
|
|
|
|
|
;;; call-with-foo-file with-foo-to-file
|
|
;;; -----------------------------------
|
|
|
|
;;; Copied straight from rts/port.scm, but re-defined in this module,
|
|
;;; closed over my versions of open-input-file and open-output-file.
|
|
|
|
(define (call-with-mumble-file open close)
|
|
(lambda (string proc)
|
|
(let ((port #f))
|
|
(dynamic-wind (lambda ()
|
|
(if port
|
|
(warn "throwing back into a call-with-...put-file"
|
|
string)
|
|
(set! port (open string))))
|
|
(lambda () (proc port))
|
|
(lambda ()
|
|
(if port
|
|
(close port)))))))
|
|
|
|
(define call-with-input-file
|
|
(call-with-mumble-file open-input-file close-input-port))
|
|
|
|
(define call-with-output-file
|
|
(call-with-mumble-file open-output-file close-output-port))
|
|
|
|
(define (with-input-from-file string thunk)
|
|
(call-with-input-file string
|
|
(lambda (port)
|
|
(let-fluid $current-input-port port thunk))))
|
|
|
|
(define (with-output-to-file string thunk)
|
|
(call-with-output-file string
|
|
(lambda (port)
|
|
(let-fluid $current-output-port port thunk))))
|
|
|