mirror of
https://github.com/ashinn/chibi-scheme.git
synced 2025-07-09 14:07:34 +02:00
adding stty module
This commit is contained in:
Alex Shinn
parent
147686a452
commit
73a4605a59
4 changed files with 336 additions and 2 deletions
8
Makefile
8
Makefile
|
|
@ -92,7 +92,8 @@ COMPILED_LIBS := lib/srfi/27/rand$(SO) lib/srfi/33/bit$(SO) \
|
|||
lib/srfi/69/hash$(SO) lib/srfi/95/qsort$(SO) lib/srfi/98/env$(SO) \
|
||||
lib/chibi/ast$(SO) lib/chibi/net$(SO) lib/chibi/filesystem$(SO) \
|
||||
lib/chibi/process$(SO) lib/chibi/time$(SO) lib/chibi/system$(SO) \
|
||||
lib/chibi/io/io$(SO) lib/chibi/heap-stats$(SO) lib/chibi/disasm$(SO)
|
||||
lib/chibi/io/io$(SO) lib/chibi/stty$(SO) \
|
||||
lib/chibi/heap-stats$(SO) lib/chibi/disasm$(SO)
|
||||
|
||||
libs: $(COMPILED_LIBS)
|
||||
|
||||
|
|
@ -108,7 +109,7 @@ include/chibi/install.h: Makefile
|
|||
sexp.o: sexp.c gc.c opt/bignum.c $(INCLUDES) Makefile
|
||||
$(CC) -c $(XCPPFLAGS) $(XCFLAGS) $(CLIBFLAGS) -o $@ $<
|
||||
|
||||
eval.o: eval.c opcodes.c vm.c opt/simplify.c $(INCLUDES) include/chibi/eval.h Makefile
|
||||
eval.o: eval.c opcodes.c vm.c opt/x86.c opt/simplify.c $(INCLUDES) include/chibi/eval.h Makefile
|
||||
$(CC) -c $(XCPPFLAGS) $(XCFLAGS) $(CLIBFLAGS) -o $@ $<
|
||||
|
||||
main.o: main.c $(INCLUDES) include/chibi/eval.h Makefile
|
||||
|
|
@ -163,6 +164,9 @@ test-build:
|
|||
test-numbers: chibi-scheme$(EXE)
|
||||
LD_LIBRARY_PATH=".:$(LD_LIBRARY_PATH)" ./chibi-scheme$(EXE) tests/numeric-tests.scm
|
||||
|
||||
test-flonums: chibi-scheme$(EXE)
|
||||
LD_LIBRARY_PATH=".:$(LD_LIBRARY_PATH)" ./chibi-scheme$(EXE) tests/flonum-tests.scm
|
||||
|
||||
test-hash: chibi-scheme$(EXE)
|
||||
LD_LIBRARY_PATH=".:$(LD_LIBRARY_PATH)" ./chibi-scheme$(EXE) tests/hash-tests.scm
|
||||
|
||||
|
|
|
|||
10
lib/chibi/stty.module
Normal file
10
lib/chibi/stty.module
Normal file
|
|
@ -0,0 +1,10 @@
|
|||
|
||||
(define-module (chibi stty)
|
||||
(export stty with-stty TCSANOW TCSADRAIN TCSAFLUSH)
|
||||
(import-immutable (scheme)
|
||||
(srfi 33)
|
||||
(srfi 69))
|
||||
(include-shared "stty")
|
||||
(include "stty.scm")
|
||||
)
|
||||
|
||||
224
lib/chibi/stty.scm
Normal file
224
lib/chibi/stty.scm
Normal file
|
|
@ -0,0 +1,224 @@
|
|||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; symbolic representation of attributes
|
||||
|
||||
(define stty-lookup (make-hash-table eq?))
|
||||
|
||||
(for-each
|
||||
(lambda (c)
|
||||
(let ((type (cadr c))
|
||||
(value (caddr c)))
|
||||
(hash-table-set! stty-lookup (car c) (cdr c))))
|
||||
|
||||
;; ripped from the stty man page, then trimmed down to what seemed
|
||||
;; available on most systems
|
||||
|
||||
`(;; characters
|
||||
;;(dsusp char ,VDSUSP) ; CHAR will send a terminal stop signal
|
||||
(eof char ,VEOF) ; CHAR will send an EOF (terminate input)
|
||||
(eol char ,VEOL) ; CHAR will end the line
|
||||
(eol2 char ,VEOL2) ; alternate CHAR for ending the line
|
||||
(erase char ,VERASE) ; CHAR will erase the last character typed
|
||||
(intr char ,VINTR) ; CHAR will send an interrupt signal
|
||||
(kill char ,VKILL) ; CHAR will erase the current line
|
||||
(lnext char ,VLNEXT) ; CHAR will enter the next character quoted
|
||||
(quit char ,VQUIT) ; CHAR will send a quit signal
|
||||
(rprnt char ,VREPRINT) ; CHAR will redraw the current line
|
||||
(start char ,VSTART) ; CHAR will restart output after stopping it
|
||||
(stop char ,VSTOP) ; CHAR will stop the output
|
||||
(susp char ,VSUSP) ; CHAR will send a terminal stop signal
|
||||
(werase char ,VWERASE) ; CHAR will erase the last word typed
|
||||
|
||||
;; special settings
|
||||
(cols special #f) ; tell the kernel that the terminal has N columns
|
||||
(columns special #f) ; same as cols N
|
||||
(ispeed special #f) ; set the input speed to N
|
||||
(line special #f) ; use line discipline N
|
||||
(min special #f) ; with -icanon, set N characters minimum for a completed read
|
||||
(ospeed special #f) ; set the output speed to N
|
||||
(rows special #f) ; tell the kernel that the terminal has N rows
|
||||
(size special #f) ; print the number of rows and columns according to the kernel
|
||||
(speed special #f) ; print the terminal speed
|
||||
(time special #f) ; with -icanon, set read timeout of N tenths of a second
|
||||
|
||||
;; control settings
|
||||
(clocal control ,CLOCAL) ; disable modem control signals
|
||||
(cread control ,CREAD) ; allow input to be received
|
||||
(crtscts control ,CRTSCTS) ; enable RTS/CTS handshaking
|
||||
(cs5 control ,CS5) ; set character size to 5 bits
|
||||
(cs6 control ,CS6) ; set character size to 6 bits
|
||||
(cs7 control ,CS7) ; set character size to 7 bits
|
||||
(cs8 control ,CS8) ; set character size to 8 bits
|
||||
(cstopb control ,CSTOPB) ; use two stop bits per character (one with `-')
|
||||
(hup control ,HUPCL) ; send a hangup signal when the last process closes the tty
|
||||
(hupcl control ,HUPCL) ; same as [-]hup
|
||||
(parenb control ,PARENB) ; generate parity bit in output and expect parity bit in input
|
||||
(parodd control ,PARODD) ; set odd parity (even with `-')
|
||||
|
||||
;; input settings
|
||||
(brkint input ,BRKINT) ; breaks cause an interrupt signal
|
||||
(icrnl input ,ICRNL) ; translate carriage return to newline
|
||||
(ignbrk input ,IGNBRK) ; ignore break characters
|
||||
(igncr input ,IGNCR) ; ignore carriage return
|
||||
(ignpar input ,IGNPAR) ; ignore characters with parity errors
|
||||
(imaxbel input ,IMAXBEL) ; * beep and do not flush a full input buffer on a character
|
||||
(inlcr input ,INLCR) ; translate newline to carriage return
|
||||
(inpck input ,INPCK) ; enable input parity checking
|
||||
(istrip input ,ISTRIP) ; clear high (8th) bit of input characters
|
||||
;;(iuclc input ,IUCLC) ; * translate uppercase characters to lowercase
|
||||
(ixany input ,IXANY) ; * let any character restart output, not only start character
|
||||
(ixoff input ,IXOFF) ; enable sending of start/stop characters
|
||||
(ixon input ,IXON) ; enable XON/XOFF flow control
|
||||
(parmrk input ,PARMRK) ; mark parity errors (with a 255-0-character sequence)
|
||||
(tandem input ,IXOFF) ; same as [-]ixoff
|
||||
|
||||
;; output settings
|
||||
;;(bs0 output ,BS0) ; backspace delay style, N in [0..1]
|
||||
;;(bs1 output ,BS1) ; backspace delay style, N in [0..1]
|
||||
;;(cr0 output ,CR0) ; carriage return delay style, N in [0..3]
|
||||
;;(cr1 output ,CR1) ; carriage return delay style, N in [0..3]
|
||||
;;(cr2 output ,CR2) ; carriage return delay style, N in [0..3]
|
||||
;;(cr3 output ,CR3) ; carriage return delay style, N in [0..3]
|
||||
;;(ff0 output ,FF0) ; form feed delay style, N in [0..1]
|
||||
;;(ff1 output ,FF1) ; form feed delay style, N in [0..1]
|
||||
;;(nl0 output ,NL0) ; newline delay style, N in [0..1]
|
||||
;;(nl1 output ,NL1) ; newline delay style, N in [0..1]
|
||||
(ocrnl output ,OCRNL) ; translate carriage return to newline
|
||||
;;(ofdel output ,OFDEL) ; use delete characters for fill instead of null characters
|
||||
;;(ofill output ,OFILL) ; use fill (padding) characters instead of timing for delays
|
||||
;;(olcuc output ,OLCUC) ; translate lowercase characters to uppercase
|
||||
(onlcr output ,ONLCR) ; translate newline to carriage return-newline
|
||||
(onlret output ,ONLRET) ; newline performs a carriage return
|
||||
(onocr output ,ONOCR) ; do not print carriage returns in the first column
|
||||
(opost output ,OPOST) ; postprocess output
|
||||
(tab0 output #f) ; horizontal tab delay style, N in [0..3]
|
||||
(tab1 output #f) ; horizontal tab delay style, N in [0..3]
|
||||
(tab2 output #f) ; horizontal tab delay style, N in [0..3]
|
||||
(tab3 output #f) ; horizontal tab delay style, N in [0..3]
|
||||
(tabs output #f) ; same as tab0
|
||||
;;(-tabs output #f) ; same as tab3
|
||||
;;(vt0 output ,VT0) ; vertical tab delay style, N in [0..1]
|
||||
;;(vt1 output ,VT1) ; vertical tab delay style, N in [0..1]
|
||||
|
||||
;; local settings
|
||||
(crterase local ,ECHOE) ; echo erase characters as backspace-space-backspace
|
||||
(crtkill local ,ECHOKE) ; kill all line by obeying the echoprt and echoe settings
|
||||
;;(-crtkill local #f) ; kill all line by obeying the echoctl and echok settings
|
||||
(ctlecho local ,ECHOCTL) ; echo control characters in hat notation (`^c')
|
||||
(echo local ,ECHO) ; echo input characters
|
||||
(echoctl local ,ECHOCTL) ; same as [-]ctlecho
|
||||
(echoe local ,ECHOE) ; same as [-]crterase
|
||||
;;(echok local ,ECHOK) ; echo a newline after a kill character
|
||||
(echoke local ,ECHOKE) ; same as [-]crtkill
|
||||
(echonl local ,ECHONL) ; echo newline even if not echoing other characters
|
||||
(echoprt local ,ECHOPRT) ; echo erased characters backward, between `\' and '/'
|
||||
(icanon local ,ICANON) ; enable erase, kill, werase, and rprnt special characters
|
||||
;;(iexten local ,IEXTEN) ; enable non-POSIX special characters
|
||||
(isig local ,ISIG) ; enable interrupt, quit, and suspend special characters
|
||||
(noflsh local ,NOFLSH) ; disable flushing after interrupt and quit special characters
|
||||
(prterase local ,ECHOPRT) ; same as [-]echoprt
|
||||
(tostop local ,TOSTOP) ; stop background jobs that try to write to the terminal
|
||||
;;(xcase local ,XCASE) ; with icanon, escape with `\' for uppercase characters
|
||||
|
||||
;; combination settings
|
||||
(LCASE combine (lcase))
|
||||
(cbreak combine (not icanon))
|
||||
(cooked combine (brkint ignpar istrip icrnl ixon opost isig icanon))
|
||||
; also eof and eol characters
|
||||
; to their default values
|
||||
(crt combine (echoe echoctl echoke))
|
||||
(dec combine (echoe echoctl echoke (not ixany)))
|
||||
; also intr ^c erase 0177 kill ^u
|
||||
(decctlq combine (ixany))
|
||||
(ek combine ()) ; erase and kill characters to their default values
|
||||
(evenp combine (parenb (not parodd) cs7))
|
||||
;;(-evenp combine #f) ; same as -parenb cs8
|
||||
(lcase combine (xcase iuclc olcuc))
|
||||
(litout combine (cs8 (not parenb istrip opost)))
|
||||
;;(-litout combine #f) ; same as parenb istrip opost cs7
|
||||
(nl combine (not icrnl onlcr))
|
||||
;;(-nl combine #f) ; same as icrnl -inlcr -igncr onlcr -ocrnl -onlret
|
||||
(oddp combine (parenb parodd cs7))
|
||||
(parity combine (evenp)) ; same as [-]evenp
|
||||
(pass8 combine (cs8 (not parenb istrip)))
|
||||
;;(-pass8 combine #f) ; same as parenb istrip cs7
|
||||
(raw combine (not ignbrk brkint ignpar parmrk
|
||||
inpck istrip inlcr igncr icrnl))
|
||||
(ixon combine (ixoff ixany imaxbel opost isig icanon)) ;; xcase iuclc
|
||||
;;(time combine #f) ; 0
|
||||
;;(-raw combine #f) ; same as cooked
|
||||
(sane combine (cread brkint icrnl imaxbel opost onlcr
|
||||
isig icanon ;; nl0 cr0 bs0 vt0 ff0 ; tab0
|
||||
echo echoe echoctl echoke ;; iexten echok
|
||||
(not ignbrk igncr ixoff ixany inlcr ;; iuclc
|
||||
ocrnl onocr onlret ;; olcuc ofill ofdel
|
||||
echonl noflsh tostop echoprt))) ;; xcase
|
||||
; plus all special characters to
|
||||
; their default values
|
||||
))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; high-level interface
|
||||
|
||||
(define (port? x) (or (input-port? x) (output-port? x)))
|
||||
|
||||
(define (stty . args)
|
||||
(let* ((port (if (and (pair? args) (port? (car args)))
|
||||
(car args)
|
||||
(current-output-port)))
|
||||
(attr (get-terminal-attributes port)))
|
||||
;; parse change requests
|
||||
(let lp ((lst (if (and (pair? args) (port? (car args))) (cdr args) args))
|
||||
(iflag (term-attrs-iflag attr))
|
||||
(oflag (term-attrs-oflag attr))
|
||||
(cflag (term-attrs-cflag attr))
|
||||
(lflag (term-attrs-lflag attr))
|
||||
(invert? #f)
|
||||
(return (lambda (iflag oflag cflag lflag)
|
||||
(term-attrs-iflag-set! attr iflag)
|
||||
(term-attrs-oflag-set! attr oflag)
|
||||
(term-attrs-cflag-set! attr cflag)
|
||||
(term-attrs-lflag-set! attr lflag)
|
||||
(set-terminal-attributes! port TCSANOW attr))))
|
||||
(define (join old new)
|
||||
(if invert? (bitwise-and old (bitwise-not new)) (bitwise-ior old new)))
|
||||
(cond
|
||||
((pair? lst)
|
||||
(let ((command (car lst)))
|
||||
(cond
|
||||
((pair? command) ;; recurse on sub-expr
|
||||
(lp command iflag oflag cflag lflag invert?
|
||||
(lambda (i o c l) (lp (cdr lst) i o c l invert? return))))
|
||||
((eq? command 'not) ;; toggle current setting
|
||||
(lp (cdr lst) iflag oflag cflag lflag (not invert?) return))
|
||||
(else
|
||||
(let ((x (hash-table-ref/default stty-lookup command #f)))
|
||||
(case (and x (car x))
|
||||
((input)
|
||||
(lp (cdr lst) (join iflag (cadr x)) oflag cflag lflag invert? return))
|
||||
((output)
|
||||
(lp (cdr lst) iflag (join oflag (cadr x)) cflag lflag invert? return))
|
||||
((control)
|
||||
(lp (cdr lst) iflag oflag (join cflag (cadr x)) lflag invert? return))
|
||||
((local)
|
||||
(lp (cdr lst) iflag oflag cflag (join lflag (cadr x)) invert? return))
|
||||
((char)
|
||||
;;(term-attrs-cc-set! attr (cadr x) (or (cadr lst) 0))
|
||||
(lp (cddr lst) iflag oflag cflag lflag invert? return))
|
||||
((combine) ;; recurse on def of this command
|
||||
(lp (cadr x) iflag oflag cflag lflag invert?
|
||||
(lambda (i o c l) (lp (cdr lst) i o c l invert? return))))
|
||||
((special)
|
||||
(error "special settings not yet supported" command))
|
||||
(else
|
||||
(error "unknown stty command" command))))))))
|
||||
(else
|
||||
(return iflag oflag cflag lflag))))))
|
||||
|
||||
(define (with-stty setting thunk . o)
|
||||
(let* ((port (if (pair? o) (car o) (current-input-port)))
|
||||
(orig-attrs (get-terminal-attributes port)))
|
||||
(dynamic-wind
|
||||
(lambda () (stty setting))
|
||||
thunk
|
||||
(lambda () (set-terminal-attributes! port TCSANOW orig-attrs)))))
|
||||
96
lib/chibi/stty.stub
Normal file
96
lib/chibi/stty.stub
Normal file
|
|
@ -0,0 +1,96 @@
|
|||
|
||||
(c-system-include "termios.h")
|
||||
|
||||
(define-c-struct termios
|
||||
predicate: term-attrs?
|
||||
constructor: (make-term-attrs)
|
||||
;;destructor: free-term-attrs
|
||||
(unsigned-long c_iflag term-attrs-iflag term-attrs-iflag-set!)
|
||||
(unsigned-long c_oflag term-attrs-oflag term-attrs-oflag-set!)
|
||||
(unsigned-long c_cflag term-attrs-cflag term-attrs-cflag-set!)
|
||||
(unsigned-long c_lflag term-attrs-lflag term-attrs-lflag-set!)
|
||||
;;(unsigned-char (c_cc 22) term-attrs-cc term-attrs-cc-set!)
|
||||
(unsigned-long c_ispeed term-attrs-ispeed term-attrs-ispeed-set!)
|
||||
(unsigned-long c_ospeed term-attrs-ospeed term-attrs-ospeed-set!))
|
||||
|
||||
(define-c-const int TCSANOW)
|
||||
(define-c-const int TCSADRAIN)
|
||||
(define-c-const int TCSAFLUSH)
|
||||
;; (define-c-const int TCSASOFT)
|
||||
|
||||
(define-c-const unsigned-long IGNBRK)
|
||||
(define-c-const unsigned-long BRKINT)
|
||||
(define-c-const unsigned-long IGNPAR)
|
||||
(define-c-const unsigned-long PARMRK)
|
||||
(define-c-const unsigned-long INPCK)
|
||||
(define-c-const unsigned-long ISTRIP)
|
||||
(define-c-const unsigned-long INLCR)
|
||||
(define-c-const unsigned-long IGNCR)
|
||||
(define-c-const unsigned-long ICRNL)
|
||||
(define-c-const unsigned-long IXON)
|
||||
(define-c-const unsigned-long IXOFF)
|
||||
(define-c-const unsigned-long IXANY)
|
||||
(define-c-const unsigned-long IMAXBEL)
|
||||
;; (define-c-const unsigned-long IUCLC)
|
||||
|
||||
(define-c-const unsigned-long OPOST)
|
||||
(define-c-const unsigned-long ONLCR)
|
||||
;; (define-c-const unsigned-long OXTABS)
|
||||
;; (define-c-const unsigned-long ONOEOT)
|
||||
(define-c-const unsigned-long OCRNL)
|
||||
;; (define-c-const unsigned-long OLCUC)
|
||||
(define-c-const unsigned-long ONOCR)
|
||||
(define-c-const unsigned-long ONLRET)
|
||||
|
||||
(define-c-const unsigned-long CSIZE)
|
||||
(define-c-const unsigned-long CS5)
|
||||
(define-c-const unsigned-long CS6)
|
||||
(define-c-const unsigned-long CS7)
|
||||
(define-c-const unsigned-long CS8)
|
||||
(define-c-const unsigned-long CSTOPB)
|
||||
(define-c-const unsigned-long CREAD)
|
||||
(define-c-const unsigned-long PARENB)
|
||||
(define-c-const unsigned-long PARODD)
|
||||
(define-c-const unsigned-long HUPCL)
|
||||
(define-c-const unsigned-long CLOCAL)
|
||||
;; (define-c-const unsigned-long CCTS_OFLOW)
|
||||
(define-c-const unsigned-long CRTSCTS)
|
||||
;; (define-c-const unsigned-long CRTS_IFLOW)
|
||||
;; (define-c-const unsigned-long MDMBUF)
|
||||
|
||||
(define-c-const unsigned-long ECHOKE)
|
||||
(define-c-const unsigned-long ECHOE)
|
||||
(define-c-const unsigned-long ECHO)
|
||||
(define-c-const unsigned-long ECHONL)
|
||||
(define-c-const unsigned-long ECHOPRT)
|
||||
(define-c-const unsigned-long ECHOCTL)
|
||||
(define-c-const unsigned-long ISIG)
|
||||
(define-c-const unsigned-long ICANON)
|
||||
;; (define-c-const unsigned-long ALTWERASE)
|
||||
(define-c-const unsigned-long IEXTEN)
|
||||
;; (define-c-const unsigned-long EXTPROC)
|
||||
(define-c-const unsigned-long TOSTOP)
|
||||
(define-c-const unsigned-long FLUSHO)
|
||||
;; (define-c-const unsigned-long NOKERNINFO)
|
||||
(define-c-const unsigned-long PENDIN)
|
||||
(define-c-const unsigned-long NOFLSH)
|
||||
|
||||
(define-c-const unsigned-long VEOF)
|
||||
(define-c-const unsigned-long VEOL)
|
||||
(define-c-const unsigned-long VEOL2)
|
||||
(define-c-const unsigned-long VERASE)
|
||||
;; (define-c-const unsigned-long VERASE2)
|
||||
(define-c-const unsigned-long VWERASE)
|
||||
(define-c-const unsigned-long VINTR)
|
||||
(define-c-const unsigned-long VKILL)
|
||||
(define-c-const unsigned-long VQUIT)
|
||||
(define-c-const unsigned-long VSUSP)
|
||||
(define-c-const unsigned-long VSTART)
|
||||
(define-c-const unsigned-long VSTOP)
|
||||
;; (define-c-const unsigned-long VDSUSP)
|
||||
(define-c-const unsigned-long VLNEXT)
|
||||
(define-c-const unsigned-long VREPRINT)
|
||||
;; (define-c-const unsigned-long VSTATUS)
|
||||
|
||||
(define-c errno (get-terminal-attributes "tcgetattr") (port-or-fd (result termios)))
|
||||
(define-c errno (set-terminal-attributes! "tcsetattr") (port-or-fd int termios))
|
||||
Loading…
Add table
Reference in a new issue