;;; To do:
;;; Add new bindings to scsh-level-0 interface defn.
;;; Magic constant defns.

;;; My comments:
;;; - We have a lot of NeXT-specific stuff. More importantly, what is the
;;;   Linux, Solaris, and HP-UX specific stuff?
;;;
;;; - I would suggest totally flushing the ttychars vector from the interface
;;;   in favor of individual slots in the TTY-INFO record. Keep the vec
;;;   in the implementation, and define the TTY-INFO:EOL, etc. procs by
;;;   hand as being indices into the vector. We could *also* expose the
;;;   vector if we liked.
;;;     -Olin

;;; Terminal Control for the Scheme Shell
;;; Copyright (c) 1995 by Brian D. Carlstrom.
;;; Rehacked by Olin 8/95.

(foreign-source
 "#include <termios.h>"
 ""
 "extern int errno;"
 ""
 "#define errno_or_false(x) (((x) == -1) ? ENTER_FIXNUM(errno) : SCHFALSE)"
 "" )


;;; tty-info records
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; I have to fake out my record package so I can define my very own
;;; MAKE-TTY-INFO procedure. Ech. I oughta have a lower-level record macro
;;; for this kind of thing.

(define-record %tty-info
  control-chars
  input-flags
  output-flags
  control-flags
  local-flags
  input-speed
  output-speed
  min
  time
  ((disclose info) '("tty-info")))

(define tty-info?	%tty-info?)
(define type/tty-info	type/%tty-info)

(define tty-info:control-chars 	%tty-info:control-chars)
(define tty-info:input-flags 	%tty-info:input-flags)
(define tty-info:output-flags 	%tty-info:output-flags)
(define tty-info:control-flags 	%tty-info:control-flags)
(define tty-info:local-flags 	%tty-info:local-flags)
(define tty-info:input-speed 	%tty-info:input-speed)
(define tty-info:output-speed 	%tty-info:output-speed)
(define tty-info:min 		%tty-info:min)
(define tty-info:time 		%tty-info:time)

(define set-tty-info:control-chars 	set-%tty-info:control-chars)
(define set-tty-info:input-flags 	set-%tty-info:input-flags)
(define set-tty-info:output-flags 	set-%tty-info:output-flags)
(define set-tty-info:control-flags 	set-%tty-info:control-flags)
(define set-tty-info:local-flags 	set-%tty-info:local-flags)
(define set-tty-info:input-speed 	set-%tty-info:input-speed)
(define set-tty-info:output-speed 	set-%tty-info:output-speed)
(define set-tty-info:min 		set-%tty-info:min)
(define set-tty-info:time 		set-%tty-info:time)

(define (make-tty-info iflags oflags cflags lflags ispeed ospeed min time)
  (make-%tty-info (make-string num-ttychars (ascii->char 0))
		  iflags oflags cflags lflags ispeed ospeed min time))

(define (copy-tty-info info)
  (make-%tty-info (string-copy (tty-info:control-chars info))
		  (tty-info:input-flags	  info)
		  (tty-info:output-flags  info)
		  (tty-info:control-flags info)
		  (tty-info:local-flags	  info)
		  (tty-info:input-speed	  info)
		  (tty-info:output-speed  info)
		  (tty-info:min		  info)
		  (tty-info:time	  info)))
		  

;;; (tty-info fd/port)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Retrieve tty-info bits from a tty.

(define (tty-info fdport)
  (let ((control-chars (make-string num-ttychars)))
    (receive (iflag-hi8 iflag-lo24 oflag-hi8 oflag-lo24
	      cflag-hi8 cflag-lo24 lflag-hi8 lflag-lo24
	      ispeed    ospeed)
	(call/fdes fdport (lambda (fd) (%tty-info fd control-chars)))
      (make-%tty-info control-chars
		      (bitwise-ior (arithmetic-shift iflag-hi8 24) iflag-lo24)
		      (bitwise-ior (arithmetic-shift oflag-hi8 24) oflag-lo24)
		      (bitwise-ior (arithmetic-shift cflag-hi8 24) cflag-lo24)
		      (bitwise-ior (arithmetic-shift lflag-hi8 24) lflag-lo24)
		      ispeed ospeed
		      (char->ascii (string-ref control-chars ttychar/min))
		      (char->ascii (string-ref control-chars ttychar/time))))))

(define-errno-syscall (%tty-info fdes control-chars) %tty-info/errno
  iflag-hi8 iflag-lo24
  oflag-hi8 oflag-lo24
  cflag-hi8 cflag-lo24
  lflag-hi8 lflag-lo24
  ispeed    ospeed)

(define-foreign %tty-info/errno
  (scheme_tcgetattr (integer fdes)
		    (string  control-chars))
  (to-scheme integer errno_or_false)
  integer integer
  integer integer
  integer integer
  integer integer
  integer integer)


;;; (set-tty-info       fdport option info)	[Not exported]
;;; (set-tty-info/now   fdport option info)
;;; (set-tty-info/drain fdport option info)
;;; (set-tty-info/flush fdport option info)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Assign tty-info bits to a tty.

(define (set-tty-info fdport option info)
  (let ((if (tty-info:input-flags   info))
	(of (tty-info:output-flags  info))
	(cf (tty-info:control-flags info))
	(lf (tty-info:local-flags   info))
	(cc (tty-info:control-chars info))
	(is (tty-info:input-speed   info))
	(os (tty-info:output-speed  info)))
    (let ((iflag-hi8  (arithmetic-shift if -24))
	  (iflag-lo24 (bitwise-and if #xffffff))
	  (oflag-hi8  (arithmetic-shift of -24))
	  (oflag-lo24 (bitwise-and of #xffffff))
	  (cflag-hi8  (arithmetic-shift cf -24))
	  (cflag-lo24 (bitwise-and cf #xffffff))
	  (lflag-hi8  (arithmetic-shift lf -24))
	  (lflag-lo24 (bitwise-and lf #xffffff)))
      (call/fdes fdport
        (lambda (fd)
	  (%set-tty-info fd option
			 cc
			 iflag-hi8 iflag-lo24
			 oflag-hi8 oflag-lo24
			 cflag-hi8 cflag-lo24
			 lflag-hi8 lflag-lo24
			 is        os
			 (tty-info:min  info)
			 (tty-info:time info)))))))

(define-simple-errno-syscall (%set-tty-info fdes      option
					    control-chars
					    iflag-hi8 iflag-lo24
					    oflag-hi8 oflag-lo24
					    cflag-hi8 cflag-lo24
					    lflag-hi8 lflag-lo24
					    ispeed    ospeed
					    min	      time)
  %set-tty-info/errno)

(define-foreign %set-tty-info/errno
  (scheme_tcsetattr (integer fdes)
		    (integer option)
		    (string  control-chars)
		    (integer iflag-hi8)
		    (integer iflag-lo24)
		    (integer oflag-hi8) 
		    (integer oflag-lo24)
		    (integer cflag-hi8) 
		    (integer cflag-lo24)
		    (integer lflag-hi8) 
		    (integer lflag-lo24)
		    (integer ispeed) 
		    (integer ospeed)
		    (integer min)
		    (integer time))
  (to-scheme integer errno_or_false))


;;; Magic Numbers 
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;; <termios.h>
(define %set-tty-info/now	0)	; Make change immediately.
(define %set-tty-info/drain	1)	; Drain output, then change.
(define %set-tty-info/flush	2)	; Drain output, flush input.

;;; Exported procs
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define (set-tty-info/now fd/port info)
  (set-tty-info fd/port %set-tty-info/now info))

(define (set-tty-info/drain fd/port info)
  (set-tty-info fd/port %set-tty-info/drain info))

(define (set-tty-info/flush fd/port info)
  (set-tty-info fd/port %set-tty-info/flush info))


;;; Send a break on the serial line.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define (send-tty-break fdport . maybe-duration)
  (call/fdes fdport
    (lambda (fdes)
      (%send-tty-break-fdes fdes (optional-arg maybe-duration 0)))))

(define-errno-syscall (%send-tty-break-fdes fdes duration)
  %send-tty-break-fdes/errno)

(define-foreign %send-tty-break-fdes/errno
  (tcsendbreak (integer fdes) (integer duration))
  (to-scheme integer errno_or_false))


;;; Drain the main vein.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define (drain-tty fdport)
  (cond ((integer? fdport) (%tcdrain fdport))	; File descriptor.
	((fdport? fdport)			; Scheme port -- flush first.
	 (force-output fdport)
	 (call/fdes fdport %tcdrain))
	(else (error "Illegal argument to DRAIN-TTY" fdport))))

(define-errno-syscall (%tcdrain fdes) %tcdrain/errno)
(define-foreign %tcdrain/errno (tcdrain (integer fdes))
  (to-scheme integer errno_or_false))


;;; Flushing the device queues. (tcflush)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define (make-tty-flusher flag)
  (lambda (fdport)
    (call/fdes fdport (lambda (fdes) (%tcflush fdes flag)))))

(define flush-tty/input  (make-tty-flusher %flush-tty/input))
(define flush-tty/output (make-tty-flusher %flush-tty/output))
(define flush-tty/both   (make-tty-flusher %flush-tty/both))

(define-errno-syscall (%tcflush fdes flag) %tcflush/errno)
(define-foreign %tcflush/errno (tcflush (integer fdes) (integer flag))
  (to-scheme integer errno_or_false))


;;; Stopping and starting I/O (tcflow)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define (make-flow-controller action)
  (lambda (fdport)
    (call/fdes fdport (lambda (fdes) (%tcflow fdes action)))))

(define start-tty-output (make-flow-controller %tcflow/start-out))
(define stop-tty-output  (make-flow-controller %tcflow/stop-out))
(define start-tty-input  (make-flow-controller %tcflow/start-in))
(define stop-tty-input   (make-flow-controller %tcflow/stop-in))

(define-errno-syscall (%tcflow fdes action) %tcflow/errno)

(define-foreign %tcflow/errno
  (tcflow (integer fdes) (integer action))
  (to-scheme integer errno_or_false))