Decigged tty.
This commit is contained in:
mainzelm
parent
e6ccf4cf1f
commit
a36dbe8904
261
scsh/tty.c
261
scsh/tty.c
|
|
@ -1,261 +0,0 @@
|
|||
/* This is an Scheme48/C interface file,
|
||||
** automatically generated by a hacked version of cig 3.0.
|
||||
step 4
|
||||
*/
|
||||
|
||||
#include <stdio.h>
|
||||
#include <stdlib.h> /* For malloc. */
|
||||
#include "libcig.h"
|
||||
|
||||
#include <sys/types.h>
|
||||
|
||||
#include <unistd.h>
|
||||
#include <termios.h>
|
||||
|
||||
/* 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))
|
||||
s48_value df_scheme_tcgetattr(s48_value g1, s48_value g2, s48_value mv_vec)
|
||||
{
|
||||
extern int scheme_tcgetattr(int , char *, int *, int *, int *, int *, int *, int *);
|
||||
s48_value ret1 = S48_FALSE;
|
||||
S48_DECLARE_GC_PROTECT(2);
|
||||
int r1;
|
||||
int r2 = 0;
|
||||
int r3 = 0;
|
||||
int r4 = 0;
|
||||
int r5 = 0;
|
||||
int r6 = 0;
|
||||
int r7 = 0;
|
||||
|
||||
|
||||
|
||||
S48_GC_PROTECT_2(mv_vec,ret1);
|
||||
r1 = scheme_tcgetattr(s48_extract_fixnum(g1), s48_extract_string(g2), &r2, &r3, &r4, &r5, &r6, &r7);
|
||||
ret1 = errno_or_false(r1);
|
||||
S48_VECTOR_SET(mv_vec,0,s48_enter_integer(r2));
|
||||
S48_VECTOR_SET(mv_vec,1,s48_enter_integer(r3));
|
||||
S48_VECTOR_SET(mv_vec,2,s48_enter_integer(r4));
|
||||
S48_VECTOR_SET(mv_vec,3,s48_enter_integer(r5));
|
||||
S48_VECTOR_SET(mv_vec,4,s48_enter_fixnum(r6));
|
||||
S48_VECTOR_SET(mv_vec,5,s48_enter_fixnum(r7));
|
||||
S48_GC_UNPROTECT();
|
||||
return ret1;
|
||||
}
|
||||
|
||||
s48_value df_scheme_tcgetattrB(s48_value g1, s48_value g2, s48_value g3)
|
||||
{
|
||||
extern int scheme_tcgetattrB(int , char *, s48_value );
|
||||
s48_value ret1 = S48_FALSE;
|
||||
S48_DECLARE_GC_PROTECT(1);
|
||||
int r1;
|
||||
|
||||
|
||||
|
||||
S48_GC_PROTECT_1(ret1);
|
||||
r1 = scheme_tcgetattrB(s48_extract_fixnum(g1), s48_extract_string(g2), g3);
|
||||
ret1 = errno_or_false(r1);
|
||||
S48_GC_UNPROTECT();
|
||||
return ret1;
|
||||
}
|
||||
|
||||
s48_value df_scheme_tcsetattr(s48_value g1, s48_value g2, s48_value g3, s48_value g4, s48_value g5, s48_value g6, s48_value g7, s48_value g8, s48_value g9, s48_value g10, s48_value g11)
|
||||
{
|
||||
extern int scheme_tcsetattr(int , int , const char *, int , int , int , int , int , int , int , int );
|
||||
s48_value ret1 = S48_FALSE;
|
||||
S48_DECLARE_GC_PROTECT(1);
|
||||
int r1;
|
||||
|
||||
|
||||
|
||||
S48_GC_PROTECT_1(ret1);
|
||||
r1 = scheme_tcsetattr(s48_extract_fixnum(g1), s48_extract_fixnum(g2), s48_extract_string(g3), s48_extract_integer(g4), s48_extract_integer(g5), s48_extract_integer(g6), s48_extract_integer(g7), s48_extract_fixnum(g8), s48_extract_fixnum(g9), s48_extract_fixnum(g10), s48_extract_fixnum(g11));
|
||||
ret1 = errno_or_false(r1);
|
||||
S48_GC_UNPROTECT();
|
||||
return ret1;
|
||||
}
|
||||
|
||||
s48_value df_tcsendbreak(s48_value g1, s48_value g2)
|
||||
{
|
||||
extern int tcsendbreak(int , int );
|
||||
s48_value ret1 = S48_FALSE;
|
||||
S48_DECLARE_GC_PROTECT(1);
|
||||
int r1;
|
||||
|
||||
|
||||
|
||||
S48_GC_PROTECT_1(ret1);
|
||||
r1 = tcsendbreak(s48_extract_integer(g1), s48_extract_integer(g2));
|
||||
ret1 = errno_or_false(r1);
|
||||
S48_GC_UNPROTECT();
|
||||
return ret1;
|
||||
}
|
||||
|
||||
s48_value df_tcdrain(s48_value g1)
|
||||
{
|
||||
|
||||
s48_value ret1 = S48_FALSE;
|
||||
S48_DECLARE_GC_PROTECT(1);
|
||||
int r1;
|
||||
|
||||
|
||||
|
||||
S48_GC_PROTECT_1(ret1);
|
||||
r1 = tcdrain(s48_extract_integer(g1));
|
||||
ret1 = errno_or_false(r1);
|
||||
S48_GC_UNPROTECT();
|
||||
return ret1;
|
||||
}
|
||||
|
||||
s48_value df_tcflush(s48_value g1, s48_value g2)
|
||||
{
|
||||
|
||||
s48_value ret1 = S48_FALSE;
|
||||
S48_DECLARE_GC_PROTECT(1);
|
||||
int r1;
|
||||
|
||||
|
||||
|
||||
S48_GC_PROTECT_1(ret1);
|
||||
r1 = tcflush(s48_extract_integer(g1), s48_extract_integer(g2));
|
||||
ret1 = errno_or_false(r1);
|
||||
S48_GC_UNPROTECT();
|
||||
return ret1;
|
||||
}
|
||||
|
||||
s48_value df_tcflow(s48_value g1, s48_value g2)
|
||||
{
|
||||
|
||||
s48_value ret1 = S48_FALSE;
|
||||
S48_DECLARE_GC_PROTECT(1);
|
||||
int r1;
|
||||
|
||||
|
||||
|
||||
S48_GC_PROTECT_1(ret1);
|
||||
r1 = tcflow(s48_extract_integer(g1), s48_extract_integer(g2));
|
||||
ret1 = errno_or_false(r1);
|
||||
S48_GC_UNPROTECT();
|
||||
return ret1;
|
||||
}
|
||||
|
||||
s48_value df_tcsetpgrp(s48_value g1, s48_value g2)
|
||||
{
|
||||
|
||||
s48_value ret1 = S48_FALSE;
|
||||
S48_DECLARE_GC_PROTECT(1);
|
||||
int r1;
|
||||
|
||||
|
||||
|
||||
S48_GC_PROTECT_1(ret1);
|
||||
r1 = tcsetpgrp(s48_extract_fixnum(g1), s48_extract_fixnum(g2));
|
||||
ret1 = errno_or_false(r1);
|
||||
S48_GC_UNPROTECT();
|
||||
return ret1;
|
||||
}
|
||||
|
||||
s48_value df_tcgetpgrp(s48_value g1, s48_value mv_vec)
|
||||
{
|
||||
|
||||
s48_value ret1 = S48_FALSE;
|
||||
S48_DECLARE_GC_PROTECT(2);
|
||||
pid_t r1;
|
||||
|
||||
|
||||
|
||||
S48_GC_PROTECT_2(mv_vec,ret1);
|
||||
r1 = tcgetpgrp(s48_extract_fixnum(g1));
|
||||
ret1 = errno_or_false(r1);
|
||||
S48_VECTOR_SET(mv_vec,0,s48_enter_fixnum(r1));
|
||||
S48_GC_UNPROTECT();
|
||||
return ret1;
|
||||
}
|
||||
|
||||
s48_value df_open_ctty(s48_value g1, s48_value g2, s48_value mv_vec)
|
||||
{
|
||||
extern int open_ctty(const char *, int );
|
||||
s48_value ret1 = S48_FALSE;
|
||||
S48_DECLARE_GC_PROTECT(2);
|
||||
int r1;
|
||||
|
||||
|
||||
|
||||
S48_GC_PROTECT_2(mv_vec,ret1);
|
||||
r1 = open_ctty(s48_extract_string(g1), s48_extract_fixnum(g2));
|
||||
ret1 = errno_or_false(r1);
|
||||
S48_VECTOR_SET(mv_vec,0,s48_enter_integer(r1));
|
||||
S48_GC_UNPROTECT();
|
||||
return ret1;
|
||||
}
|
||||
|
||||
s48_value df_isatty(s48_value g1)
|
||||
{
|
||||
extern int isatty(int );
|
||||
s48_value ret1 = S48_FALSE;
|
||||
S48_DECLARE_GC_PROTECT(1);
|
||||
int r1;
|
||||
|
||||
|
||||
|
||||
S48_GC_PROTECT_1(ret1);
|
||||
r1 = isatty(s48_extract_integer(g1));
|
||||
ret1 = ENTER_BOOLEAN(r1);
|
||||
S48_GC_UNPROTECT();
|
||||
return ret1;
|
||||
}
|
||||
|
||||
s48_value df_ttyname(s48_value g1, s48_value mv_vec)
|
||||
{
|
||||
extern char *ttyname(int );
|
||||
s48_value ret1 = S48_FALSE;
|
||||
S48_DECLARE_GC_PROTECT(2);
|
||||
char *r1;
|
||||
|
||||
|
||||
|
||||
S48_GC_PROTECT_2(mv_vec,ret1);
|
||||
r1 = ttyname(s48_extract_integer(g1));
|
||||
ret1 = errno_on_zero_or_false(r1);
|
||||
SetAlienVal(S48_CAR(S48_VECTOR_REF(mv_vec,0)),(long) r1); S48_SET_CDR(S48_VECTOR_REF(mv_vec,0),strlen_or_false(r1));//str-and-len
|
||||
S48_GC_UNPROTECT();
|
||||
return ret1;
|
||||
}
|
||||
|
||||
s48_value df_scm_ctermid(s48_value mv_vec)
|
||||
{
|
||||
extern char *scm_ctermid(void);
|
||||
s48_value ret1 = S48_FALSE;
|
||||
S48_DECLARE_GC_PROTECT(2);
|
||||
char *r1;
|
||||
|
||||
|
||||
|
||||
S48_GC_PROTECT_2(mv_vec,ret1);
|
||||
r1 = scm_ctermid();
|
||||
ret1 = errno_on_zero_or_false(r1);
|
||||
SetAlienVal(S48_CAR(S48_VECTOR_REF(mv_vec,0)),(long) r1); S48_SET_CDR(S48_VECTOR_REF(mv_vec,0),strlen_or_false(r1));//str-and-len
|
||||
S48_GC_UNPROTECT();
|
||||
return ret1;
|
||||
}
|
||||
|
||||
void s48_init_tty(void)
|
||||
{
|
||||
S48_EXPORT_FUNCTION(df_scheme_tcgetattr);
|
||||
S48_EXPORT_FUNCTION(df_scheme_tcgetattrB);
|
||||
S48_EXPORT_FUNCTION(df_scheme_tcsetattr);
|
||||
S48_EXPORT_FUNCTION(df_tcsendbreak);
|
||||
S48_EXPORT_FUNCTION(df_tcdrain);
|
||||
S48_EXPORT_FUNCTION(df_tcflush);
|
||||
S48_EXPORT_FUNCTION(df_tcflow);
|
||||
S48_EXPORT_FUNCTION(df_tcsetpgrp);
|
||||
S48_EXPORT_FUNCTION(df_tcgetpgrp);
|
||||
S48_EXPORT_FUNCTION(df_open_ctty);
|
||||
S48_EXPORT_FUNCTION(df_isatty);
|
||||
S48_EXPORT_FUNCTION(df_ttyname);
|
||||
S48_EXPORT_FUNCTION(df_scm_ctermid);
|
||||
}
|
||||
192
scsh/tty.scm
192
scsh/tty.scm
|
|
@ -13,24 +13,6 @@
|
|||
;;; Copyright (c) 1995 by Brian D. Carlstrom.
|
||||
;;; Rehacked by Olin 8/95.
|
||||
|
||||
(foreign-init-name "tty")
|
||||
|
||||
(foreign-source
|
||||
"#include <sys/types.h>"
|
||||
""
|
||||
"#include <unistd.h>"
|
||||
"#include <termios.h>"
|
||||
""
|
||||
"/* 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
|
||||
|
|
@ -127,10 +109,8 @@
|
|||
|
||||
(define (tty-info fdport)
|
||||
(let ((control-chars (make-string num-ttychars)))
|
||||
(receive (iflag oflag
|
||||
cflag lflag
|
||||
ispeed-code ospeed-code)
|
||||
(sleazy-call/fdes fdport (lambda (fd) (%tty-info fd control-chars)))
|
||||
(apply
|
||||
(lambda (iflag oflag cflag lflag ispeed-code ospeed-code)
|
||||
(make-%tty-info control-chars
|
||||
iflag
|
||||
oflag
|
||||
|
|
@ -139,38 +119,30 @@
|
|||
(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))))))
|
||||
(char->ascii (string-ref control-chars ttychar/time))))
|
||||
(sleazy-call/fdes fdport (lambda (fd) (%tty-info fd control-chars))))))
|
||||
|
||||
(define-errno-syscall (%tty-info fdes control-chars) %tty-info/errno
|
||||
iflag
|
||||
oflag
|
||||
cflag
|
||||
lflag
|
||||
ispeed-code ospeed-code)
|
||||
(define-stubless-foreign %tty-info/eintr (fdes control-chars)
|
||||
"scheme_tcgetattr")
|
||||
(define-retrying-syscall %tty-info %tty-info/eintr)
|
||||
|
||||
(define-foreign %tty-info/errno
|
||||
(scheme_tcgetattr (fixnum fdes)
|
||||
(var-string control-chars))
|
||||
(to-scheme fixnum errno_or_false)
|
||||
integer
|
||||
integer
|
||||
integer
|
||||
integer
|
||||
fixnum fixnum)
|
||||
|
||||
(define-foreign %bogus-tty-info/errno
|
||||
("scheme_tcgetattrB" (fixnum fdes)
|
||||
(var-string control-chars)
|
||||
(vector-desc ivec))
|
||||
(to-scheme fixnum errno_or_false))
|
||||
;;; JMG: I don't know what the purpose of this code is...
|
||||
;(define-foreign %bogus-tty-info/errno
|
||||
; ("scheme_tcgetattrB" (fixnum fdes)
|
||||
; (var-string control-chars)
|
||||
; (vector-desc ivec))
|
||||
; (to-scheme fixnum errno_or_false))
|
||||
|
||||
(define-errno-syscall (%bogus-tty-info fdes control-chars ivec)
|
||||
%bogus-tty-info/errno)
|
||||
;(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 6)))
|
||||
(%bogus-tty-info fd control-chars ivec)
|
||||
ivec))
|
||||
;(define (%%bogus-tty-info fd control-chars)
|
||||
; (let ((ivec (make-vector 6)))
|
||||
; (%bogus-tty-info fd control-chars ivec)
|
||||
; ivec))
|
||||
|
||||
|
||||
|
||||
;(define (%tty-info fdes cc)
|
||||
; (let ((ivec (%%bogus-tty-info fdes cc)))
|
||||
|
|
@ -210,31 +182,11 @@
|
|||
(tty-info:time info))))))
|
||||
|
||||
|
||||
(define-errno-syscall (%set-tty-info fdes option
|
||||
control-chars
|
||||
iflag
|
||||
oflag
|
||||
cflag
|
||||
lflag
|
||||
ispeed-code ospeed-code
|
||||
min time)
|
||||
%set-tty-info/errno)
|
||||
|
||||
|
||||
(define-foreign %set-tty-info/errno
|
||||
(scheme_tcsetattr (fixnum fdes)
|
||||
(fixnum option)
|
||||
(string control-chars)
|
||||
(integer iflag)
|
||||
(integer oflag)
|
||||
(integer cflag)
|
||||
(integer lflag)
|
||||
(fixnum ispeed-code)
|
||||
(fixnum ospeed-code)
|
||||
(fixnum min)
|
||||
(fixnum time))
|
||||
(to-scheme fixnum errno_or_false))
|
||||
|
||||
(define-stubless-foreign %set-tty-info/eintr
|
||||
(fdes option control-chars iflag oflag cflag lflag ispeed-code ospeed-code
|
||||
min time)
|
||||
"scheme_tcsetattr")
|
||||
(define-retrying-syscall %set-tty-info %set-tty-info/eintr)
|
||||
|
||||
;;; Exported procs
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
|
@ -257,13 +209,9 @@
|
|||
(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))
|
||||
|
||||
(define-stubless-foreign %send-tty-break-fdes/eintr (fdes duration)
|
||||
"sch_tcsendbreak")
|
||||
(define-retrying-syscall %send-tty-break-fdes %send-tty-break-fdes/eintr)
|
||||
|
||||
;;; Drain the main vein.
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
|
@ -275,10 +223,8 @@
|
|||
(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))
|
||||
|
||||
(define-stubless-foreign %tcdrain/eintr (fdes) "sch_tcdrain")
|
||||
(define-retrying-syscall %tcdrain %tcdrain/eintr)
|
||||
|
||||
;;; Flushing the device queues. (tcflush)
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
|
@ -293,11 +239,8 @@
|
|||
(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))
|
||||
|
||||
(define-stubless-foreign %tcflush/eintr (fdes flag) "sch_tcflush")
|
||||
(define-retrying-syscall %tcflush %tcflush/eintr)
|
||||
|
||||
;;; Stopping and starting I/O (tcflow)
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
|
@ -313,12 +256,8 @@
|
|||
(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))
|
||||
|
||||
(define-stubless-foreign %tcflow/eintr (fdes action) "sch_tcflow")
|
||||
(define-retrying-syscall %tcflow %tcflow/eintr)
|
||||
|
||||
;;; Baud rate translation
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
|
@ -348,24 +287,14 @@
|
|||
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-stubless-foreign %set-tty-process-group/eintr (fdes pid) "sch_tcsetpgrp")
|
||||
(define-retrying-syscall %set-tty-process-group %set-tty-process-group/eintr)
|
||||
|
||||
(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))
|
||||
(define-stubless-foreign %tty-process-group/eintr (fdes) "sch_tcgetpgrp")
|
||||
(define-retrying-syscall %tty-process-group %tty-process-group/eintr)
|
||||
|
||||
;;; (open-control-tty fname [flags])
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
|
@ -377,23 +306,16 @@
|
|||
|
||||
(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))
|
||||
(let ((fd (%open-control-tty ttyname flags))
|
||||
(access (bitwise-and flags open/access-mask)))
|
||||
((if (or (= access open/read)
|
||||
(= access open/read+write))
|
||||
make-input-fdport
|
||||
make-output-fdport)
|
||||
fd 1))))
|
||||
|
||||
(define-stubless-foreign %open-control-tty/eintr (ttyname flags) "open_ctty")
|
||||
(define-retrying-syscall %open-control-tty %open-control-tty/eintr)
|
||||
|
||||
;;; Random bits & pieces: isatty ttyname ctermid
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
|
@ -401,20 +323,14 @@
|
|||
;;; (tty-file-name fd/port) -> string
|
||||
;;; (control-tty-file-name) -> string
|
||||
|
||||
(define-foreign %tty? (isatty (integer fd)) bool)
|
||||
(define-stubless-foreign %tty?/eintr (fd) "sch_isatty")
|
||||
(define-retrying-syscall %tty? %tty?/eintr)
|
||||
(define (tty? fd/port) (sleazy-call/fdes fd/port %tty?))
|
||||
|
||||
(define-stubless-foreign %tty-file-name/eintr (fd) "sch_ttyname")
|
||||
(define-retrying-syscall %tty-file-name %tty-file-name/eintr)
|
||||
|
||||
(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)
|
||||
(define-stubless-foreign %ctermid/eintr () "scm_ctermid")
|
||||
(define-retrying-syscall control-tty-file-name %ctermid/eintr)
|
||||
|
|
|
|||
184
scsh/tty1.c
184
scsh/tty1.c
|
|
@ -16,6 +16,7 @@
|
|||
#include <termios.h>
|
||||
#include <string.h>
|
||||
#include <sys/types.h>
|
||||
#include <errno.h>
|
||||
#include "scheme48.h"
|
||||
|
||||
/* This #include is for the #ifdef'd code in open_ctty() below, and
|
||||
|
|
@ -27,33 +28,42 @@
|
|||
|
||||
#include "tty1.h" /* Make sure the .h interface agrees with the code. */
|
||||
|
||||
extern int errno;
|
||||
|
||||
/*****************************************************************************/
|
||||
// should be part of the FFI interface
|
||||
s48_value s48_list_6 (s48_value e1, s48_value e2, s48_value e3,
|
||||
s48_value e4, s48_value e5, s48_value e6)
|
||||
{
|
||||
return
|
||||
s48_cons (e1, s48_cons (e2, s48_cons (e3, s48_cons (e4, s48_cons
|
||||
(e5, s48_cons (e6, S48_NULL))))));
|
||||
}
|
||||
|
||||
int scheme_tcgetattr(int fd, char *control_chars,
|
||||
int *iflag,
|
||||
s48_value scheme_tcgetattr(s48_value sch_fd, s48_value sch_control_chars)
|
||||
/* int *iflag,
|
||||
int *oflag,
|
||||
int *cflag,
|
||||
int *lflag,
|
||||
int *ispeed, int *ospeed)
|
||||
int *ispeed, int *ospeed)*/
|
||||
{
|
||||
struct termios t;
|
||||
int result = tcgetattr(fd, &t);
|
||||
int result = tcgetattr(s48_extract_fixnum (sch_fd), &t);
|
||||
int i;
|
||||
|
||||
if (result != -1) {
|
||||
memcpy(control_chars, t.c_cc, NCCS);
|
||||
*iflag =t.c_iflag;
|
||||
*oflag =t.c_oflag;
|
||||
*cflag =t.c_cflag;
|
||||
*lflag =t.c_lflag;
|
||||
*ispeed=cfgetispeed(&t);
|
||||
*ospeed=cfgetospeed(&t);
|
||||
}
|
||||
|
||||
return result;
|
||||
}
|
||||
if (result == -1)
|
||||
s48_raise_os_error_2 (errno, sch_fd, sch_control_chars);
|
||||
|
||||
for (i = 0; i < NCCS; i++)
|
||||
S48_STRING_SET(sch_control_chars, i, t.c_cc[i]);
|
||||
return
|
||||
s48_list_6 (s48_enter_integer (t.c_iflag),
|
||||
s48_enter_integer (t.c_oflag),
|
||||
s48_enter_integer (t.c_cflag),
|
||||
s48_enter_integer (t.c_lflag),
|
||||
s48_enter_integer (cfgetispeed(&t)),
|
||||
s48_enter_integer (cfgetospeed(&t)));
|
||||
}
|
||||
|
||||
// The Scheme caller of this is commented out...
|
||||
int scheme_tcgetattrB(int fd, char *control_chars, s48_value scmvec)
|
||||
{
|
||||
struct termios t;
|
||||
|
|
@ -78,18 +88,18 @@ int scheme_tcgetattrB(int fd, char *control_chars, s48_value scmvec)
|
|||
|
||||
/*****************************************************************************/
|
||||
|
||||
int scheme_tcsetattr(int fd, int option,
|
||||
const char *control_chars,
|
||||
int iflag,
|
||||
int oflag,
|
||||
int cflag,
|
||||
int lflag,
|
||||
int ispeed, int ospeed,
|
||||
int min, int time)
|
||||
s48_value scheme_tcsetattr(s48_value sch_fd, s48_value sch_option,
|
||||
s48_value sch_control_chars,
|
||||
s48_value sch_iflag,
|
||||
s48_value sch_oflag,
|
||||
s48_value sch_cflag,
|
||||
s48_value sch_lflag,
|
||||
s48_value sch_ispeed, s48_value sch_ospeed,
|
||||
s48_value sch_min, s48_value sch_time)
|
||||
{
|
||||
struct termios t;
|
||||
|
||||
memcpy(t.c_cc, control_chars, NCCS);
|
||||
memcpy(t.c_cc, s48_extract_string (sch_control_chars), NCCS);
|
||||
|
||||
/* This first clause of this conditional test will hopefully
|
||||
** resolve the branch at compile time. However, since VMIN/VEOF
|
||||
|
|
@ -99,27 +109,79 @@ int scheme_tcsetattr(int fd, int option,
|
|||
*/
|
||||
|
||||
if( (VMIN != VEOF && VTIME != VEOL) || !(t.c_lflag & ICANON) ) {
|
||||
t.c_cc[VMIN] = min;
|
||||
t.c_cc[VTIME] = time;
|
||||
t.c_cc[VMIN] = s48_extract_fixnum (sch_min);
|
||||
t.c_cc[VTIME] = s48_extract_integer (sch_time);
|
||||
}
|
||||
|
||||
t.c_iflag = iflag;
|
||||
t.c_oflag = oflag;
|
||||
t.c_cflag = cflag;
|
||||
t.c_lflag = lflag;
|
||||
t.c_iflag = s48_extract_integer (sch_iflag);
|
||||
t.c_oflag = s48_extract_integer (sch_oflag);
|
||||
t.c_cflag = s48_extract_integer (sch_cflag);
|
||||
t.c_lflag = s48_extract_integer (sch_lflag);
|
||||
|
||||
cfsetispeed(&t, ispeed);
|
||||
cfsetospeed(&t, ospeed);
|
||||
cfsetispeed(&t, s48_extract_integer (sch_ispeed));
|
||||
cfsetospeed(&t, s48_extract_integer (sch_ospeed));
|
||||
|
||||
return tcsetattr(fd, option, &t);
|
||||
if (tcsetattr(s48_extract_fixnum (sch_fd), s48_extract_integer (sch_option),
|
||||
&t)
|
||||
== -1)
|
||||
s48_raise_os_error_1 (errno, sch_fd);
|
||||
return S48_UNSPECIFIC;
|
||||
}
|
||||
|
||||
|
||||
s48_value sch_tcsendbreak (s48_value sch_fd, s48_value sch_duration)
|
||||
{
|
||||
if (tcsendbreak (s48_extract_fixnum (sch_fd),
|
||||
s48_extract_integer (sch_duration)) == -1)
|
||||
s48_raise_os_error_2 (errno, sch_fd, sch_duration);
|
||||
return S48_UNSPECIFIC;
|
||||
}
|
||||
|
||||
s48_value sch_tcdrain (s48_value sch_fd)
|
||||
{
|
||||
if (tcdrain (s48_extract_fixnum (sch_fd)) == -1)
|
||||
s48_raise_os_error_1 (errno, sch_fd);
|
||||
return S48_UNSPECIFIC;
|
||||
}
|
||||
|
||||
s48_value sch_tcflush (s48_value sch_fd, s48_value sch_action)
|
||||
{
|
||||
if (tcflush (s48_extract_fixnum (sch_fd),
|
||||
s48_extract_fixnum (sch_action)) == -1)
|
||||
s48_raise_os_error_2 (errno, sch_fd, sch_action);
|
||||
return S48_UNSPECIFIC;
|
||||
}
|
||||
|
||||
s48_value sch_tcflow (s48_value sch_fd, s48_value sch_action)
|
||||
{
|
||||
if (tcflow (s48_extract_fixnum (sch_fd),
|
||||
s48_extract_fixnum (sch_action)) == -1)
|
||||
s48_raise_os_error_2 (errno, sch_fd, sch_action);
|
||||
return S48_UNSPECIFIC;
|
||||
}
|
||||
|
||||
s48_value sch_tcsetpgrp (s48_value sch_fd, s48_value sch_pid)
|
||||
{
|
||||
if (tcsetpgrp (s48_extract_fixnum (sch_fd),
|
||||
s48_extract_fixnum (sch_pid)) == -1)
|
||||
s48_raise_os_error_2 (errno, sch_fd, sch_pid);
|
||||
return S48_UNSPECIFIC;
|
||||
}
|
||||
|
||||
s48_value sch_tcgetpgrp (s48_value sch_fd)
|
||||
{
|
||||
int ret = tcgetpgrp (s48_extract_fixnum (sch_fd));
|
||||
if (ret == -1)
|
||||
s48_raise_os_error_1 (errno, sch_fd);
|
||||
return s48_enter_integer (ret);
|
||||
}
|
||||
|
||||
/*****************************************************************************/
|
||||
|
||||
int open_ctty(const char *ttyname, int flags)
|
||||
s48_value open_ctty(s48_value sch_ttyname, s48_value sch_flags)
|
||||
{
|
||||
int fd = open(ttyname, flags);
|
||||
int fd = open(s48_extract_string (sch_ttyname),
|
||||
s48_extract_integer (sch_flags));
|
||||
|
||||
#if defined(TIOCSCTTY) && !defined(CIBAUD) && !defined(__hpux)
|
||||
/* 4.3+BSD way to acquire control tty. !CIBAUD rules out SunOS.
|
||||
|
|
@ -128,11 +190,47 @@ int open_ctty(const char *ttyname, int flags)
|
|||
if( (fd >= 0) && (ioctl(fd, TIOCSCTTY, (char *) 0) < 0) ) {
|
||||
int e = errno;
|
||||
close(fd);
|
||||
errno = e;
|
||||
return -1;
|
||||
s48_raise_os_error_2 (e, sch_ttyname, sch_flags);
|
||||
}
|
||||
#endif
|
||||
return fd;
|
||||
}
|
||||
if (fd == -1)
|
||||
s48_raise_os_error_2 (errno, sch_ttyname, sch_flags);
|
||||
return s48_enter_fixnum (fd);
|
||||
}
|
||||
|
||||
char *scm_ctermid() { return ctermid(0); }
|
||||
s48_value sch_isatty (s48_value sch_fd)
|
||||
{
|
||||
return ((isatty (s48_extract_fixnum (sch_fd))) ? S48_TRUE : S48_FALSE);
|
||||
}
|
||||
|
||||
s48_value sch_ttyname (s48_value sch_fd)
|
||||
{
|
||||
char* ret = ttyname (s48_extract_fixnum (sch_fd));
|
||||
if (ret == NULL)
|
||||
s48_raise_os_error_1 (errno, sch_fd);
|
||||
return s48_enter_string (ret);
|
||||
}
|
||||
|
||||
s48_value scm_ctermid()
|
||||
{
|
||||
char* ret = ctermid(0);
|
||||
if (ret == NULL)
|
||||
s48_raise_os_error (errno);
|
||||
return s48_enter_string (ret);
|
||||
}
|
||||
|
||||
void s48_init_tty(void)
|
||||
{
|
||||
S48_EXPORT_FUNCTION(scheme_tcgetattr);
|
||||
S48_EXPORT_FUNCTION(scheme_tcsetattr);
|
||||
S48_EXPORT_FUNCTION(sch_tcsendbreak);
|
||||
S48_EXPORT_FUNCTION(sch_tcdrain);
|
||||
S48_EXPORT_FUNCTION(sch_tcflush);
|
||||
S48_EXPORT_FUNCTION(sch_tcflow);
|
||||
S48_EXPORT_FUNCTION(sch_tcsetpgrp);
|
||||
S48_EXPORT_FUNCTION(sch_tcgetpgrp);
|
||||
S48_EXPORT_FUNCTION(open_ctty);
|
||||
S48_EXPORT_FUNCTION(sch_isatty);
|
||||
S48_EXPORT_FUNCTION(sch_ttyname);
|
||||
S48_EXPORT_FUNCTION(scm_ctermid);
|
||||
}
|
||||
|
|
|
|||
39
scsh/tty1.h
39
scsh/tty1.h
|
|
@ -1,21 +1,28 @@
|
|||
/* Exports from tty1.c. */
|
||||
|
||||
int scheme_tcgetattr(int fd, char *control_chars,
|
||||
int *iflag,
|
||||
int *oflag,
|
||||
int *cflag,
|
||||
int *lflag,
|
||||
int *ispeed, int *ospeed);
|
||||
s48_value scheme_tcgetattr(s48_value sch_fd,s48_value sch_control_chars);
|
||||
|
||||
int scheme_tcsetattr(int fd, int option,
|
||||
const char *control_chars,
|
||||
int iflag,
|
||||
int oflag,
|
||||
int cflag,
|
||||
int lflag,
|
||||
int ispeed, int ospeed,
|
||||
int min, int time);
|
||||
s48_value scheme_tcsetattr(s48_value fd, s48_value option,
|
||||
s48_value control_chars,
|
||||
s48_value iflag,
|
||||
s48_value oflag,
|
||||
s48_value cflag,
|
||||
s48_value lflag,
|
||||
s48_value ispeed, s48_value ospeed,
|
||||
s48_value min, s48_value time);
|
||||
s48_value sch_tcsendbreak (s48_value sch_fd, s48_value sch_duration);
|
||||
s48_value sch_tcdrain (s48_value sch_fd);
|
||||
s48_value sch_tcflush (s48_value sch_fd, s48_value sch_action);
|
||||
s48_value sch_tcflow (s48_value sch_fd, s48_value sch_action);
|
||||
s48_value sch_tcsetpgrp (s48_value sch_fd, s48_value sch_pid);
|
||||
s48_value sch_tcgetpgrp (s48_value sch_fd);
|
||||
|
||||
s48_value open_ctty(s48_value sch_ttyname, s48_value sch_flags);
|
||||
|
||||
s48_value sch_isatty (s48_value sch_fd);
|
||||
|
||||
s48_value sch_ttyname (s48_value sch_fd);
|
||||
|
||||
s48_value scm_ctermid();
|
||||
|
||||
int open_ctty(const char *ttyname, int flags);
|
||||
|
||||
char *scm_ctermid(void);
|
||||
|
|
|
|||
Loading…
Reference in New Issue