;;;  SCHEME->C Runtime Library

;*              Copyright 1989 Digital Equipment Corporation
;*                         All Rights Reserved
;*
;* Permission to use, copy, and modify this software and its documentation is
;* hereby granted only under the following terms and conditions.  Both the
;* above copyright notice and this permission notice must appear in all copies
;* of the software, derivative works or modified versions, and any portions
;* thereof, and both notices must appear in supporting documentation.
;*
;* Users of this software agree to the terms and conditions set forth herein,
;* and hereby grant back to Digital a non-exclusive, unrestricted, royalty-free
;* right and license under any changes, enhancements or extensions made to the
;* core functions of the software, including but not limited to those affording
;* compatibility with other hardware or software environments, but excluding
;* applications which incorporate this software.  Users further agree to use
;* their best efforts to return to Digital any such changes, enhancements or
;* extensions that they make and inform Digital of noteworthy uses of this
;* software.  Correspondence should be provided to Digital at:
;* 
;*                       Director of Licensing
;*                       Western Research Laboratory
;*                       Digital Equipment Corporation
;*                       100 Hamilton Avenue
;*                       Palo Alto, California  94301  
;* 
;* This software may be distributed (but not offered for sale or transferred
;* for compensation) to third parties, provided such third parties agree to
;* abide by the terms and conditions of this notice.  
;* 
;* THE SOFTWARE IS PROVIDED "AS IS" AND DIGITAL EQUIPMENT CORP. DISCLAIMS ALL
;* WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING ALL IMPLIED WARRANTIES OF
;* MERCHANTABILITY AND FITNESS.   IN NO EVENT SHALL DIGITAL EQUIPMENT
;* CORPORATION BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL
;* DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR
;* PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS
;* ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS
;* SOFTWARE.

(module scrt5
    (top-level
    	STDIN-PORT STDOUT-PORT STDERR-PORT
	CALL-WITH-INPUT-FILE CALL-WITH-OUTPUT-FILE INPUT-PORT? OUTPUT-PORT?
	CURRENT-INPUT-PORT CURRENT-OUTPUT-PORT
	WITH-INPUT-FROM-FILE WITH-OUTPUT-TO-FILE
	OPEN-INPUT-FILE OPEN-OUTPUT-FILE OPEN-FILE MAKE-FILE-PORT
	OPEN-INPUT-STRING OPEN-OUTPUT-STRING
	CLOSE-INPUT-PORT CLOSE-OUTPUT-PORT CLOSE-PORT
	DEFINE-SYSTEM-FILE-TASK WAIT-SYSTEM-FILE ENABLE-SYSTEM-FILE-TASKS))

