;;; 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))))