scsh-0.5/scsh/tty.scm

;;; 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. See file COPYING.
;;; Rehacked by Olin 8/95.

(foreign-source
 "#include <sys/types.h>"
 ""
 "#include <unistd.h>"
 "#include <errno.h>"
 "#include <termios.h>"
 ""
 "/* Make sure foreign-function stubs interface to the C funs correctly: */"
 "#include \"tty1.h\""
 ""
 "#define errno_or_false(x) (((x) == -1) ? ENTER_FIXNUM(errno) : SCHFALSE)"
  "#define errno_on_zero_or_false(x) ((x) ? SCHFALSE : ENTER_FIXNUM(errno))"
 "" )


;;; 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
  input-speed-code
  output-speed
  output-speed-code
  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:min 		set-%tty-info:min)
(define set-tty-info:time 		set-%tty-info:time)

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

;;; Encode the speeds at assignment time.
(define (set-tty-info:input-speed info speed)
  (set-%tty-info:input-speed-code info (encode-baud-rate speed))
  (set-%tty-info:input-speed      info speed))

(define (set-tty-info:output-speed info speed)
  (set-%tty-info:output-speed-code info (encode-baud-rate speed))
  (set-%tty-info:output-speed      info speed))

(define (modify-tty-info:input-speed info proc)
  (set-tty-info:input-speed info (proc (tty-info:input-speed info))))

(define (modify-tty-info:output-speed info proc)
  (set-tty-info:output-speed info (proc (tty-info:output-speed info))))

(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 (encode-baud-rate ispeed)
		  ospeed (encode-baud-rate 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:input-speed-code  info)
		  (tty-info:output-speed       info)
		  (%tty-info:output-speed-code info)
		  (tty-info:min		       info)
		  (tty-info:time	       info)))
		  


(define (sleazy-call/file tty opener proc)
  (if (string? tty) (opener tty proc)
      (sleazy-call/fdes tty proc)))

;;; (tty-info [fd/port/fname])
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Retrieve tty-info bits from a tty. Arg defaults to current input port.

;;; I don't understand why, but somehow returning 10 values from a 
;;; define-foreign function seems to corrupt the stack. ??? See tty-bug
;;; for more details. As a workaround, we don't use %tty-info/errno.
;;; Instead, we have an alternate entry point, %bogus-tty-info/errno,
;;; which passes in a 10-elt vector into which the results are stored.
;;; Yech. I have no idea what has tickled this bug in S48 0.36. I hope
;;; if we port up to a modern S48, it'll go away. -Olin

;;; Actually, I subsequently discovered that adding an extra, unused binding
;;; to the LET, cures the problem. So I backed out the really horrible code
;;; and did that. -Olin

