From a36dbe8904f155215956376ea264ecbf3887ce9d Mon Sep 17 00:00:00 2001 From: mainzelm Date: Fri, 7 Sep 2001 15:17:54 +0000 Subject: [PATCH] Decigged tty. --- scsh/tty.c | 261 --------------------------------------------------- scsh/tty.scm | 192 +++++++++++-------------------------- scsh/tty1.c | 184 +++++++++++++++++++++++++++--------- scsh/tty1.h | 39 ++++---- 4 files changed, 218 insertions(+), 458 deletions(-) delete mode 100644 scsh/tty.c diff --git a/scsh/tty.c b/scsh/tty.c deleted file mode 100644 index 15602fd..0000000 --- a/scsh/tty.c +++ /dev/null @@ -1,261 +0,0 @@ -/* This is an Scheme48/C interface file, -** automatically generated by a hacked version of cig 3.0. -step 4 -*/ - -#include -#include /* For malloc. */ -#include "libcig.h" - -#include - -#include -#include - -/* 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); -} diff --git a/scsh/tty.scm b/scsh/tty.scm index 86db0ab..2d7e559 100644 --- a/scsh/tty.scm +++ b/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 " - "" - "#include " - "#include " - "" - "/* 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) diff --git a/scsh/tty1.c b/scsh/tty1.c index 1850f4c..3ef5b33 100644 --- a/scsh/tty1.c +++ b/scsh/tty1.c @@ -16,6 +16,7 @@ #include #include #include +#include #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); +} diff --git a/scsh/tty1.h b/scsh/tty1.h index a415886..eb05d83 100644 --- a/scsh/tty1.h +++ b/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);