275 lines
9.0 KiB
Scheme
275 lines
9.0 KiB
Scheme
;;; 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)
|