scsh-0.6/scsh/newports.scm

704 lines
23 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
channel
revealed)
(define max-fdport 255)
; This stuff is _weak_.
; Vector of weak pointers mapping fd -> fdport.
(define (weak-vector-set! vector number set-me)
(vector-set! vector number (make-weak-pointer set-me)))
(define (weak-vector-ref vector number)
(let ((ref (vector-ref vector number)))
(if (weak-pointer? ref) (weak-pointer-ref ref) ref)))
(define (strengthen-weak-vector-ref vector number)
(vector-set! vector number (weak-vector-ref vector number)))
(define (weaken-weak-vector-ref vector number)
(weak-vector-set! vector number (weak-vector-ref vector number)))
(define fdports (make-vector max-fdport #f))
(define (install-fdport fdport)
(let* ((fdport* (fdport-data fdport))
(ch (fdport-data:channel fdport*))
(ch-number (channel-os-index ch)))
(if (fdport-data:revealed fdport*)
(vector-set! fdports ch-number fdport)
(weak-vector-set! fdports ch-number fdport))))
(define (maybe-fdes->port fdes)
(weak-vector-ref fdports fdes))
;Hmm... these shouldn't be necessary. But still.
;Fake defrec routines for backwards compatibility.
(define (fdport-data:fd fdport*)
(channel-os-index (fdport-data:channel fdport*)))
(define (fdport-data:closed? fdport*)
(eq? (channel-status (fdport-data:channel fdport*))
(enum channel-status-option closed)))
;Arbitrary, for now.
(define buffer-size 255)
(define open-fdchannel open-channel)
(define (make-input-fdchannel fd)
(open-fdchannel fd (enum channel-status-option input)))
(define (make-output-fdchannel fd)
(open-fdchannel fd (enum channel-status-option output)))
;The two following routines are to build ports from stdin and stdout channels.
(define (channel-port->input-fdport channel-port)
(let ((p (make-input-port input-fdport-handler
(make-fdport-data (channel-cell-ref (port-data channel-port)) 1)
(make-code-vector buffer-size 0) 0 0)))
(obtain-port-lock channel-port)
(set-port-lock! p (port-lock channel-port))
(set-port-locked?! p (port-locked? channel-port))
(install-fdport p)
(release-port-lock channel-port)
p))
(define (channel-port->output-fdport channel-port)
(let ((p (make-output-port output-fdport-handler
(make-fdport-data (channel-cell-ref(port-data channel-port)) 1)
(make-code-vector buffer-size 0) 0 buffer-size)))
(obtain-port-lock channel-port)
(set-port-lock! p (port-lock channel-port))
(set-port-locked?! p (port-locked? channel-port))
(install-fdport p)
(periodically-force-output! p)
(release-port-lock channel-port)
p))
(define (channel-port->unbuffered-output-fdport channel-port)
(let ((p (make-unbuffered-output-port unbuffered-output-fdport-handler
(make-fdport-data (channel-cell-ref(port-data channel-port)) 1))))
(obtain-port-lock channel-port)
(set-port-lock! p (port-lock channel-port))
(set-port-locked?! p (port-locked? channel-port))
(install-fdport p)
; (periodically-force-output! p)
(release-port-lock channel-port)
p))
(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))
(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-fdport p)
p))
(define (make-output-fdport fd revealed)
(let ((p (alloc-output-fdport fd revealed)))
;(periodically-force-output! p)
(install-fdport p)
p))
(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)))
(define fdport-null-method (lambda (x) x #f))
(define null-func (lambda args #t))
(define (close-fdport* fdport*)
(vector-set! fdports (channel-os-index (fdport-data:channel fdport*)) #f)
(close-channel (fdport-data:channel fdport*)))
;The handlers drop straight through to the convenient channel routines.
(define (make-input-fdport-handler bufferproc)
(make-port-handler
(lambda (fdport*)
(list 'input-fdport (fdport-data:channel fdport*)))
close-fdport*
bufferproc
(lambda (fdport* owner)
(steal-channel! (fdport-data:channel fdport*) owner))))
(define input-fdport-handler
(make-input-fdport-handler
(lambda (fdport* buffer start needed)
(channel-read buffer start needed (fdport-data:channel fdport*)))))
(define (make-output-fdport-handler bufferproc)
(make-port-handler
(lambda (fdport*)
(list 'output-fdport (fdport-data:channel fdport*)))
close-fdport*
bufferproc
(lambda (fdport* owner)
(steal-channel! (fdport-data:channel fdport*) owner))))
(define output-fdport-handler
(make-output-fdport-handler
(lambda (fdport* buffer start count)
(channel-write buffer start count (fdport-data:channel fdport*)))))
(define unbuffered-output-fdport-handler
(let ((buffer (make-code-vector 1 0)))
(make-output-fdport-handler
(lambda (fdport* char)
(code-vector-set! buffer 0 (char->ascii char))
(channel-write buffer 0 1 (fdport-data:channel fdport*))))))
(define fdport-data port-data)
; That was easy.
(define (06-policy policy)
(case policy
((0) 'bufpol/block)
((1) 'bufpol/line)
((2) 'bufpol/none)
(else policy)))
(define (guess-output-policy port)
(if (= 0 (port-limit port))
'bufpol/none
'bufpol/block))
(define (set-port-buffering port policy . maybe-size)
(let ((policy (06-policy policy)))
(cond ((and (fdport? port) (open-input-port? port))
(let ((size (if (pair? maybe-size) (car maybe-size) 255)))
(set-input-port-buffering port policy size)))
((and (fdport? port) (open-output-port? port))
(let ((size (if (pair? maybe-size) (car maybe-size) 255)))
(if (<= size 0) (error "size must be at least 1"))
(set-output-port-buffering port policy size)))
(else
(warn "port-type not supported" port)))))
(define (set-output-port-buffering port policy size)
(cond ((eq? policy 'bufpol/none)
(install-nullbuffer port unbuffered-output-fdport-handler))
((eq? policy 'bufpol/block)
(let ((old-size (code-vector-length (port-buffer port)))
(new-buffer (make-code-vector size 0)))
(if (< size old-size)
(begin
(really-force-output port)
(obtain-port-lock port)
(set-port-index! port 0))
(begin
(obtain-port-lock port)
(copy-bytes! (port-buffer port) 0 new-buffer 0 old-size)))
(install-buffer port new-buffer size)
(release-port-lock port)))
((eq? policy 'bufpol/line)
(install-nullbuffer port (make-line-output-proc size)))
(else (warn "policy not supported " policy))))
(define (install-nullbuffer port handler)
(really-force-output port)
(obtain-port-lock port)
(set-port-limit! port 0)
(set-port-index! port 0)
(set-port-buffer! port (make-code-vector 0 0))
(set-port-handler! port handler)
(release-port-lock port))
(define (install-buffer port new-buffer size)
(if (eq? 'bufpol/none (guess-output-policy port))
(set-port-handler! port output-fdport-handler))
(set-port-limit! port size)
(set-port-buffer! port new-buffer))
; TODO flush on stdinput is required
;;; This port can ONLY be flushed with a newline or a close-output
;;; flush-output won't help
(define (make-line-output-proc size)
(let ((proc-buffer (make-code-vector size 0))
(proc-buffer-index 0))
(make-port-handler
(lambda (fdport*)
(list 'output-fdport (fdport-data:channel fdport*)))
(lambda (fdport*)
(channel-write proc-buffer
0
proc-buffer-index
(fdport-data:channel fdport*))
(close-fdport* fdport*))
(lambda (fdport* char)
(code-vector-set! proc-buffer proc-buffer-index (char->ascii char))
(set! proc-buffer-index (+ proc-buffer-index 1))
(cond ((or (eq? char #\newline) (= proc-buffer-index size))
(channel-write proc-buffer
0
proc-buffer-index
(fdport-data:channel fdport*))
(set! proc-buffer-index 0))))
(lambda (fdport* owner)
(steal-channel! (fdport-data:channel fdport*) owner)))))
(define (set-input-port-buffering port policy size)
(cond ((eq? policy 'bufpol/none)
(set-input-port-buffering port 'bufpol/block 1))
((eq? policy 'bufpol/block)
(if (<= size 0) (error "size must be at least 1"))
(install-input-handler port input-fdport-handler size #t))
((eq? policy 'bufpol/line)
(if (<= size 0) (error "size must be at least 1"))
(install-input-handler port line-input-handler size #t))
(else (warn "policy not supported " policy))))
(define (install-input-handler port new-handler size gentle?)
(obtain-port-lock port)
(let* ((old-limit (port-limit port))
(old-index (port-index port))
(old-buffer (port-buffer port))
(old-unread (- old-limit old-index))
(new-unread (min old-unread size))
(throw-away (max 0 (- old-unread new-unread)))
(new-buffer (make-code-vector size 0)))
(if (not gentle?)
(let ((ret (if (> throw-away 0)
(let ((return-buffer
(make-code-vector throw-away 0)))
(copy-bytes! old-buffer old-index
return-buffer 0
throw-away) return-buffer)
#f)))
(copy-bytes! old-buffer (+ old-index throw-away)
new-buffer 0
new-unread)
(set-port-buffer! port new-buffer)
(set-port-index! port 0)
(set-port-limit! port new-unread)
(set-port-handler! port new-handler)
(release-port-lock port)
ret)
(begin
(install-drain-port-handler
old-buffer old-index old-limit port new-handler)
(set-port-buffer! port new-buffer)
(set-port-index! port 0)
(set-port-limit! port 0)
(release-port-lock port)
#t))))
(define (install-drain-port-handler
old-buffer old-start old-limit port new-handler)
(if (< 0 (- old-limit old-start))
(set-port-handler! port
(make-drain-port-handler
old-buffer old-start old-limit port new-handler))
(set-port-handler! port new-handler)))
;;; TODO: This reference to port will prevent gc !!!
(define (make-drain-port-handler
very-old-buffer old-start old-limit port new-handler)
(let ((old-buffer (make-code-vector old-limit 0)))
(copy-bytes! very-old-buffer 0 old-buffer 0 old-limit)
(make-input-fdport-handler
(lambda (data buffer start needed)
(let ((old-left (- (code-vector-length old-buffer) old-start)))
(let ((size (cond ((or (eq? needed 'any) (eq? needed 'immediate))
(min old-left
(code-vector-length buffer)))
(else (min needed old-left)))))
(copy-bytes! old-buffer old-start buffer start size)
(set! old-start (+ size old-start))
(if (= old-start (code-vector-length old-buffer)) ;buffer drained ?
(begin
(set-port-handler! port new-handler)
(if (and (integer? needed) (> needed size))
(+ size ((port-handler-buffer-proc new-handler)
data buffer (+ start size) (- needed size)))
size))
size)))))))
(define line-input-handler
(make-input-fdport-handler
(lambda (fdport* buffer start needed)
(read-until-newline fdport* buffer start needed 0))))
(define newline-ascii (char->ascii #\newline))
(define (read-until-newline fdport* buffer start needed counter)
(let ((channel-needed (if (eq? needed 'immediate) needed 1)))
(let ((read (channel-read buffer
start
channel-needed
(fdport-data:channel fdport*))))
(if (= 0 read)
counter
(begin
(set! counter (+ counter 1))
(if (or (and (code-vector? buffer)
(= newline-ascii (code-vector-ref buffer start)))
(and (string? buffer)
(eq? #\newline (string-ref buffer start)))
(and (number? needed) (= needed counter))
(and (eq? needed 'any) (= (+ start 1) (buffer-length buffer))))
counter
(read-until-newline fdport* buffer
(+ start 1)
needed
counter)))))))
(define (buffer-length buffer)
(if (string? buffer)
(string-length buffer)
(code-vector-length buffer)))
;;; Open & Close
;;; ------------
;;; replace rts/channel-port.scm begin
(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)))
;;; replace rts/channel-port.scm end
;;; All these revealed-count-hacking procs have atomicity problems.
;;; They need to run uninterrupted.
;;; (port-locks should do the trick -df)
;;; (what else has atomicity problems? -df)
(define (increment-revealed-count port delta)
(obtain-port-lock port)
(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,
(begin
(strengthen-weak-vector-ref fdports (fdport-data:fd data))
(%set-cloexec (fdport-data:fd data) #f)))); so don't close on exec().
(release-port-lock port))
(define (release-port-handle port)
(check-arg fdport? port port->fdes)
(obtain-port-lock port)
(let* ((data (fdport-data port))
(rev (fdport-data:revealed data)))
(if (not (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
(begin ; the fd can be closed on exec.
(weaken-weak-vector-ref fdports (fdport-data:fd data))
(%set-cloexec (fdport-data:fd data) #t))))))
(release-port-lock port))
(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)
(and (fdport? x) (or (open-output-port? x) (open-input-port? x))))
(define (fdport-open? port)
(check-arg fdport? port fdport-open?)
(not (fdport-data:closed? (port-data port))))
;;; Initialise the system
;;; ---------------------
;;; JMG: should be deprecated-proc
(define error-output-port
current-error-port)
(define old-inport #f) ; Just because.
(define old-outport #f)
(define old-errport #f)
(define (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)))
(set-fluid! $current-input-port (channel-port->input-fdport (current-input-port)))
(set-fluid! $current-output-port (channel-port->output-fdport (current-output-port)))
(set-fluid! $current-error-port (channel-port->unbuffered-output-fdport (current-error-port)))
(set-fluid! $current-noise-port (make-null-output-port)))
;;; 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 (%move-fdport fd port new-revealed)
(obtain-port-lock port)
(let* ((fdport* (fdport-data port))
(ch (fdport-data:channel fdport*))
(old-fd (channel-os-index ch))
(old-vector-ref (vector-ref fdports old-fd)))
(set-fdport-data:revealed fdport* new-revealed)
(vector-set! fdports old-fd #f)
(close-channel ch)
(set-fdport-data:channel
fdport*
((if (input-port? port) make-input-fdchannel make-output-fdchannel) fd))
(vector-set! fdports fd old-vector-ref)
(%set-cloexec fd (not new-revealed)))
(release-port-lock port)
#f) ; JMG: It used to return #f on succes in 0.5.1, so we do the same
(define (close-fdes fd)
(evict-ports fd)
(%close-fdes fd))
(define (flush-fdport fdport)
(check-arg fdport? fdport flush-fdport)
(force-output fdport))
(define (flush-all-ports)
(let loop ((i 0))
(if (< i max-fdport)
(begin
(let ((fdport (weak-vector-ref fdports i)))
(if (and fdport (output-port? fdport) ) (flush-fdport fdport)))
(loop (+ i 1))))))
;;; 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)))))))
;;; replace rts/channel-port.scm begin
(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))))
;;; replace rts/channel-port.scm end