; -*- Mode: Scheme; Syntax: Scheme; Package: Scheme; -*-
; This is file vmio.scm.
;;;; I/O primitives
; Port fields:
; port-mode 1 = input
; 2 = output
; (this field doesn't ever change)
; port-index index into open-ports vector
; 0 = initial input port
; 1 = initial output port
; -1 = not open
; peeked-char char or #f
; port-id for debugging
;
; Questions:
; What to do if an error occurs?
; How to deal with transcript-on and transcript-off ?
; How to deal with uninterrubtibly opening a port and pushing it onto
; an outstanding-ports list?
; *open-vm-ports* is a vector of descriptors for open ports.
; *open-ports is a vector of open ports of the underlying Scheme implementation.
(define *number-of-ports* 100)
(define *open-ports* (unassigned))
(define *open-vm-ports* (unassigned))
(define for-input 1)
(define for-output 2)
(define (vm-input-port? obj)
(and (port? obj)
(= (port-mode obj) (enter-fixnum for-input))))
(define (vm-output-port? obj)
(and (port? obj)
(= (port-mode obj) (enter-fixnum for-output))))
(define iip-index 0) ;index of initial input port
(define iop-index 1) ;[out/in]ditto
(define (initialize-i/o-system)
(set! *open-ports* (make-vector *number-of-ports*))
(set! *open-vm-ports* (make-vector *number-of-ports*))
(if (or (null-pointer? *open-ports*)
(null-pointer? *open-vm-ports*))
(error "out of memory, unable to continue"))
(vector+length-fill! *open-vm-ports* *number-of-ports* false)
(vector-set! *open-ports* iip-index (current-input-port))
(vector-set! *open-ports* iop-index (current-output-port))
(let ((iip (make-port (enter-fixnum for-input)
(enter-fixnum iip-index)
false
(enter-string "si")
universal-key))
(iop (make-port (enter-fixnum for-output)
(enter-fixnum iop-index)
false
(enter-string "so")
universal-key)))
(vector-set! *open-vm-ports* iip-index iip)
(vector-set! *open-vm-ports* iop-index iop)
unspecific))
(define (allocate-another-port-descriptor got-one-cont none-left-cont)
(let* ((new-count (+ *number-of-ports* 8))
(old-count *number-of-ports*)
(new-ports (make-vector new-count))
(new-vm-ports (make-vector new-count)))
(cond ((or (null-pointer? new-ports)
(null-pointer? new-vm-ports))
(none-left-cont))
(else
(vector+length-fill! new-vm-ports new-count false)
(do ((i 0 (+ i 1)))
((>= i *number-of-ports*))
(vector-set! new-ports i (vector-ref *open-ports* i))
(vector-set! new-vm-ports i (vector-ref *open-vm-ports* i)))
(deallocate *open-ports*)
(deallocate *open-vm-ports*)
(set! *open-ports* new-ports)
(set! *open-vm-ports* new-vm-ports)
(set! *number-of-ports* new-count)
(got-one-cont old-count))))) ; new and unallocated port index
(define initial-i/o-heap-space (* 2 port-size))
(define (initial-input-port)
(vector-ref *open-vm-ports* iip-index))
(define (initial-output-port)
(vector-ref *open-vm-ports* iop-index))
; Auxiliaries for I/O primitives
(define (extract-port port)
(vector-ref *open-ports* (extract-fixnum (port-index port))))
(define (find-port-index)
(let loop ((i 0))
(cond ((>= i *number-of-ports*)
-1)
((false? (vector-ref *open-vm-ports* i))
i)
(else (loop (+ i 1))))))
(define (use-port-index! index vm-port port)
(vector-set! *open-ports* index port)
(vector-set! *open-vm-ports* index vm-port))
; [An open can fail for several reasons:
; - The OS couldn't open it
; - There are no empty slots in *open-ports* and we can't get more memory
; ]
(define (open-port filename mode key collect-saving-temp
succeeded os-failed vm-failed)
(let loop ((index (find-port-index)) (filename filename))
(if (>= index 0)
(really-open-port filename index mode key succeeded os-failed)
(let ((filename (collect-saving-temp filename)))
(let ((index (find-port-index)))
(if (>= index 0)
(loop index filename)
(allocate-another-port-descriptor
(lambda (index)
(loop index filename))
(lambda ()
(vm-failed filename)))))))))
(define (really-open-port filename index mode key succeeded os-failed)
(let ((port (cond ((= mode for-output)
(open-output-file (extract-string filename)))
(else ;(= mode for-input)
(open-input-file (extract-string filename))))))
(if (null-port? port)
(os-failed filename)
(let ((vm-port (make-port (enter-fixnum mode)
(enter-fixnum index)
false
filename
key)))
(use-port-index! index vm-port port)
(succeeded vm-port)))))
(define (open? port)
(>= (port-index port) (enter-fixnum 0)))
(define (close-port vm-port)
(if (open? vm-port)
(let ((index (extract-fixnum (port-index vm-port))))
(if (not (or (= index iip-index)
(= index iop-index)))
(let ((port (extract-port vm-port))
(mode (extract-fixnum (port-mode vm-port))))
(cond ((= mode for-input)
(close-input-port port))
((= mode for-output)
(close-output-port port))
(else
(error "this shouldn't happen when closing a port")))
(set-port-mode! vm-port (enter-fixnum 0))
(set-port-index! vm-port (enter-fixnum -1))
; (vector-set! *open-ports* index 0) ; type error
(vector-set! *open-vm-ports* index false))))))
; The following is called after the GC finishes.
(define (close-untraced-ports!)
(do ((i 2 (+ i 1))) ; Skip over initial input and output ports
((= i *number-of-ports*) #f)
(let ((port (vector-ref *open-vm-ports* i)))
(if (not (false? port))
(let* ((header (stob-header port))
(new (cond ((stob? header) ; port was copied
header)
(else ; port was not copied
(close-port-noisily port)
false))))
(vector-set! *open-vm-ports* i new))))))
(define (close-port-noisily port)
(let* ((header (stob-header (port-id port)))
(name (if (stob? header)
header ; name was copied
(port-id port)))) ; name was not copied
(close-port port)
(write-string "Port closed: " (current-output-port))
(write-vm-string (port-id port) (current-output-port))
(newline (current-output-port))))