;;; Terminal Control for the Scheme Shell
;;; Copyright (c) 1995 by Brian D. Carlstrom.

;;; Scheme48 implementation.

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

;;; terminal-info
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define-record terminal-info
  input-flags
  output-flags
  control-flags
  local-flags
  control-chars
  input-speed
  output-speed)

;;; tcgetattr
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (terminal-info fdport)
  (let ((control-chars (make-string cc/nccs)))
    (receive (iflag-hi8 iflag-lo24
			oflag-hi8 oflag-lo24
			cflag-hi8 cflag-lo24
			lflag-hi8 lflag-lo24
			ispeed    ospeed)
	(%tcgetattr (->fdes fdport) control-chars)
      (make-terminal-info (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)
			  control-chars
			  ispeed ospeed))))

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

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

;;; tcsetattr
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (set-terminal-info fdport option info)
  (let ((if (terminal-info:input-flags   info))
	(of (terminal-info:output-flags  info))
	(cf (terminal-info:control-flags info))
	(lf (terminal-info:local-flags   info))
	(cc (terminal-info:control-chars info))
	(is (terminal-info:input-speed   info))
	(os (terminal-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)))
      (%tcsetattr (->fdes fdport) option
		  iflag-hi8 iflag-lo24
		  oflag-hi8 oflag-lo24
		  cflag-hi8 cflag-lo24
		  lflag-hi8 lflag-lo24
		  cc
		  is        os))))

(define-simple-errno-syscall (%tcsetattr fdes      option
				  iflag-hi8 iflag-lo24
				  oflag-hi8 oflag-lo24
				  cflag-hi8 cflag-lo24
				  lflag-hi8 lflag-lo24
				  control-chars
				  ispeed    ospeed)
  %tcsetattr/errno)

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

;;; ->fdes - Peeks at fdes of a port
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (->fdes fdport)
  (cond ((integer? fdport) fdport)
	((input-port?  fdport) 
	 (fdport-data:fd (extensible-input-port-local-data fdport)))
	((output-port? fdport)
	 (fdport-data:fd (extensible-output-port-local-data fdport)))))

;;; Magic Numbers 
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; <sys/termios.h>
(define tc/set-attributes/now	0)	; make change immediate
(define tc/set-attributes/drain	1)	; drain output, then change
(define tc/set-attributes/flush	2)	; drain output, flush input

;;; Special Control Characters 
;;  Index into c_cc[] character array.
;;	Name	     Subscript	Enabled by 

;;  POSIX
(define cc/veof		0)		; icanon
(define cc/veol		1)		; icanon
(define cc/verase	2)		; icanon
(define cc/vkill	3)		; icanon
(define cc/vintr	4)		; isig
(define cc/vquit	5)		; isig
(define cc/vsusp	6)		; isig
(define cc/vstart	7)		; ixon, ixoff
(define cc/vstop	8)		; ixon, ixoff
(define cc/vmin		9)		; !icanon
(define cc/vtime	10)		; !icanon
;;  NeXT
(define cc/vwerase 	11)		; icanon
(define cc/vreprint 	12)		; icanon
(define cc/vlnext	13)		; iexten
(define cc/vdiscard	14)		; iexten
(define cc/vdsusp	15)		; isig
(define cc/vquote	16)		; icanon
;; Number of Control Characters - *Not Exported*
(define	cc/nccs		17)