(define (tty-info . maybe-tty)
  (let ((control-chars (make-string num-ttychars))
	(bogus #f))
    (receive (iflag-hi8 iflag-lo24 oflag-hi8 oflag-lo24
	      cflag-hi8 cflag-lo24 lflag-hi8 lflag-lo24
	      ispeed-code ospeed-code)
	(sleazy-call/file (:optional maybe-tty (current-input-port))
			  call-with-input-file
			  (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)
		      (decode-baud-rate ispeed-code) ispeed-code
		      (decode-baud-rate ospeed-code) ospeed-code
		      (char->ascii (string-ref control-chars ttychar/min))
		      (char->ascii (string-ref control-chars ttychar/time))))))

;(define (tty-info . maybe-tty)
;  (receive (iflag-hi8 iflag-lo24 oflag-hi8 oflag-lo24
;		      cflag-hi8 cflag-lo24 lflag-hi8 lflag-lo24
;		      ispeed-code ospeed-code control-chars)
;      (sleazy-call/file (:optional maybe-tty (current-input-port))
;			call-with-input-file
;			(lambda (fd) (%tty-info fd (make-string num-ttychars))))
;    (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)
;		    (decode-baud-rate ispeed-code) ispeed-code
;		    (decode-baud-rate ospeed-code) ospeed-code
;		    (char->ascii (string-ref control-chars ttychar/min))
;		    (char->ascii (string-ref control-chars ttychar/time)))))

;(define (%tty-info fdes cc)
;  (receive (v1 v2 v3 v4 v5 v6 v7 v8 v9 v10) (%real-tty-info fdes cc)
;    (values v1 v2 v3 v4 v5 v6 v7 v8 v9 v10 cc)))

(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-code ospeed-code)

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

(define-foreign %bogus-tty-info/errno
  ("scheme_tcgetattrB" (integer fdes)
                       (var-string control-chars)
		       (vector-desc ivec))
  (to-scheme integer errno_or_false))

(define-errno-syscall (%bogus-tty-info fdes control-chars ivec)
  %bogus-tty-info/errno)
  
(define (%%bogus-tty-info fd control-chars)
  (let ((ivec (make-vector 10)))
    (%bogus-tty-info fd control-chars ivec)
    ivec))

;(define (%tty-info fdes cc)
;  (let ((ivec (%%bogus-tty-info fdes cc)))
;    (values (vector-ref ivec 0) (vector-ref ivec 1)
;	    (vector-ref ivec 2) (vector-ref ivec 3)
;	    (vector-ref ivec 4) (vector-ref ivec 5)
;	    (vector-ref ivec 6) (vector-ref ivec 7)
;	    (vector-ref ivec 8) (vector-ref ivec 9)
;	    cc)))

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

(define (set-tty-info tty 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-code  info))
	(os (%tty-info:output-speed-code 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)))
      (sleazy-call/file tty call-with-input-file
        (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-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-code ospeed-code
				     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-code) 
		    (integer ospeed-code)
		    (integer min)
		    (integer time))
  (to-scheme integer errno_or_false))


;;; Exported procs
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Note that the magic %set-tty-info/foo constants must be defined before this
;;; file is loaded due to the set-tty-info/foo definitions below.

(define (make-tty-info-setter how)
  (lambda (tty info) (set-tty-info tty how info)))

(define set-tty-info/now   (make-tty-info-setter %set-tty-info/now))
(define set-tty-info/drain (make-tty-info-setter %set-tty-info/drain))
(define set-tty-info/flush (make-tty-info-setter %set-tty-info/flush))


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

(define (send-tty-break . args) ; [tty duration]
  (let-optionals args ((tty (current-output-port))
		       (duration 0))
    (sleazy-call/file tty call-with-output-file
      (lambda (fdes)
	(%send-tty-break-fdes fdes duration)))))

(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 . maybe-tty)
  (let ((tty (:optional maybe-tty (current-output-port))))
    (cond ((integer? tty) (%tcdrain tty))	; File descriptor.
	  ((fdport? tty)			; Scheme port -- flush first.
	   (force-output tty)
	   (sleazy-call/fdes tty %tcdrain))
	  ((string? tty)			; file name
	   (call-with-output-file tty
	     (lambda (p) (sleazy-call/fdes p %tcdrain))))
	  (else (error "Illegal argument to DRAIN-TTY" tty)))))

(define-errno-syscall (%tcdrain fdes) %tcdrain/errno)
(define-foreign %tcdrain/errno (tcdrain (integer fdes)) no-declare ; Ultrix
  (to-scheme integer errno_or_false))


;;; Flushing the device queues. (tcflush)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Note that the magic %flush-tty/foo constants must be defined before this
;;; file is loaded due to the flush-tty/foo definitions below.

(define (make-input-tty-flusher flag)
  (lambda maybe-tty
    (sleazy-call/file (:optional maybe-tty (current-input-port))
		      call-with-input-file
		      (lambda (fdes) (%tcflush fdes flag)))))

(define (make-output-tty-flusher flag)
  (lambda maybe-tty
    (sleazy-call/file (:optional maybe-tty (current-output-port))
		      call-with-output-file
		      (lambda (fdes) (%tcflush fdes flag)))))

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

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


;;; Stopping and starting I/O (tcflow)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Note that the magic %tcflow/foo constants must be defined before this
;;; file is loaded due to the definitions below.

(define (make-input-flow-controller action)
  (lambda maybe-tty
    (sleazy-call/file (:optional maybe-tty (current-input-port))
		      call-with-input-file
		      (lambda (fdes) (%tcflow fdes action)))))

