scsh-conservatory
/
scsh-0.6
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Decigged tty.

This commit is contained in:
mainzelm 2001-09-07 15:17:54 +00:00
parent e6ccf4cf1f
commit a36dbe8904
4 changed files with 218 additions and 458 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

261
scsh/tty.c
View File

@ -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
View File

@ -13,24 +13,6 @@
;;; Copyright (c) 1995 by Brian D. Carlstrom. ;;; Copyright (c) 1995 by Brian D. Carlstrom.
;;; Rehacked by Olin 8/95. ;;; 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 ;;; tty-info records
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; I have to fake out my record package so I can define my very own ;;; I have to fake out my record package so I can define my very own
@ -127,10 +109,8 @@
(define (tty-info fdport) (define (tty-info fdport)
(let ((control-chars (make-string num-ttychars))) (let ((control-chars (make-string num-ttychars)))
(receive (iflag oflag (apply
cflag lflag (lambda (iflag oflag cflag lflag ispeed-code ospeed-code)
ispeed-code ospeed-code)
(sleazy-call/fdes fdport (lambda (fd) (%tty-info fd control-chars)))
(make-%tty-info control-chars (make-%tty-info control-chars
iflag iflag
oflag oflag
@ -139,38 +119,30 @@
(decode-baud-rate ispeed-code) ispeed-code (decode-baud-rate ispeed-code) ispeed-code
(decode-baud-rate ospeed-code) ospeed-code (decode-baud-rate ospeed-code) ospeed-code
(char->ascii (string-ref control-chars ttychar/min)) (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 (define-stubless-foreign %tty-info/eintr (fdes control-chars)
iflag "scheme_tcgetattr")
oflag (define-retrying-syscall %tty-info %tty-info/eintr)
cflag
lflag
ispeed-code ospeed-code)
(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 ;;; JMG: I don't know what the purpose of this code is...
("scheme_tcgetattrB" (fixnum fdes) ;(define-foreign %bogus-tty-info/errno
(var-string control-chars) ; ("scheme_tcgetattrB" (fixnum fdes)
(vector-desc ivec)) ; (var-string control-chars)
(to-scheme fixnum errno_or_false)) ; (vector-desc ivec))
; (to-scheme fixnum errno_or_false))
;(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-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 (%tty-info fdes cc) ;(define (%tty-info fdes cc)
; (let ((ivec (%%bogus-tty-info fdes cc))) ; (let ((ivec (%%bogus-tty-info fdes cc)))
@ -210,31 +182,11 @@
(tty-info:time info)))))) (tty-info:time info))))))
(define-errno-syscall (%set-tty-info fdes option (define-stubless-foreign %set-tty-info/eintr
control-chars (fdes option control-chars iflag oflag cflag lflag ispeed-code ospeed-code
iflag min time)
oflag "scheme_tcsetattr")
cflag (define-retrying-syscall %set-tty-info %set-tty-info/eintr)
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))
;;; Exported procs ;;; Exported procs
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@ -257,13 +209,9 @@
(lambda (fdes) (lambda (fdes)
(%send-tty-break-fdes fdes (:optional maybe-duration 0))))) (%send-tty-break-fdes fdes (:optional maybe-duration 0)))))
(define-errno-syscall (%send-tty-break-fdes fdes duration) (define-stubless-foreign %send-tty-break-fdes/eintr (fdes duration)
%send-tty-break-fdes/errno) "sch_tcsendbreak")
(define-retrying-syscall %send-tty-break-fdes %send-tty-break-fdes/eintr)
(define-foreign %send-tty-break-fdes/errno
(tcsendbreak (integer fdes) (integer duration))
(to-scheme integer errno_or_false))
;;; Drain the main vein. ;;; Drain the main vein.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@ -275,10 +223,8 @@
(sleazy-call/fdes fdport %tcdrain)) (sleazy-call/fdes fdport %tcdrain))
(else (error "Illegal argument to DRAIN-TTY" fdport)))) (else (error "Illegal argument to DRAIN-TTY" fdport))))
(define-errno-syscall (%tcdrain fdes) %tcdrain/errno) (define-stubless-foreign %tcdrain/eintr (fdes) "sch_tcdrain")
(define-foreign %tcdrain/errno (tcdrain (integer fdes)) no-declare ; Ultrix (define-retrying-syscall %tcdrain %tcdrain/eintr)
(to-scheme integer errno_or_false))
;;; Flushing the device queues. (tcflush) ;;; Flushing the device queues. (tcflush)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@ -293,11 +239,8 @@
(define flush-tty/output (make-tty-flusher %flush-tty/output)) (define flush-tty/output (make-tty-flusher %flush-tty/output))
(define flush-tty/both (make-tty-flusher %flush-tty/both)) (define flush-tty/both (make-tty-flusher %flush-tty/both))
(define-errno-syscall (%tcflush fdes flag) %tcflush/errno) (define-stubless-foreign %tcflush/eintr (fdes flag) "sch_tcflush")
(define-foreign %tcflush/errno (tcflush (integer fdes) (integer flag)) (define-retrying-syscall %tcflush %tcflush/eintr)
no-declare ; Ultrix
(to-scheme integer errno_or_false))
;;; Stopping and starting I/O (tcflow) ;;; Stopping and starting I/O (tcflow)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@ -313,12 +256,8 @@
(define start-tty-input (make-flow-controller %tcflow/start-in)) (define start-tty-input (make-flow-controller %tcflow/start-in))
(define stop-tty-input (make-flow-controller %tcflow/stop-in)) (define stop-tty-input (make-flow-controller %tcflow/stop-in))
(define-errno-syscall (%tcflow fdes action) %tcflow/errno) (define-stubless-foreign %tcflow/eintr (fdes action) "sch_tcflow")
(define-retrying-syscall %tcflow %tcflow/eintr)
(define-foreign %tcflow/errno
(tcflow (integer fdes) (integer action)) no-declare ; Ultrix
(to-scheme integer errno_or_false))
;;; Baud rate translation ;;; Baud rate translation
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@ -348,24 +287,14 @@
proc-group proc-group
(proc:pid proc-group)))))) (proc:pid proc-group))))))
(define-errno-syscall (%set-tty-process-group fdes pid) (define-stubless-foreign %set-tty-process-group/eintr (fdes pid) "sch_tcsetpgrp")
%set-tty-process-group/errno) (define-retrying-syscall %set-tty-process-group %set-tty-process-group/eintr)
(define-foreign %set-tty-process-group/errno (tcsetpgrp (fixnum fdes)
(pid_t pid))
no-declare ; Ultrix
(to-scheme integer errno_or_false))
(define (tty-process-group port/fd) (define (tty-process-group port/fd)
(sleazy-call/fdes port/fd %tty-process-group)) (sleazy-call/fdes port/fd %tty-process-group))
(define-errno-syscall (%tty-process-group fd) %tty-process-group/errno (define-stubless-foreign %tty-process-group/eintr (fdes) "sch_tcgetpgrp")
pid) (define-retrying-syscall %tty-process-group %tty-process-group/eintr)
(define-foreign %tty-process-group/errno (tcgetpgrp (fixnum fdes))
no-declare ; Ultrix
(multi-rep (to-scheme pid_t errno_or_false)
pid_t))
;;; (open-control-tty fname [flags]) ;;; (open-control-tty fname [flags])
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@ -377,23 +306,16 @@
(define (open-control-tty ttyname . maybe-flags) (define (open-control-tty ttyname . maybe-flags)
(let ((flags (:optional maybe-flags open/read+write))) (let ((flags (:optional maybe-flags open/read+write)))
(let lp () (let ((fd (%open-control-tty ttyname flags))
(receive (errno fd) (open-control-tty/errno ttyname flags) (access (bitwise-and flags open/access-mask)))
(cond ((not errno) ((if (or (= access open/read)
(let ((access (bitwise-and flags open/access-mask))) (= access open/read+write))
((if (or (= access open/read) make-input-fdport
(= access open/read+write)) make-output-fdport)
make-input-fdport fd 1))))
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))
(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 ;;; Random bits & pieces: isatty ttyname ctermid
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@ -401,20 +323,14 @@
;;; (tty-file-name fd/port) -> string ;;; (tty-file-name fd/port) -> string
;;; (control-tty-file-name) -> 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 (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 (tty-file-name fd/port) (sleazy-call/fdes fd/port %tty-file-name))
(define-stubless-foreign %ctermid/eintr () "scm_ctermid")
(define-foreign %ctermid/errno (scm_ctermid) (define-retrying-syscall control-tty-file-name %ctermid/eintr)
(multi-rep (to-scheme static-string errno_on_zero_or_false)
static-string))
(define-errno-syscall (control-tty-file-name) %ctermid/errno term-name)

182
scsh/tty1.c
View File

@ -16,6 +16,7 @@
#include <termios.h> #include <termios.h>
#include <string.h> #include <string.h>
#include <sys/types.h> #include <sys/types.h>
#include <errno.h>
#include "scheme48.h" #include "scheme48.h"
/* This #include is for the #ifdef'd code in open_ctty() below, and /* 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. */ #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, s48_value scheme_tcgetattr(s48_value sch_fd, s48_value sch_control_chars)
int *iflag, /* int *iflag,
int *oflag, int *oflag,
int *cflag, int *cflag,
int *lflag, int *lflag,
int *ispeed, int *ospeed) int *ispeed, int *ospeed)*/
{ {
struct termios t; struct termios t;
int result = tcgetattr(fd, &t); int result = tcgetattr(s48_extract_fixnum (sch_fd), &t);
int i;
if (result != -1) { if (result == -1)
memcpy(control_chars, t.c_cc, NCCS); s48_raise_os_error_2 (errno, sch_fd, sch_control_chars);
*iflag =t.c_iflag;
*oflag =t.c_oflag;
*cflag =t.c_cflag;
*lflag =t.c_lflag;
*ispeed=cfgetispeed(&t);
*ospeed=cfgetospeed(&t);
}
return result; 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) int scheme_tcgetattrB(int fd, char *control_chars, s48_value scmvec)
{ {
struct termios t; 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, s48_value scheme_tcsetattr(s48_value sch_fd, s48_value sch_option,
const char *control_chars, s48_value sch_control_chars,
int iflag, s48_value sch_iflag,
int oflag, s48_value sch_oflag,
int cflag, s48_value sch_cflag,
int lflag, s48_value sch_lflag,
int ispeed, int ospeed, s48_value sch_ispeed, s48_value sch_ospeed,
int min, int time) s48_value sch_min, s48_value sch_time)
{ {
struct termios t; 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 /* This first clause of this conditional test will hopefully
** resolve the branch at compile time. However, since VMIN/VEOF ** 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) ) { if( (VMIN != VEOF && VTIME != VEOL) || !(t.c_lflag & ICANON) ) {
t.c_cc[VMIN] = min; t.c_cc[VMIN] = s48_extract_fixnum (sch_min);
t.c_cc[VTIME] = time; t.c_cc[VTIME] = s48_extract_integer (sch_time);
} }
t.c_iflag = iflag; t.c_iflag = s48_extract_integer (sch_iflag);
t.c_oflag = oflag; t.c_oflag = s48_extract_integer (sch_oflag);
t.c_cflag = cflag; t.c_cflag = s48_extract_integer (sch_cflag);
t.c_lflag = lflag; t.c_lflag = s48_extract_integer (sch_lflag);
cfsetispeed(&t, ispeed); cfsetispeed(&t, s48_extract_integer (sch_ispeed));
cfsetospeed(&t, ospeed); 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) #if defined(TIOCSCTTY) && !defined(CIBAUD) && !defined(__hpux)
/* 4.3+BSD way to acquire control tty. !CIBAUD rules out SunOS. /* 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) ) { if( (fd >= 0) && (ioctl(fd, TIOCSCTTY, (char *) 0) < 0) ) {
int e = errno; int e = errno;
close(fd); close(fd);
errno = e; s48_raise_os_error_2 (e, sch_ttyname, sch_flags);
return -1;
} }
#endif #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
View File

@ -1,21 +1,28 @@
/* Exports from tty1.c. */ /* Exports from tty1.c. */
int scheme_tcgetattr(int fd, char *control_chars, 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 scheme_tcsetattr(int fd, int option, s48_value scheme_tcsetattr(s48_value fd, s48_value option,
const char *control_chars, s48_value control_chars,
int iflag, s48_value iflag,
int oflag, s48_value oflag,
int cflag, s48_value cflag,
int lflag, s48_value lflag,
int ispeed, int ospeed, s48_value ispeed, s48_value ospeed,
int min, int time); 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);