diff --git a/scsh/hpux/tty-consts.scm b/scsh/hpux/tty-consts.scm index 42dbdce..75c2655 100644 --- a/scsh/hpux/tty-consts.scm +++ b/scsh/hpux/tty-consts.scm @@ -190,47 +190,17 @@ (define ttyl/case-map #o4) ; xcase: canonical upper/lower presentation -;;; 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/900 9) ; Non-standard -(define baud/1200 10) -(define baud/1800 11) -(define baud/2400 12) -(define baud/3600 13) ; Non-standard -(define baud/4800 14) -(define baud/7200 15) ; Non-standard -(define baud/9600 16) -(define baud/19200 17) -(define baud/38400 18) -(define baud/57600 19) ; Non-standard -(define baud/115200 20) ; Non-standard -(define baud/230400 21) ; Non-standard -(define baud/460800 22) ; Non-standard -(define baud/exta 30) ; Non-standard -(define baud/extb 31) ; Non-standard +;;; Vector of (speed . code) pairs. -;;; Rather cheesy mechanism here. -;;; Vector of lists because some OS's define EXTA and EXTB to be -;;; the same code as 19.2k and 38.4k baud. - -(define baud-rates '#((0) (50) (75) - (110) (134) (150) - (200) (300) (600) - (900) (1200) (1800) - (2400) (3600) (4800) - (7200) (9600) (19200) - (38400) (57600) (115200) - (230400) (460800) #f - #f #f #f #f #f #f ; 24-29 - (exta) (extb))) +(define baud-rates '#((0 . 0) (1 . 50) (2 . 75) + (3 . 110) (4 . 134) (5 . 150) + (6 . 200) (7 . 300) (8 . 600) + (9 . 900) (10 . 1200) (11 . 1800) + (12 . 2400) (13 . 3600) (14 . 4800) + (15 . 7200) (16 . 9600) (17 . 19200) + (18 . 38400) (19 . 57600) (20 . 115200) + (21 . 230400) (22 . 460800) ; 23-29 unused. + (30 . exta) (31 . extb))) ;;; tcflush() constants diff --git a/scsh/scsh-interfaces.scm b/scsh/scsh-interfaces.scm index caede28..4053184 100644 --- a/scsh/scsh-interfaces.scm +++ b/scsh/scsh-interfaces.scm @@ -902,12 +902,6 @@ ;; SVR4 ttyl/case-map ; xcase: canonical upper/lower presentation - - ;; Baud Rates - baud/0 baud/50 baud/75 baud/110 - baud/134 baud/150 baud/200 baud/300 - baud/600 baud/1200 baud/1800 baud/2400 - baud/4800 baud/9600 baud/19200 baud/38400 )) ;;; Non-exported values required by the tty code. diff --git a/scsh/tty.scm b/scsh/tty.scm index 6558ca1..529ec50 100644 --- a/scsh/tty.scm +++ b/scsh/tty.scm @@ -39,7 +39,9 @@ control-flags local-flags input-speed + input-speed-code output-speed + output-speed-code min time ((disclose info) '("tty-info"))) @@ -62,25 +64,38 @@ (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) +;;; 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 (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)) + 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:output-speed info) - (tty-info:min info) - (tty-info:time 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))) ;;; (tty-info fd/port) @@ -91,14 +106,15 @@ (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) + ispeed-code ospeed-code) (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 + (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)))))) @@ -107,7 +123,7 @@ oflag-hi8 oflag-lo24 cflag-hi8 cflag-lo24 lflag-hi8 lflag-lo24 - ispeed ospeed) + ispeed-code ospeed-code) (define-foreign %tty-info/errno (scheme_tcgetattr (integer fdes) @@ -133,8 +149,8 @@ (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))) + (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)) @@ -162,7 +178,7 @@ oflag-hi8 oflag-lo24 cflag-hi8 cflag-lo24 lflag-hi8 lflag-lo24 - ispeed ospeed + ispeed-code ospeed-code min time) %set-tty-info/errno) @@ -179,8 +195,8 @@ (integer cflag-lo24) (integer lflag-hi8) (integer lflag-lo24) - (integer ispeed) - (integer ospeed) + (integer ispeed-code) + (integer ospeed-code) (integer min) (integer time)) (to-scheme integer errno_or_false)) @@ -271,16 +287,20 @@ ;;; 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))) - ((let ((entry (vector-ref baud-rates i))) - (and (pair? entry) (memv speed entry))) - i) + ((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) ; value of BAUD/9600 -> 9600 - (car (vector-ref baud-rates code))) +(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