;;; 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 scrt6
    (top-level
	READ READ-CHAR PEEK-CHAR CHAR-READY? EOF-OBJECT?
	WRITE DISPLAY WRITE-CHAR NEWLINE FLUSH-BUFFER GET-OUTPUT-STRING
	WRITE-COUNT WRITE-WIDTH SET-WRITE-WIDTH!
	ECHO TRANSCRIPT-ON TRANSCRIPT-OFF PORT->STDIO-FILE
	ERROR *ERROR-HANDLER* FORMAT RESET EXIT PROCEED PP))

;;; External declarations for Standard I/O Subroutines

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

(define-c-external (UNIX_EXIT int) int "exit")

(define-c-external (FPRINTF pointer pointer pointer) int "fprintf")

(define-external (READ-DATUM port) scrt7)

(define-external (WRITE/DISPLAY obj readable port) scrt7)

(define-external (CLEANUP-UNREFERENCED) scrt4)

(include "repdef.sc")

;;; 6.10.2. Input

;;; Verify that an optional input port was supplied, and return the procedure
;;; to acquire the port methods.  Flush stdout if working with stdin and it
;;; has pending operations.

(define PENDING-STDOUT #f)

(define (INPUT-PORT func pl)
    (let ((port (if pl
		    (let ((port (car pl)))
			 (if (not (input-port? port))
			     (error func "Argument is not an INPUT-PORT: ~s"
				    port)
			     port))
		    (current-input-port))))
	 (if (and (eq? port stdin-port) pending-stdout)
	     (flush-buffer stdout-port))
	 (cdr port)))
    
(define (READ . port) (read-datum (input-port 'read port)))

(define (READ-CHAR . port) (((input-port 'read-char port) 'read-char)))

(define (PEEK-CHAR . port) (((input-port 'peek-char port) 'peek-char)))

(define (CHAR-READY? . port) (((input-port 'char-ready? port) 'char-ready?)))

(define (EOF-OBJECT? obj) (eq? obj $_eof-object))

;;; 6.10.3. Output

;;; Verify that an optional output port was supplied, and return the procedure
;;; to acquire the port methods.

(define (OUTPUT-PORT func pl)
    (let ((port (if pl
		    (let ((port (car pl)))
			 (if (not (output-port? port))
			     (error func "Argument is not an OUTPUT-PORT: ~s"
				    port)
			     port))
		    (current-output-port))))
	 (cond ((and (eq? port stderr-port) pending-stdout)
		(flush-buffer stdout-port))
	       ((eq? port stdout-port)
		(set! pending-stdout (not (eq? func 'flush-buffer)))))
	 (cdr port)))

(define (WRITE obj . port)
    (write/display obj #t (output-port 'write port)))

(define (DISPLAY obj . port)
    (write/display obj #f (output-port 'display port)))

(define (WRITE-CHAR char . port)
    (if (not (char? char))
	(error 'WRITE-CHAR "Argument is not a CHARACTER: ~s" char))
    (((output-port 'write-char port) 'write-char) char))

(define (NEWLINE . port)
    (((output-port 'newline port) 'write-char) #\newline))

(define (FLUSH-BUFFER . port)
    (((output-port 'flush-buffer port) 'write-flush)))
    
(define (GET-OUTPUT-STRING port)
    (let ((s (and (output-port? port) (((cdr port) 'get-output-string)))))
	 (if s
	     s
	     (error 'GET-OUTPUT-STRING
	       "Argument is not an OUTPUT STRING PORT: ~s" port))))

(define (WRITE-COUNT . port)
    (((output-port 'write-count port) 'write-count)))

(define (WRITE-WIDTH . port)
    (((output-port 'write-width port) 'write-width)))

(define (SET-WRITE-WIDTH! width . port)
    (if (or (not (integer? width)) (<= width 0))
	(error 'SET-WRITE-WIDTH! "Argument is not a POSITIVE INTEGER: ~s"
	       width))
    (((output-port 'set-write-width! port) 'write-width!) width))

;;; 6.10.4. User Interface

(define (ECHO port . argl)
    (if (and (not (input-port? port)) (not (output-port? port)))
	(error 'ECHO "Argument is not a port: ~s" port))
    (if (not ((cdr port) 'echo))
	(error 'ECHO "Port does not support ECHO: ~s" port))
    (if argl
	(let ((echo-port (car argl)))
	     (if (and echo-port (not (output-port? echo-port)))
		 (error 'ECHO "Argument is not an OUTPUT PORT or #F: ~s"
			echo-port))
	     (if (equal? port echo-port)
		 (error 'ECHO "PORT cannot be echoed to itself: ~s"
			echo-port))
	     (((cdr port) 'echo!) echo-port))
	(((cdr port) 'echo))))

(define (TRANSCRIPT-ON filename)
    (if (or (echo stdin-port) (echo stdout-port))
	(error 'TRANSCRIPT-ON "A TRANSCRIPT is already in progress"))
    (let ((port (open-file filename "w")))
	 (echo stdin-port port)
	 (echo stdout-port port)
	 'transcript-on))

(define (TRANSCRIPT-OFF)
    (let ((input-echo (echo stdin-port))
	  (output-echo (echo stdout-port)))
	 (if (not (equal? input-echo output-echo))
	    (error 'TRANSCRIPT-OFF "A TRANSCRIPT is not in progress"))
	 (echo stdin-port #f)
	 (echo stdout-port #f)
	 (close-port input-echo)))

(define (PORT->STDIO-FILE port)
    (if (or (input-port? port) (output-port? port))
	(let ((method ((cdr port) 'file-port)))
	     (if method (method) #f))
	(error 'PORT->STDIO-FILE "Argument is not a port: ~s" port)))

;;; This section provides the general error reporting function and I/O
;;; formatting.  It is heavily influenced by Chez Scheme.

(define (ERROR symbol format-string . args)
    (let ((flag *error-handler*))
	 (cond ((procedure? flag)
		(set! *error-handler* #t)
		(apply flag (cons symbol (cons format-string args))))
	       (flag
		(set! *error-handler* #f)
		(error-display '*****\ \i\n\s\i\d\e\ ERROR)
		(do ((arg (cons symbol (cons format-string args))
			  (cdr arg)))
		    ((null? arg)
		     (error-display #\newline)
		     (unix_exit  1))
		    (error-display #\space)
		    (error-display (car arg))))
	       (else
		(error-display "***** ERROR error handler failed!")
		(error-display #\newline)
		(unix_exit 1)))))

(define (ERROR-DISPLAY item)
    (if (symbol? item) (set! item (symbol->string item)))
    (cond ((char? item)
	   (fprintf stderr "%c" (char->integer item)))
	  ((string? item)
	   (fprintf stderr "\"%s\"" item))
	  ((fixed? item)
	   (fprintf stderr "%d" item))
	  (else
	   (fprintf stderr "%x" ((lap (x) (INT_TSCP (INT x))) item)))))
    
(define (DEFAULT-ERROR-HANDLER id format-string . args)
    (display (format "***** ~a " id) stderr-port)
    (display (apply format (cons format-string args)) stderr-port)
    (newline stderr-port)
    (set! *error-handler* default-error-handler)
    (reset))

(define *ERROR-HANDLER* default-error-handler)

(define (FORMAT form . args)
    (if (eq? form #t) (set! form (current-output-port)))
    (cond ((and (not form) args (string? (car args)))
	   (let ((port (open-output-string)))
		(formatx port (car args) (cdr args))
		(get-output-string port)))
	  ((string? form)
	   (let ((port (open-output-string)))
		(formatx port form args)
		(get-output-string port)))
	  ((and (output-port? form) args (string? (car args)))
	   (formatx form (car args) (cdr args)))
	  (else (error 'format "Illegal arguments: ~s" (cons form args)))))

(define (FORMATX port form args)
    (let ((arg (lambda ()
		       (if (null? args)
			   (error 'format "Too few ARGUMENTS for ~s" form))
		       (let ((result (car args)))
			    (set! args (cdr args))
			    result))))
	 (do ((i 0 (+ 1 i))
	      (tilde #f)
	      (c #f))
	     ((= i (string-length form))
	      (if tilde
		  (error 'format "FORM ends with a ~~:  ~s" form))
	      (if args
		  (error 'format "Too many ARGUMENTS for ~s" form)))
	     (set! c (string-ref form i))
	     (if tilde
		 (begin (set! tilde #f)
			(case c
			      ((#\~)     (display c port))
			      ((#\%)     (newline port))
			      ((#\s #\S) (write (arg) port))
			      ((#\a #\A) (display (arg) port))
			      ((#\c #\C) (write-char (arg) port))
			      (else (error 'format
					 "Unrecognized OUTPUT DESCRIPTOR in ~s"
					 form))))		   
		 (cond ((eq? c #\~) (set! tilde #t))
		       (else (write-char c port)))))))


(define (DEFAULT-RESET)
    (do ((stp (stacktrace) (c-unsigned-ref stp 0))
	 (procname "")
	 (string-out (open-output-string))
	 (start "SCRT6_DEFAULT-RESET")
	 (lines 20))
	((or (= stp 0) (= lines 0)))
	(set! procname (c-tscp-ref stp 4))
	(cond (start
	       (if (equal? start procname) (set! start #f)))
	      ((not (string? procname))
	       (write (c-tscp-ref stp 8) string-out)
	       (let ((expr (get-output-string string-out)))
		    (if (> (string-length expr) 65)
			(display (string-append
				     (substring expr 0 65)
				     " ...") stderr-port)
			(display expr stderr-port)))
	       (newline stderr-port)
	       (set! lines (- lines 1)))
	      ((member procname
		       '("SCEVAL_INTERPRETED-PROC" "LOOP [inside EXEC]")))
	      (else
	       (display "(" stderr-port)
	       (display procname stderr-port)
	       (display " ...)" stderr-port)
	       (newline stderr-port)
	       (set! lines (- lines 1)))))
    (unix_exit 1))

(define RESET default-reset)
    
(define (DEFAULT-EXIT)
    (unix_exit 0))

(define EXIT default-exit)

(define (DEFAULT-PROCEED . x)
    (if x (unix_exit (car x)) (unix_exit 0)))

(define PROCEED default-proceed)

;;; (PP form [ output ]) pretty-prints the form on the current output port,
;;; another port, or to a file depending upon the value of "output".

(define (PP form . output)
    (cond ((null? output)
	   (pp1 form (current-output-port)))
	  ((output-port? (car output))
	   (pp1 form (car output)))
	  (else
	       (let ((port (open-output-file (car output))))
		    (pp1 form port)
		    (close-output-port port))))
    #t)

(define (PP1 form port)
    (let* ((indent (write-count port))
	   (left (print-in form (- (write-width port) indent))))
	  (cond ((negative? left)
		 (cond ((pair? form)
			(display "(" port)
			(pp1 (car form) port)
			(do ((tab (make-string (+ indent 2) #\space))
			     (x (cdr form) (cdr x)))
			    ((not (pair? x))
			     (when x
				   (newline port)
				   (display tab port)
				   (display ". " port)
				   (pp1 x port))
			     (display ")" port))
			    (newline port)
			    (display tab port)
			    (pp1 (car x) port)))
		       ((vector? form)
			(display "#" port)
			(pp1 (vector->list form) port))
		       (else (write form port))))
		(else (write form port)))))		 

;;; PRINT-IN is used to decide if a form can be printed in line-length 
;;; characters.  If it can, then it will return:
;;;    line-length - # characters needed
;;; otherwise it will return a negative number.

(define (PRINT-IN form line-length)
    (cond ((negative? line-length) line-length)
	  ((pair? form)
	   (cond ((null? (cdr form))	;;; End of list
		  (- (print-in (car form) (- line-length 1)) 1))
		 ((pair? (cdr form))	;;; Continued list
		  (print-in (cdr form) (print-in (car form)
					   (- line-length 1))))
		 (else			;;; Dotted pair
		     (print-in (cdr form)
			 (print-in (car form) (- line-length 5))))))
	  ((vector? form)		;;; Vector is 1 longer than its list
	   (print-in (vector->list form) (- line-length 1)))
	  (else				;;; Print to a string port and measure
	      (let ((port (open-output-string)))
		   (write form port)
		   (- line-length (string-length (get-output-string port)))))))