; -*- Mode: Scheme; Syntax: Scheme; Package: S48; -*-

; 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-ports* is a vector of descriptors for open ports.
; *open-%ports is a vector of open "%ports".  A "%port" corresponds to
; a non-simulated Scheme port, or to a C FILE * object.

(define number-of-ports 100)

(define *open-%ports* (unassigned))
(define *open-ports*  (unassigned))

(define (extract-port port)
  (let ((index (extract-fixnum (port-index port))))
    (if (>=& index 0)
	(scheme:vector-ref *open-%ports* index)
	#f)))

(define (initialize-i/o-system)
  (set! *open-%ports* (scheme:make-vector number-of-ports #f))
  (set! *open-ports*  (scheme:make-vector number-of-ports f))
  (scheme:vector-set! *open-%ports* 0 (current-input-port))
  (scheme:vector-set! *open-%ports* 1 (current-output-port)))

; Auxiliaries for I/O primitives

(define (input-port? obj)
  (and (port? obj)
       (=& (extract-fixnum (port-mode obj)) 1)))

(define (output-port? obj)
  (and (port? obj)
       (=& (extract-fixnum (port-mode obj)) 2)))

(define (open? port)
  (>=& (extract-fixnum (port-index port)) 0))

(define port->        (input-type port?        (lambda (x) x)))
(define input-port->  (input-type input-port?  (lambda (x) x)))
(define output-port-> (input-type output-port? (lambda (x) x)))

(define (enter-char-or-eof c)
  (if (eof-object? c)
      eof-object
      (enter-char c)))

(define (->char-or-eof c)
  (return (enter-char-or-eof c)))

; I/O primitives

(define-primitive op/open-port (string->)
  (lambda (filename)
    (let ((index (scheme:vector-posq #f *open-%ports*)))
      (cond (index
	     (set! *retrying-after-gc?* #f)
	     (let* ((mode (next-byte))
		    (%port (case mode
			     ((1) (open-input-file (extract-string filename)))
			     ((2) (open-output-file (extract-string filename)))
			     (else #f))))
	       (if %port
		   (let ((port (make-port (enter-fixnum mode)
					  (enter-fixnum index)
					  f
					  filename)))
		     (scheme:vector-set! *open-%ports* index %port)
		     (scheme:vector-set! *open-ports*  index port)
		     (return port))
		   (raise exception/file-not-found))))
	    (else
	     (set! *pc* (-& *pc* 1))	;Back up!
	     (set! *finished* interpret)
	     (goto collect-and-retry))))))

(define (close-port port)
  (lambda (port)
    (if (open? port)
	(let ((%port (extract-port port))
	      (index (port-index port)))
	  (case (port-mode port)
	    ((1) (close-input-port %port))
	    ((2) (close-output-port %port)))
	  (set-input-port-index! port -1)
	  (scheme:vector-set! *open-%ports* index #f)
	  (scheme:vector-set! *open-ports*  index f)))))

(define-primitive op/close-port (port->)
  close-port
  ->unsepcified)

(define-primitive op/read-char (input-port->)
  (lambda (port)
    (if (open? port)
	(let ((c (peeked-char port)))
	  (return (cond ((false? c)
			 (enter-char-or-eof
			   (read-char (extract-port port))))
			(else
			 (set-peeked-char! port f)
			 c))))
	(raise exc/operation-on-closed-port))))

(define-primitive op/peek-char (input-port->)
  (lambda (port)
    (if (open? port)
	(let ((c (peeked-char port)))
	  (return (cond ((false? c)
			 (let ((c (enter-char-or-eof
				    (read-char (extract-port port)))))
			   (set-peeked-char! port c)
			   c))
			(else c))))
	(raise exc/operation-on-closed-port))))

(define-primitive op/write-char (char-> output-port->)
  (lambda (c port)
    (if (open? port)
	(begin (write-char c (extract-port port))
	       (return unspecifed))
	(raise exc/operation-on-closed-port))))

(define-primitive op/write-string (xstring-> output-port->)
  (lambda (c port)
    (if (open? port)
	(begin (write-string s (extract-port port))
	       (return unspecifed))
	(raise exc/operation-on-closed-port))))

; The following are auxiliaries for GC and SUSPEND.

(define (close-port-noisily port)
  (close-port port)
  (write-string "Port closed: ")
  (write-string (extract-string (port-id port)))
  (newline))

(define (map-over-open-ports! proc)  ;For suspend and GC
  (do ((i 0 (+& i 1)))
      ((=& i number-of-ports) #f)
    (let ((port (scheme:vector-ref *open-ports* i)))
      (if (not (false? port))
	  ;; Update pointer after GC
	  (scheme:vector-set! *open-ports* i (proc port))))))