;;; 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 " "" "#include " "#include " "" "/* Make sure foreign-function stubs interface to the C funs correctly: */" "#include \"tty1.h\"" "" "extern int errno;" "" "#define errno_or_false(x) (((x) == -1) ? s48_enter_fixnum(errno) : S48_FALSE)" "#define errno_on_zero_or_false(x) ((x) ? S48_FALSE : s48_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. (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-code ospeed-code) (sleazy-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) (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-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 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-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/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-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 (fdport info) (set-tty-info fdport 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 fdport . maybe-duration) (sleazy-call/fdes fdport (lambda (fdes) (%send-tty-break-fdes fdes (:optional 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) (sleazy-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)) 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-tty-flusher flag) (lambda (fdport) (sleazy-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)) 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-flow-controller action) (lambda (fdport) (sleazy-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)) 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 port/fd proc-group) (sleazy-call/fdes port/fd (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 port/fd) (sleazy-call/fdes port/fd %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)