272 lines
8.9 KiB
Scheme
272 lines
8.9 KiB
Scheme
;;; 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))
|