;;; 6.10.  Input and Output
;;;
;;; All I/O is done to and from "ports", where a port is an object that can
;;; read and write characters.  A port is represented as  (PORT . proc)
;;; where the symbol "PORT" identifies the object, and the procedure "proc"
;;; implements the operations.  This is but one example where closures provide
;;; an elegant, simple solution.  Needless to say, if a more general object
;;; based system is later implemented, the I/O system should be rewritten
;;; using it.
;;;
;;; The function MAKE-STRING-PORT makes a port which allows expressions to be
;;; read from a string, and MAKE-FILE-PORT makes a port which allows
;;; expressions to be read from a file.  Each time an I/O operation is done,
;;; the port's procedure is invoked.  It is called with a symbol which is the
;;; method needed and a procedure which performs that method is returned.  That
;;; procedure is then called with the appropriate arguments to perform the
;;; operation and return the result.  If the desired method does not exist,
;;; then #F should be returned.  The required methods for all ports are:
;;;
;;;  METHOD     ARGUMENTS         OPERATION & RESULT
;;;
;;; CLOSE-PORT    -		close port for all I/O, result is unspecified
;;;
;;; If the port supports input, then it must provide the following methods:
;;;
;;; READ-CHAR	  -		next input character or EOF-OBJECT
;;; PEEK-CHAR     -		"peek" at the next character, or EOF-OBJECT
;;; CHAR-READY?	  -		boolean indicating that an input character is
;;;				available
;;;
;;; Ports which support output must provide the following methods:
;;;
;;; WRITE-CHAR    character     output the character, result is unspecified
;;; WRITE-TOKEN	  token		output the token (character, string, or list
;;;				of characters).  If the token will not fit
;;;				in the current line, then it will start a new
;;;				line.
;;; WRITE-WIDTH   -		number of characters per line
;;; WRITE-WIDTH!  number	sets the number of characters per line, result
;;;				is unspecified
;;; WRITE-COUNT	  -		number of characters on current line
;;; WRITE-FLUSH   -		flush buffers, result is unspecified
;;;
;;; Some ports support the following additional methods:
;;;
;;; ECHO	  -             port that I/O is echoed to (or #f)
;;; ECHO!	  port/#F	sets I/O echo port
;;; FILE-PORT	  -		Stdio library FILE for the port.

;;; External declarations for Standard I/O Subroutines

(define-c-external STDIN pointer "sc_stdin")

(define-c-external STDOUT pointer "sc_stdout")

(define-c-external STDERR pointer "sc_stderr")

(define-c-external (FOPEN pointer pointer) pointer "fopen")

(define-c-external (FCLOSE pointer) int "fclose")

(define-c-external (FFLUSH pointer) int "fflush")

(define-c-external (FILENO pointer) int "sc_fileno")

(define-c-external (FGETC pointer) int "fgetc")

(define-c-external (CLEARERR pointer) int "sc_clearerr")

(define-c-external (FEOF pointer) int "sc_feof")

(define-c-external (FERROR pointer) int "sc_ferror")

(define-c-external (FPUTC int pointer) int "fputc")

(define-c-external (INPUT-CHARS? pointer) int "sc_inputchars")

(define-c-external (BUFFERED-CHARS? pointer) int "sc_bufferedchars")

(define-c-external ERRNO int "errno")

(define-c-external LIBC-EOF int "sc_libc_eof")

(define-c-external (SELECT int pointer pointer pointer pointer) int "select")

;;; 6.10.1  Ports

(define (CALL-WITH-INPUT-FILE filename proc)
    (if (not (procedure? proc))
	(error 'CALL-WITH-INPUT-FILE "Argument is not a PROCEDURE: ~s" proc))
    (let* ((port (open-file filename "r"))
	   (result (proc port)))
	  (close-port port)
	  result))

(define (CALL-WITH-OUTPUT-FILE filename proc)
    (if (not (procedure? proc))
        (error 'CALL-WITH-OUTPUT-FILE "Argument is not a PROCEDURE: ~s" proc))
    (let* ((port (open-file filename "w"))
	   (result (proc port)))
	  (close-port port)
	  result))

(define (INPUT-PORT? x)
    (if (and (pair? x) (eq? (car x) 'port) (procedure? (cdr x))
	     ((cdr x) 'read-char))
	#t
	#f))

(define (OUTPUT-PORT? x)
    (if (and (pair? x) (eq? (car x) 'port) (procedure? (cdr x))
	     ((cdr x) 'write-char))
	#t
	#f))

;;; The current input and output ports are kept in the following two cells.
;;; Initially the input port uses stdin and the output port uses stdout.

(define CURRENT-INPUT-PORT-VALUE (make-file-port stdin "r"))

(define CURRENT-OUTPUT-PORT-VALUE (make-file-port stdout "w"))

(define STDIN-PORT current-input-port-value)

(define STDOUT-PORT current-output-port-value)

(define STDERR-PORT (make-file-port stderr "w"))

(define (CURRENT-INPUT-PORT) current-input-port-value)

(define (CURRENT-OUTPUT-PORT) current-output-port-value)

(define (WITH-INPUT-FROM-FILE filename proc)
    (let ((old-input-port (current-input-port))
	  (result '()))
	 (if (not (procedure? proc))
	     (error 'WITH-INPUT-FROM-FILE "Argument is not a PROCEDURE: ~s"
		    proc))
	 (set! current-input-port-value (open-file filename "r"))
	 (set! result (proc))
	 (close-port current-input-port-value)
	 (set! current-input-port-value old-input-port)
	 result))

(define (WITH-OUTPUT-TO-FILE filename proc)
    (let ((old-output-port (current-output-port))
	  (result '()))
	 (if (not (procedure? proc))
	     (error 'WITH-OUTPUT-TO-FILE "Argument is not a PROCEDURE: ~s"
		    proc))
	 (set! current-output-port-value (open-file filename "w"))
	 (set! result (proc))
	 (close-port current-output-port-value)
	 (set! current-output-port-value old-output-port)
	 result))

(define (OPEN-INPUT-FILE filename) (open-file filename "r"))

(define (OPEN-OUTPUT-FILE filename) (open-file filename "w"))

;;; The following function does the actual file opening.  It uses UNIX's fopen
;;; and supports the various open types.  See the man page fopen(3s) for
;;; more information.  The filename and type are expected to be strings and the
;;; return value of the function is a port.

(define (OPEN-FILE filename type)
    (let ((file '()))
	 (if (not (string? filename))
	     (error 'FILENAME->FILE "Argument is not a STRING: ~s" filename))
	 (set! file (fopen filename type))
	 (if (zero? file)
	     (error 'FILENAME->FILE "Unable to open file ~s" filename))
	 (let ((port (make-file-port file type)))
	      (when-unreferenced port close-port)
	      port)))

;;; The following function is used to make a port which is does I/O to a UNIX
;;; file.  It takes a file pointer (as a Scheme number) and the type string
;;; that was used to fopen the file initially.

(define (MAKE-FILE-PORT file type)
    (letrec ((charcnt 0)
	     (width 80)
	     (echo-port #f)
	     (nextchar #f)

	     (write-char (lambda (char)
				 (if (char<? char #\space)
				     (cond ((memq char
						  '(#\linefeed #\return
						    #\newline))
					    (set! charcnt 0))
					   ((eq? char #\tab)
					    (set! charcnt
						  (+ charcnt
						     (- 8
							(remainder charcnt
							           8)))))
					   (else (set! charcnt (+ charcnt 1))))
				     (set! charcnt (+ charcnt 1)))
				 (if (eq? (fputc (char->integer char) file)
					  libc-eof)
				     (error 'MAKE-FILE-PORT
					    "I/O error ~s on output"
					    (ferror file)))))

	     (write-token (lambda (token)
				  (cond ((char? token)
					 (write-char token))
					((or (pair? token) (null? token))
					 (for-each write-char token))
					(else
					 (let ((len (string-length token)))
					      (do ((i 0 (+ i 1)))
						  ((= i len))
						  (write-char
						      (string-ref
							  token i))))))))

	     (read-char (lambda ()
				(cond (nextchar
				       (let ((c nextchar))
					    (set! nextchar #f)
					    c))
				      (else
				       (if (and (not (eq? system-file-mask 0))
				                (eq? (buffered-chars? file) 0))
					   (wait-system-file (fileno file)))
				       (let ((char (fgetc file)))
					    (if (eq? char libc-eof)
						(if (feof file)
						    (begin (clearerr file)
							   $_eof-object)
						    (error 'MAKE-FILE-PORT
							 "I/O error ~s on port"
							 (ferror file)))
						(integer->char char)))))))

	     (peek-char (lambda ()
				(if nextchar
				    nextchar
				    (set! nextchar (read-char)))))

	     (read-char-echo (lambda ()
				     (let ((char (read-char)))
					  (if (not (eof-object? char))
					      (((cdr echo-port) 'write-char)
					       char))
					  char)))

	     (char-ready? (lambda ()
				  (if (or nextchar (eq? (input-chars? file) 1))
				      #t
				      #f)))

	     (close-port (lambda ()
				 (fflush file)
				 (fclose file)))

	     (write-char-echo (lambda (char)
				      (write-char char)
				      (((cdr echo-port) 'write-char) char)))

	     (write-token-echo (lambda (token)
				       (write-token token)
				       (((cdr echo-port) 'write-token) token)))

	     (write-count (lambda () charcnt))

	     (write-width (lambda () width))

	     (write-width! (lambda (w) (set! width w)))

	     (write-flush (lambda () (fflush file)))

	     (echo (lambda () echo-port))

	     (echo! (lambda (p) (set! echo-port p)))

	     (file-port (lambda () file)))

	 (cond ((equal? type "r")
		(set! write-char-echo #f)
		(set! write-char #f))
	       ((equal? type "w")
		(set! read-char-echo #f)
		(set! read-char #f)))	     
	 (cons 'port
	       (lambda (method)
		       (case method
		             ((close-port)     close-port)
			     ((read-char)      (if echo-port
						   read-char-echo
						   read-char))
			     ((peek-char)      peek-char)
			     ((char-ready?)    char-ready?)
			     ((write-char)     (if echo-port
						   write-char-echo
						   write-char))
			     ((write-token)    (if echo-port
						   write-token-echo
						   write-token))
			     ((write-width)    write-width)
			     ((write-width!)   write-width!)
			     ((write-count)    write-count)
			     ((write-flush)    write-flush)
			     ((echo) 	       echo)
			     ((echo!)	       echo!)
			     ((file-port)      file-port)
			     (else #f))))))

;;; The following function turns a string into an input port and thus allows
;;; Scheme expressions to be read from strings.  It is as defined in Chez
;;; Scheme.
    
(define (OPEN-INPUT-STRING string)
    (letrec ((nextchar 0)
	     (strlen   (string-length string))

	     (read-char (lambda ()
				(if (= nextchar strlen)
				    $_eof-object
				    (let ((char
					       (string-ref string nextchar)))
					 (set! nextchar (+ 1 nextchar))
					 char))))
	     
	     (peek-char (lambda () (if (= nextchar strlen)
				       $_eof-object
				       (string-ref string nextchar))))
	     (true (lambda () #t)))
	    
	    (cons 'port
		  (lambda (method)
			  (case method
				((read-char)   read-char)
				((peek-char)   peek-char)
				((char-ready?) true)
				((close-port)  true)
				(else #f))))))

;;; The following function is used to make a port which does I/O to a string.
;;; It is as defined in Chez Scheme.

(define (OPEN-OUTPUT-STRING)
    (letrec ((chars '())
	     (width 80)

	     (write-token (lambda (token)
				  (cond ((char? token)
					 (set! chars (cons token chars)))
					((or (pair? token) (null? token))
					 (set! chars
					       (append (reverse token)
						       chars)))
					(else
					 (set! chars
					       (append (reverse (string->list
								    token))
						       chars))))))
	     (get-output-string (lambda ()
					(let ((s (list->string
						     (reverse chars))))
					     (set! chars '())
					     s)))
	     
	     (write-char (lambda (char)
				 (set! chars (cons char chars))))
	     
	     (write-width (lambda () width))

	     (write-width! (lambda (w) (set! width w)))
	     
	     (write-count (lambda () (length chars))))
	    
	    (cons 'port
		  (lambda (method)
			  (case method
				((write-token)       write-token)
				((write-char)        write-char)
				((write-width)       write-width)
				((write-width!)      write-width!)
				((write-count)       write-count)
				((get-output-string) get-output-string)
				(else #f))))))

(define (CLOSE-INPUT-PORT port) (close-port port))

(define (CLOSE-OUTPUT-PORT port) (close-port port))

(define (CLOSE-PORT port)
    (if (and (not (input-port? port)) (not (output-port? port)))
	(error 'CLOSE-PORT "Argument is not a PORT: ~s" port))
    (when-unreferenced port #f)
    (((cdr port) 'close-port)))

;;; When there are no characters available on a port, the I/O system executes
;;; the idle task associated with each system file and then dispatches system
;;; tasks or continues reading from the port when some read completes.  N.B:
;;;    (1) System file tasks never interrupt an executing Scheme program.
;;;    (2) System file tasking is disabled while in the debugger.
;;;    (3) All pending system file tasks are executed before continuing reads
;;;        from the port.

(define SYSTEM-TASKING #t)

(define SYSTEM-FILE-MASK 0)

(define MAX-SYSTEM-FILE -1)

(define SYSTEM-FILE-TASK #f)

(define IDLE-TASKS (make-vector 32 #f))

(define FILE-TASKS (make-vector 32 #f))

;;; A task is associated with a system file number by the following procedure.
;;; A task is deleted by passing #F for each task procedure.

(define (DEFINE-SYSTEM-FILE-TASK file idle-task file-task)
    (vector-set! idle-tasks file idle-task)
    (vector-set! file-tasks file file-task)
    (set! system-file-mask 0)
    (set! max-system-file -1)
    (do ((i 0 (+ 1 i)))
	((= i 32))
	(when (vector-ref file-tasks i)
	      (set! max-system-file i)
	      (set! system-file-mask (bit-or system-file-mask (bit-lsh 1 i)))))
    file)

;;; A task waits for input on a file by calling the following procedure with
;;; the system file number, or #f.  When input is available on the file (<> #f)
;;; or all tasks have completed, the procedure returns.

(define (WAIT-SYSTEM-FILE file)
    (if (and (not (eq? system-file-mask 0)) system-tasking)
	(let ((x (make-string 4)))
	     (if (eq? file 0) (flush-buffer stdout-port))
	     (do ((i 0 (+ i 1)))
		 ((> i max-system-file))
		 (if (vector-ref idle-tasks i) ((vector-ref idle-tasks i))))
	     (c-unsigned-set! x 0
		 (bit-or system-file-mask (if file (bit-lsh 1 file) 0)))
	     (if (eq? (select (+ (max max-system-file (or file 0)) 1) x 0 0 0)
		      -1)
		 (if (eq? errno 4)
		     (wait-system-file file)
		     (error 'wait-system-file "Select error: ~s" errno)))
	     (let ((inputs (c-unsigned-ref x 0)))
		  (do ((i 0 (+ i 1))
		       (mask 1 (bit-lsh mask 1)))
		      ((> i max-system-file))
		      (if (not (eq? 0 (bit-and mask inputs)))
			  (let ((task (vector-ref file-tasks i)))
			       (when task
				     (set! system-file-task i)
				     (task)))))
		  (set! system-file-task #f)
		  (if (or (not file) (zero? (bit-and inputs (bit-lsh 1 file))))
		      (wait-system-file file))))))

;;; System file tasking is enabled and disabled by the following procedure.
;;; It returns the previous state of system file tasking.  When called with
;;; WAIT as its argument, it will not return until all system file tasks have
;;; completed.

(define (ENABLE-SYSTEM-FILE-TASKS enable)
    (let ((prev system-tasking))
	 (set! system-tasking (if enable #t #f))
	 (if (eq? enable 'wait) (wait-system-file #f))
	 prev))