scsh-0.6/scheme/rts/port.scm

604 lines
18 KiB
Scheme

; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
; Ports and port handlers
; See doc/io.txt for a description of the i/o system, including ports,
; port handlers, and so forth.
(define-record-type port-handler :port-handler
(make-port-handler discloser close buffer-proc)
port-handler?
(discloser port-handler-discloser)
(close port-handler-close)
(buffer-proc port-handler-buffer-proc))
(define (disclose-port port)
((port-handler-discloser (port-handler port)) (port-data port)))
(define-method &disclose ((port :input-port))
(disclose-port port))
(define-method &disclose ((port :output-port))
(disclose-port port))
; The PORT-LOCKED? bit is checked by READ-CHAR, PEEK-CHAR, and WRITE-CHAR
; which are too simple-minded to understand real locks. The three procedures
; below ensure that (PORT-LOCKED? <port>) is #t whenever someone has aquired
; <port>'s lock.
(define (obtain-port-lock port)
(set-port-locked?! port #t)
(obtain-lock (port-lock port)))
(define (maybe-obtain-port-lock port)
(let ((ints (set-enabled-interrupts! 0)))
(set-port-locked?! port #t)
(let ((result (if (maybe-obtain-lock (port-lock port))
#t
(begin
(set-port-locked?! port #f)
#f))))
(set-enabled-interrupts! ints)
result)))
(define (release-port-lock port)
(let ((ints (set-enabled-interrupts! 0)))
(if (release-lock (port-lock port))
(set-port-locked?! port #f))
(set-enabled-interrupts! ints)))
; Set up exception handlers for the three unnecessary I/O primitives,
; READ-CHAR, PEEK-CHAR, and WRITE-CHAR. These do the right thing in
; the case of buffer overflow or underflow.
;
; This is abstracted to avoid a circular module dependency.
(define (initialize-i/o-handlers! define-exception-handler signal-exception)
(define-exception-handler (enum op read-char)
(one-arg-proc->handler (read-char-handler #t) signal-exception))
(define-exception-handler (enum op peek-char)
(one-arg-proc->handler (read-char-handler #f) signal-exception))
(define-exception-handler (enum op write-char)
(two-arg-proc->handler write-char-handler signal-exception)))
; Check the exception and then lock the port.
(define (one-arg-proc->handler proc signal-exception)
(lambda (opcode reason port)
(if (= reason (enum exception buffer-full/empty))
(begin
(obtain-port-lock port)
(let ((value (proc port)))
(release-port-lock port)
value))
(signal-exception opcode reason port))))
; This could combined with on-arg-... if the port were the first argument.
(define (two-arg-proc->handler proc signal-exception)
(lambda (opcode reason arg port)
(if (= reason (enum exception buffer-full/empty))
(begin
(obtain-port-lock port)
(let ((value (proc arg port)))
(release-port-lock port)
value))
(signal-exception opcode reason arg port))))
; If a character is available, use it; if there is an EOF waiting, use that;
; otherwise fill the buffer and go from there.
(define (read-char-handler read?)
(lambda (port)
(cond ((< (port-index port) (port-limit port))
(let ((index (port-index port)))
(if read?
(set-port-index! port (+ 1 index)))
(ascii->char (code-vector-ref (port-buffer port) index))))
((port-pending-eof? port)
(if read?
(set-port-pending-eof?! port #f))
(eof-object))
(else
(let ((got (fill-port-buffer! port 'any)))
(cond ((or (eof-object? got)
(= 0 got))
(if (not read?)
(set-port-pending-eof?! port #t))
(eof-object))
(else
(set-port-index! port (if read? 1 0))
(set-port-limit! port got)
(ascii->char (code-vector-ref (port-buffer port) 0)))))))))
(define (fill-port-buffer! port needed)
((port-handler-buffer-proc (port-handler port))
(port-data port)
(port-buffer port)
0
needed))
; Write the character if there is room, or call the handler if there is
; no actual buffering. Otherwise use the handler to empty the buffer.
(define (write-char-handler char port)
(cond ((< (port-index port) (port-limit port))
(code-vector-set! (port-buffer port)
(port-index port)
(char->ascii char))
(set-port-index! port (+ 1 (port-index port))))
((= 0 (port-limit port))
((port-handler-buffer-proc (port-handler port)) (port-data port) char))
(else
(empty-port-buffer! port)
(code-vector-set! (port-buffer port) 0 (char->ascii char))
(set-port-index! port 1)))
(unspecific))
; This may change PORT's buffer.
(define (empty-port-buffer! port)
((port-handler-buffer-proc (port-handler port))
(port-data port)
(port-buffer port)
0
(port-index port))
(set-port-index! port 0)
(set-port-flushed?! port #t))
(define port-flushed? port-pending-eof?)
(define set-port-flushed?! set-port-pending-eof?!)
;----------------
; Closing is done with the appropriate handler.
; R4RS says that CLOSE-... is idempotent.
(define (close-input-port port)
(if (input-port? port)
(begin
(obtain-port-lock port)
(if (open-input-port? port)
(begin
(make-input-port-closed! port)
((port-handler-close (port-handler port)) (port-data port))))
(release-port-lock port))
(call-error "invalid argument" close-input-port port)))
(define (close-output-port port)
(if (output-port? port)
(begin
(obtain-port-lock port)
(if (open-output-port? port)
(begin
(really-force-output port)
(make-output-port-closed! port)
((port-handler-close (port-handler port)) (port-data port))))
(release-port-lock port))
(call-error "invalid argument" close-output-port port)))
;----------------
; Port operations that do not have opcodes. Each of these needs to check its
; arguments and then lock the port. A macro is used to add the checking and
; locking code. This has to check that the port is a port before locking it
; and then check that it is open after locking it.
; A macro to handle locking ports and checking that they're open.
(define-syntax define-port-op
(syntax-rules ()
((define-port-op (?id ?args ...) ?port ?predicate ?body)
(define (?id ?args ...)
(if ?predicate ; if args are okay
(begin
(obtain-port-lock ?port) ; lock the port
(if (open-port? ?port) ; check that it's open
(let ((value ?body)) ; do the work
(release-port-lock ?port) ; release the lock
value) ; return
(begin
(release-port-lock ?port)
(call-error "invalid argument" ?id ?args ...))))
(call-error "invalid argument" ?id ?args ...))))
; ?port defaults to the first argument
((define-port-op (?id ?port ?args ...) ?predicate ?body)
(define-port-op (?id ?port ?args ...) ?port ?predicate ?body))))
;----------------
; See if there is a character available. CHAR-READY? itself is defined
; in current-ports.scm as it needs CURRENT-INPUT-PORT when called with
; no arguments.
(define (real-char-ready? port)
(cond ((not (open-input-port? port))
(call-error "invalid argument" char-ready? port))
((not (maybe-obtain-port-lock port))
#f)
((not (open-port? port)) ; have to check again after the lock call
(release-port-lock port)
(call-error "invalid argument" char-ready? port))
((or (< (port-index port) (port-limit port))
(port-pending-eof? port))
(release-port-lock port)
#t)
(else
(let ((got (fill-port-buffer! port 'immediate)))
(cond ((eof-object? got)
(set-port-pending-eof?! port #t)
(release-port-lock port)
#t)
(else
(set-port-index! port 0)
(set-port-limit! port got)
(release-port-lock port)
(> got 0)))))))
;----------------
; Check the arguments and the state of the buffer. Leave any actual work
; up to the next procedure.
;
; The arguments are the same as those for input port handlers: BUFFER is either
; a string or a code vector, START is the initial index, and COUNT is either
; the required number of characters, 'ANY (one or more characters wanted),
; or 'IMMEDIATE (get what's available, but don't block).
(define-port-op (read-block buffer start count port) port
(and (open-input-port? port)
(okay-limits? buffer start (if (or (eq? count 'any)
(eq? count 'immediate))
1
count)))
(cond ((port-pending-eof? port)
(set-port-pending-eof?! port #f)
(eof-object))
((eq? count 0)
0)
(else
(really-read-block buffer start count port))))
; If nothing is available, call the port's handler procedure. Otherwise,
; copy any available characters into the buffer. If more are needed the
; buffer handler is called.
(define (really-read-block buffer start count port)
(let ((have (- (port-limit port) (port-index port))))
(if (= have 0)
((port-handler-buffer-proc (port-handler port))
(port-data port)
buffer
start
count)
(let ((move (min have
(if (symbol? count)
(- (buffer-length buffer) start)
count))))
(copy-bytes! (port-buffer port) (port-index port) buffer start move)
(set-port-index! port (+ (port-index port) move))
(if (or (symbol? count)
(= move count))
move
(read-more buffer start count port move))))))
(define (buffer-length buffer)
(if (string? buffer)
(string-length buffer)
(code-vector-length buffer)))
(define (read-more buffer start count port have)
(let ((more ((port-handler-buffer-proc (port-handler port))
(port-data port)
buffer
(+ start have)
(- count have))))
(if (eof-object? more)
(if (= 0 have)
(eof-object)
(begin
(set-port-pending-eof?! port #t)
have))
(+ more have))))
; Check that BUFFER contains COUNT characters starting from START.
(define (okay-limits? buffer start count)
(and (integer? start)
(exact? start)
(<= 0 start)
(integer? count)
(exact? count)
(<= 0 count)
(<= (+ start count)
(cond ((string? buffer)
(string-length buffer))
((code-vector? buffer)
(code-vector-length buffer))
(else
-1)))))
;----------------
; Write the COUNT bytes beginning at START from BUFFER to PORT.
(define-port-op (write-block buffer start count port) port
(and (open-output-port? port)
(okay-limits? buffer start count))
(if (= 0 (port-limit port))
(write-unbuffered-block buffer start count port)
(write-buffered-block buffer start count port)))
; WRITE-STRING is a front for WRITE-BLOCK.
(define (write-string string port)
(write-block string 0 (string-length string) port))
; Copy the bytes into the buffer if there is room, otherwise write out anything
; in the buffer and then write BUFFER.
(define (write-buffered-block buffer start count port)
(let ((space (- (port-limit port) (port-index port))))
(cond ((>= space count)
(copy-bytes! buffer start (port-buffer port) (port-index port) count)
(set-port-index! port (+ (port-index port) count)))
(else
(really-force-output port)
((port-handler-buffer-proc (port-handler port))
(port-data port) buffer start count)))))
; For unbuffered ports we have to call the handler on each character
; separately.
(define (write-unbuffered-block buffer start count port)
(let ((proc (port-handler-buffer-proc (port-handler port)))
(data (port-data port))
(string? (string? buffer)))
(do ((i 0 (+ i 1)))
((= i count))
(proc data (if string?
(string-ref buffer (+ start i))
(ascii->char (code-vector-ref buffer (+ start i))))))))
;----------------
; Empty the buffer if it contains anything.
(define-port-op (force-output port)
(open-output-port? port)
(really-force-output port))
(define (really-force-output port)
(if (< 0 (port-index port))
(empty-port-buffer! port)))
; Used to avoid race conditions elsewhere.
(define (force-output-if-open port)
(if (output-port? port)
(begin
(obtain-port-lock port)
(if (open-output-port? port)
(really-force-output port))
(release-port-lock port))
(call-error "invalid argument" force-output-if-open port)))
;----------------
(define default-buffer-size 4096) ; should get this from the system
;----------------
; Is PORT open?
(define (open-port? port)
(not (= 0 (bitwise-and open-port-mask (port-status port)))))
(define open-port-mask
(bitwise-ior (arithmetic-shift 1 (enum port-status-options open-for-input))
(arithmetic-shift 1 (enum port-status-options open-for-output))))
;----------------
; Input ports
(define input-port-mask
(arithmetic-shift 1 (enum port-status-options input)))
(define open-input-port-mask
(arithmetic-shift 1 (enum port-status-options open-for-input)))
(define open-input-port-status
(bitwise-ior input-port-mask open-input-port-mask))
(define (open-input-port? port)
(not (= 0 (bitwise-and open-input-port-mask (port-status port)))))
(define (make-input-port-closed! port)
(set-port-status! port (bitwise-and (port-status port)
(bitwise-not open-input-port-mask))))
(define (make-input-port handler data buffer index limit)
(if (and (okay-buffer? buffer index limit)
(port-handler? handler))
(make-port handler
(bitwise-ior input-port-mask open-input-port-mask)
(make-lock)
#f ; locked?
data
buffer
index
limit
#f) ; pending-eof?
(call-error "invalid argument"
make-input-port handler data buffer index limit)))
(define (okay-buffer? buffer index limit)
(and (code-vector? buffer)
(let ((length (code-vector-length buffer)))
(integer? limit)
(<= 0 limit)
(<= limit length)
(<= index limit)
(integer? index)
(<= 0 index)
(<= index limit))))
;----------------
; Output ports
(define output-port-mask
(arithmetic-shift 1 (enum port-status-options output)))
(define open-output-port-mask
(arithmetic-shift 1 (enum port-status-options open-for-output)))
(define open-output-port-status
(bitwise-ior output-port-mask open-output-port-mask))
(define (open-output-port? port)
(not (= 0 (bitwise-and open-output-port-mask (port-status port)))))
(define (make-output-port-closed! port)
(set-port-status! port (bitwise-and (port-status port)
(bitwise-not open-output-port-mask))))
(define (make-output-port handler data buffer index limit)
(if (and (okay-buffer? buffer index limit)
(> limit 0)
(port-handler? handler))
(make-port handler
open-output-port-status
(make-lock)
#f ; locked?
data
buffer
index
limit
#f) ; pending-eof?
(call-error "invalid argument"
make-output-port handler data buffer index limit)))
(define (make-unbuffered-output-port handler data)
(if (port-handler? handler)
(make-port handler
open-output-port-status
(make-lock)
#f ; locked?
data
(make-code-vector 0 0)
0
0
#f) ; pending-eof?
(call-error "invalid argument"
make-unbuffered-output-port handler data)))
(define null-output-port-handler
(make-port-handler
(lambda (ignore)
(list 'null-output-port))
(lambda (ignore)
(unspecific))
(lambda (channel buffer start need)
(unspecific))))
(define (make-null-output-port)
(make-port null-output-port-handler
open-output-port-status
(make-lock) ; wasted
#f ; locked?
(unspecific)
(make-code-vector 1 0)
0
1 ; if 0 it would look unbuffered
#f)) ; pending-eof?
;----------------
; Code to periodically flush output ports.
(define *flush-these-ports* (cons #f '()))
(define (initialize-output-port-list!)
(set! *flush-these-ports* (cons #f '())))
(define (periodically-force-output! port)
(set-cdr! *flush-these-ports*
(cons (make-weak-pointer port) (cdr *flush-these-ports*))))
; Return a list of thunks that will flush the buffer of each open, unlocked
; port that contains characters that have been there since the last time
; this was called. The actual i/o is done using separate threads to keep
; i/o errors from killing anything vital.
;
; If USE-FLUSHED?-FLAGS? is true this won't flush buffers that have been
; flushed by someone else sinse the last call. If it is false then flush
; all non-empty buffers, because the system has nothing to do and is going
; to pause while waiting for external events.
(define (output-port-forcers use-flushed?-flags?)
(let loop ((next (cdr *flush-these-ports*))
(last *flush-these-ports*)
(thunks '()))
(if (null? next)
thunks
(let ((port (weak-pointer-ref (car next))))
(cond ((or (not port) ; GCed or closed
(not (open-output-port? port))) ; so drop it from the list
(set-cdr! last (cdr next))
(loop (cdr next) last thunks))
((not (maybe-obtain-port-lock port)) ; locked
(loop (cdr next) next thunks))
((and use-flushed?-flags? ; flushed recently
(port-flushed? port))
(set-port-flushed?! port #f)
(release-port-lock port)
(loop (cdr next) next thunks))
((< 0 (port-index port)) ; non-empty
(release-port-lock port)
(loop (cdr next) next
(cons (make-forcing-thunk port)
thunks)))
(else ; empty
(release-port-lock port)
(loop (cdr next) next thunks)))))))
; Returns a list of the current ports that are flushed whenever.
; This is used to flush channel ports before forking.
(define (periodically-flushed-ports)
(let ((ints (set-enabled-interrupts! 0)))
(let loop ((next (cdr *flush-these-ports*))
(last *flush-these-ports*)
(ports '()))
(if (null? next)
(begin
(set-enabled-interrupts! ints)
ports)
(let ((port (weak-pointer-ref (car next))))
(cond ((or (not port) ; GCed or closed
(not (open-output-port? port))) ; so drop it from the list
(set-cdr! last (cdr next))
(loop (cdr next) last ports))
(else
(loop (cdr next)
next
(cons port ports)))))))))
; Write out PORT's buffer. If a problem occurs it is reported and PORT
; is closed.
(define (make-forcing-thunk port)
(lambda ()
(if (and (report-errors-as-warnings
(lambda ()
(if (maybe-obtain-port-lock port)
(begin
(really-force-output port)
(release-port-lock port))))
"error when flushing buffer; closing port"
port)
(open-output-port? port))
(report-errors-as-warnings
(lambda ()
(make-output-port-closed! port)
((port-handler-close (port-handler port)) (port-data port)))
"error when closing port"
port))))