Update of /cvsroot/scsh/scsh-0.6/scsh
In directory usw-pr-cvs1:/tmp/cvs-serv17602/scsh
Modified Files:
tty.scm tty1.c tty1.h
Removed Files:
tty.c
Log Message:
Decigged tty.
Index: tty.scm
===================================================================
RCS file: /cvsroot/scsh/scsh-0.6/scsh/tty.scm,v
retrieving revision 1.5
retrieving revision 1.6
diff -C2 -r1.5 -r1.6
*** tty.scm 1999/10/08 18:34:44 1.5
--- tty.scm 2001/09/07 15:17:54 1.6
***************
*** 14,35 ****
;;; 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
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
--- 14,17 ----
***************
*** 128,135 ****
(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)))
(make-%tty-info control-chars
iflag
--- 110,115 ----
(define (tty-info fdport)
(let ((control-chars (make-string num-ttychars)))
! (apply
! (lambda (iflag oflag cflag lflag ispeed-code ospeed-code)
(make-%tty-info control-chars
iflag
***************
*** 140,176 ****
(decode-baud-rate ospeed-code) ospeed-code
(char->ascii (string-ref control-chars ttychar/min))
! (char->ascii (string-ref control-chars ttychar/time))))))
! (define-errno-syscall (%tty-info fdes control-chars) %tty-info/errno
! iflag
! oflag
! 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
! ("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 (%%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)))
--- 120,148 ----
(decode-baud-rate ospeed-code) ospeed-code
(char->ascii (string-ref control-chars ttychar/min))
! (char->ascii (string-ref control-chars ttychar/time))))
! (sleazy-call/fdes fdport (lambda (fd) (%tty-info fd control-chars))))))
! (define-stubless-foreign %tty-info/eintr (fdes control-chars)
! "scheme_tcgetattr")
! (define-retrying-syscall %tty-info %tty-info/eintr)
!
!
! ;;; 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 (%%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,239 ****
(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))
;;; Exported procs
--- 182,191 ----
(tty-info:time info))))))
+ (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,268 ****
(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))
;;; Drain the main vein.
--- 209,216 ----
(lambda (fdes)
(%send-tty-break-fdes fdes (:optional maybe-duration 0)))))
+ (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.
***************
*** 276,284 ****
(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))
-
;;; Flushing the device queues. (tcflush)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
--- 224,230 ----
(else (error "Illegal argument to DRAIN-TTY" fdport))))
! (define-stubless-foreign %tcdrain/eintr (fdes) "sch_tcdrain")
! (define-retrying-syscall %tcdrain %tcdrain/eintr)
;;; Flushing the device queues. (tcflush)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
***************
*** 293,302 ****
(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))
;;; Stopping and starting I/O (tcflow)
--- 239,245 ----
(define flush-tty/output (make-tty-flusher %flush-tty/output))
(define flush-tty/both (make-tty-flusher %flush-tty/both))
+ (define-stubless-foreign %tcflush/eintr (fdes flag) "sch_tcflush")
+ (define-retrying-syscall %tcflush %tcflush/eintr)
;;; Stopping and starting I/O (tcflow)
***************
*** 313,323 ****
(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))
;;; Baud rate translation
--- 256,262 ----
(define start-tty-input (make-flow-controller %tcflow/start-in))
(define stop-tty-input (make-flow-controller %tcflow/stop-in))
+ (define-stubless-foreign %tcflow/eintr (fdes action) "sch_tcflow")
+ (define-retrying-syscall %tcflow %tcflow/eintr)
;;; Baud rate translation
***************
*** 349,370 ****
(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 (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))
;;; (open-control-tty fname [flags])
--- 288,299 ----
(proc:pid proc-group))))))
! (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-stubless-foreign %tty-process-group/eintr (fdes) "sch_tcgetpgrp")
! (define-retrying-syscall %tty-process-group %tty-process-group/eintr)
;;; (open-control-tty fname [flags])
***************
*** 378,398 ****
(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))
;;; Random bits & pieces: isatty ttyname ctermid
--- 307,320 ----
(define (open-control-tty ttyname . maybe-flags)
(let ((flags (:optional maybe-flags open/read+write)))
! (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
***************
*** 402,420 ****
;;; (control-tty-file-name) -> string
! (define-foreign %tty? (isatty (integer fd)) bool)
(define (tty? fd/port) (sleazy-call/fdes fd/port %tty?))
- (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)
--- 324,336 ----
;;; (control-tty-file-name) -> string
! (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 (tty-file-name fd/port) (sleazy-call/fdes fd/port %tty-file-name))
! (define-stubless-foreign %ctermid/eintr () "scm_ctermid")
! (define-retrying-syscall control-tty-file-name %ctermid/eintr)
Index: tty1.c
===================================================================
RCS file: /cvsroot/scsh/scsh-0.6/scsh/tty1.c,v
retrieving revision 1.4
retrieving revision 1.5
diff -C2 -r1.4 -r1.5
*** tty1.c 1999/11/04 20:10:28 1.4
--- tty1.c 2001/09/07 15:17:54 1.5
***************
*** 17,20 ****
--- 17,21 ----
#include <string.h>
#include <sys/types.h>
+ #include <errno.h>
#include "scheme48.h"
***************
*** 28,58 ****
#include "tty1.h" /* Make sure the .h interface agrees with the code. */
- extern int errno;
-
/*****************************************************************************/
! int scheme_tcgetattr(int fd, char *control_chars,
! int *iflag,
int *oflag,
int *cflag,
int *lflag,
! int *ispeed, int *ospeed)
{
struct termios t;
! int result = tcgetattr(fd, &t);
! 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;
! }
int scheme_tcgetattrB(int fd, char *control_chars, s48_value scmvec)
{
--- 29,68 ----
#include "tty1.h" /* Make sure the .h interface agrees with the code. */
/*****************************************************************************/
+ // 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))))));
+ }
! 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)*/
{
struct termios t;
! int result = tcgetattr(s48_extract_fixnum (sch_fd), &t);
! int i;
! 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)
{
***************
*** 79,94 ****
/*****************************************************************************/
! 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)
{
struct termios t;
! memcpy(t.c_cc, control_chars, NCCS);
/* This first clause of this conditional test will hopefully
--- 89,104 ----
/*****************************************************************************/
! 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, s48_extract_string (sch_control_chars), NCCS);
/* This first clause of this conditional test will hopefully
***************
*** 100,124 ****
if( (VMIN != VEOF && VTIME != VEOL) || !(t.c_lflag & ICANON) ) {
! t.c_cc[VMIN] = min;
! t.c_cc[VTIME] = time;
}
! t.c_iflag = iflag;
! t.c_oflag = oflag;
! t.c_cflag = cflag;
! t.c_lflag = lflag;
! cfsetispeed(&t, ispeed);
! cfsetospeed(&t, ospeed);
! return tcsetattr(fd, option, &t);
}
/*****************************************************************************/
! int open_ctty(const char *ttyname, int flags)
{
! int fd = open(ttyname, flags);
#if defined(TIOCSCTTY) && !defined(CIBAUD) && !defined(__hpux)
--- 110,186 ----
if( (VMIN != VEOF && VTIME != VEOL) || !(t.c_lflag & ICANON) ) {
! t.c_cc[VMIN] = s48_extract_fixnum (sch_min);
! t.c_cc[VTIME] = s48_extract_integer (sch_time);
}
+
+ 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, s48_extract_integer (sch_ispeed));
+ cfsetospeed(&t, s48_extract_integer (sch_ospeed));
+
+ 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);
+ }
/*****************************************************************************/
! s48_value open_ctty(s48_value sch_ttyname, s48_value sch_flags)
{
! int fd = open(s48_extract_string (sch_ttyname),
! s48_extract_integer (sch_flags));
#if defined(TIOCSCTTY) && !defined(CIBAUD) && !defined(__hpux)
***************
*** 129,138 ****
int e = errno;
close(fd);
! errno = e;
! return -1;
}
#endif
! return fd;
! }
! char *scm_ctermid() { return ctermid(0); }
--- 191,236 ----
int e = errno;
close(fd);
! s48_raise_os_error_2 (e, sch_ttyname, sch_flags);
}
#endif
! if (fd == -1)
! s48_raise_os_error_2 (errno, sch_ttyname, sch_flags);
! return s48_enter_fixnum (fd);
! }
! 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);
! }
Index: tty1.h
===================================================================
RCS file: /cvsroot/scsh/scsh-0.6/scsh/tty1.h,v
retrieving revision 1.2
retrieving revision 1.3
diff -C2 -r1.2 -r1.3
*** tty1.h 1999/10/08 18:34:45 1.2
--- tty1.h 2001/09/07 15:17:54 1.3
***************
*** 1,21 ****
/* Exports from tty1.c. */
! int scheme_tcgetattr(int fd, char *control_chars,
! int *iflag,
! int *oflag,
! int *cflag,
! int *lflag,
! int *ispeed, int *ospeed);
!
! 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);
! int open_ctty(const char *ttyname, int flags);
! char *scm_ctermid(void);
--- 1,28 ----
/* Exports from tty1.c. */
! s48_value scheme_tcgetattr(s48_value sch_fd,s48_value sch_control_chars);
! 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();
!
!
--- tty.c DELETED ---
|