(define (make-output-flow-controller action)
  (lambda maybe-tty
    (sleazy-call/file (:optional maybe-tty (current-output-port))
		      call-with-output-file
		      (lambda (fdes) (%tcflow fdes action)))))

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

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

(define-foreign %tcflow/errno
  (tcflow (integer fdes) (integer action)) no-declare ; Ultrix
  (to-scheme integer errno_or_false))


;;; Baud rate translation
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; We should just move these guys out to the tty-consts file.
;;; We currently search a vector of (code . speed) pairs.

(define (encode-baud-rate speed)	; 9600 -> value of BAUD/9600
  (do ((i (- (vector-length baud-rates) 1) (- i 1)))
      ((eqv? (cdr (vector-ref baud-rates i)) speed)
       (car (vector-ref baud-rates i)))
    (if (< i 0) (error "Unknown baud rate." speed))))

(define (decode-baud-rate code)		; BAUD/9600 -> 9600
  (do ((i (- (vector-length baud-rates) 1) (- i 1)))
      ((eqv? (car (vector-ref baud-rates i)) code)
       (cdr (vector-ref baud-rates i)))
    (if (< i 0) (error "Unknown baud rate code." code))))


;;; Set/Get tty process group
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define (set-tty-process-group tty proc-group)
  (sleazy-call/file tty call-with-input-file
    (lambda (fd)
      (%set-tty-process-group fd (if (integer? proc-group)
				     proc-group
				     (proc:pid proc-group))))))

(define-errno-syscall (%set-tty-process-group fdes pid)
  %set-tty-process-group/errno)

(define-foreign %set-tty-process-group/errno (tcsetpgrp (fixnum fdes)
						        (pid_t pid))
  no-declare				; Ultrix
  (to-scheme integer errno_or_false))

(define (tty-process-group tty)
  (sleazy-call/file tty call-with-input-file %tty-process-group))

(define-errno-syscall (%tty-process-group fd) %tty-process-group/errno
  pid)

(define-foreign %tty-process-group/errno (tcgetpgrp (fixnum fdes))
  no-declare				; Ultrix
  (multi-rep (to-scheme pid_t errno_or_false)
             pid_t))

;;; (open-control-tty fname [flags])
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Open a control tty, return a port.
;;; This procedure is only guaranteed to work when the process doesn't already
;;; have a control tty -- e.g., right after a (BECOME-PROCESS-LEADER) call.
;;; This limted functionality is about all we can provide portably across BSD,
;;; SunOS, and SVR4.

(define (open-control-tty ttyname . maybe-flags)
  (let ((flags (:optional maybe-flags open/read+write)))
    (let lp ()
      (receive (errno fd) (open-control-tty/errno ttyname flags)
	(cond ((not errno)
	       (let ((access (bitwise-and flags open/access-mask)))
		 ((if (or (= access open/read)
			  (= access open/read+write))
		      make-input-fdport
		      make-output-fdport)
		  fd 1)))
	      ((= errno/intr errno) (lp))
	      (else (errno-error errno open-control-tty ttyname flags)))))))

(define-foreign open-control-tty/errno (open_ctty (string ttyname)
						  (fixnum flags))
  (multi-rep (to-scheme integer errno_or_false)
             integer))


;;; Random bits & pieces: isatty ttyname ctermid
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; (tty? fd/port) -> boolean
;;; (tty-file-name fd/port) -> string
;;; (control-tty-file-name) -> string

(define-foreign %tty? (isatty (integer fd)) bool)
(define (tty? fd/port) (sleazy-call/fdes fd/port %tty?))


(define-foreign %tty-file-name/errno (ttyname (integer fd))
  (multi-rep (to-scheme static-string errno_on_zero_or_false)
	     static-string))
(define-errno-syscall (%tty-file-name fd) %tty-file-name/errno
  tty-name)
(define (tty-file-name fd/port) (sleazy-call/fdes fd/port %tty-file-name))


(define-foreign %ctermid/errno (scm_ctermid)
  (multi-rep (to-scheme static-string errno_on_zero_or_false)
	     static-string))

(define-errno-syscall (control-tty-file-name) %ctermid/errno term-name)