;;; Input flags - software input processing
;;  POSIX
(define iflag/ignbrk	#x00000001)	; ignore break condition 
(define iflag/brkint	#x00000002)	; map break to sigintr 
(define iflag/ignpar	#x00000004)	; ignore (discard) parity errors 
(define iflag/parmrk	#x00000008)	; mark parity and framing errors 
(define iflag/inpck	#x00000010)	; enable checking of parity errors 
(define iflag/istrip	#x00000020)	; strip 8th bit off chars 
(define iflag/inlcr	#x00000040)	; map nl into cr 
(define iflag/igncr	#x00000080)	; ignore cr 
(define iflag/icrnl	#x00000100)	; map cr to nl (ala crmod) 
(define iflag/ixon	#x00000200)	; enable output flow control 
(define iflag/ixoff	#x00000400)	; enable input flow control 
;;NeXT
(define iflag/ixany	#x00000800)	; any char will restart after stop 
(define iflag/imaxbel	#x00002000)	; ring bell on input queue full 


;;; Output flags - software output processing
;;  POSIX 
(define	oflag/opost	#x00000001)	; enable following output processing 
;;  NeXT
(define oflag/onlcr	#x00000002)	; map nl to cr-nl (ala crmod) 
; use the same bits as old delay flags 
(define	oflag/nldelay	#x00000300)	; \n delay 
(define	 oflag/nl0	#x00000000)
(define	 oflag/nl1	#x00000100)	; tty 37 
(define	 oflag/nl2	#x00000200)	; vt05 
(define	 oflag/nl3	#x00000300)
(define	oflag/tbdelay	#x00000c00)	; horizontal tab delay 
(define	 oflag/tab0	#x00000000)
(define	 oflag/tab1	#x00000400)	; tty 37 
(define	 oflag/tab2	#x00000800)
(define	oflag/xtabs	#x00000c00)	; expand tabs on output 
(define	oflag/crdelay	#x00003000)	; \r delay 
(define	 oflag/cr0	#x00000000)
(define	 oflag/cr1	#x00001000)	; tn 300 
(define	 oflag/cr2	#x00002000)	; tty 37 
(define	 oflag/cr3	#x00003000)	; concept 100 
(define	oflag/vtdelay	#x00004000)	; vertical tab delay 
(define	 oflag/ff0	#x00000000)
(define	 oflag/ff1	#x00004000)	; tty 37 
(define	oflag/bsdelay	#x00008000)	; \b delay 
(define	 oflag/bs0	#x00000000)
(define	 oflag/bs1	#x00008000)
(define	oflag/alldelay	(bitwise-ior 
			 (bitwise-ior 
			  (bitwise-ior oflag/nldelay oflag/tbdelay)
			  (bitwise-ior oflag/crdelay oflag/vtdelay))
			 oflag/bsdelay))

;;; Control flags - hardware control of terminal
;;  NeXT
(define	cflag/cignore	#x00000001)	; ignore control flags 
;;  POSIX
(define cflag/csize	#x00000300)	; character size mask 
(define  cflag/cs5	#x00000000)	; 5 bits (pseudo) 
(define  cflag/cs6	#x00000100)	; 6 bits 
(define  cflag/cs7	#x00000200)	; 7 bits 
(define  cflag/cs8	#x00000300)	; 8 bits 
(define cflag/cstopb	#x00000400)	; send 2 stop bits 
(define cflag/cread	#x00000800)	; enable receiver 
(define cflag/parenb	#x00001000)	; parity enable 
(define cflag/parodd	#x00002000)	; odd parity, else even 
(define cflag/hupcl	#x00004000)	; hang up on last close 
(define cflag/clocal	#x00008000)	; ignore modem status lines 
;;  NeXT
(define cflag/cstopb110	#x00010000)
(define cflag/par0	#x00020000)	; space parity 
(define cflag/par1	#x00040000)	; mark parity 

;;; "Local" flags - dumping ground for other state
;;  Warning: some flags in this structure begin with
;;  the letter "I" and look like they belong in the
;;  input flag.
;;  NeXT
(define lflag/echoke	#x00000001)	; visual erase for line kill 
;;  POSIX
(define lflag/echoe	#x00000002)	; visually erase chars 
(define lflag/echok	#x00000004)	; echo nl after line kill 
(define lflag/echo	#x00000008)	; enable echoing 
(define lflag/echonl	#x00000010)	; echo nl even if echo is off 
(define lflag/icanon	#x00000020)	; canonicalize input lines 
(define lflag/isig	#x00000040)	; enable signals intr, quit, [d]susp 
(define lflag/iexten	#x00000080)	; enable discard and lnext 
;;  NeXT
(define lflag/echocrt	#x00000100)	; visual erase mode for crt 
(define lflag/echoprt	#x00000200)	; visual erase mode for hardcopy 
(define lflag/echoctl  	#x00000400)	; echo control chars as ^(char) 
(define lflag/altwerase	#x00000800)	; use alternate werase algorithm 
(define lflag/mdmbuf	#x00100000)	; flow control output via carrier 
;;  POSIX
(define lflag/tostop	#x00400000)	; stop background jobs from output 
;;  NeXT
(define lflag/xlcase	#x04000000)
(define lflag/xeucbksp	#x08000000)
;;  POSIX
(define lflag/noflsh	#x80000000)	; don't flush after interrupt

;;; Baud Rates
(define baud/0		0)
(define baud/50		1)
(define baud/75		2)
(define baud/110	3)
(define baud/134	4)
(define baud/150	5)
(define baud/200	6)
(define baud/300	7)
(define baud/600	8)
(define baud/1200	9)
(define baud/1800	10)
(define baud/2400	11)
(define baud/4800	12)
(define baud/9600	13)
(define baud/19200	14)
(define baud/38400	15)