diff --git a/scsh/tty.c b/scsh/tty.c index bab93c9..698457a 100644 --- a/scsh/tty.c +++ b/scsh/tty.c @@ -6,6 +6,7 @@ #include /* For malloc. */ #include "libcig.h" +#include #include /* Make sure foreign-function stubs interface to the C funs correctly: */ @@ -106,3 +107,41 @@ scheme_value df_tcflow(long nargs, scheme_value *args) return ret1; } +scheme_value df_tcsetpgrp(long nargs, scheme_value *args) +{ + extern int tcsetpgrp(int , pid_t ); + scheme_value ret1; + int r1; + + cig_check_nargs(2, nargs, "tcsetpgrp"); + r1 = tcsetpgrp(EXTRACT_FIXNUM(args[1]), EXTRACT_FIXNUM(args[0])); + ret1 = errno_or_false(r1); + return ret1; + } + +scheme_value df_tcgetpgrp(long nargs, scheme_value *args) +{ + extern pid_t tcgetpgrp(int ); + scheme_value ret1; + pid_t r1; + + cig_check_nargs(2, nargs, "tcgetpgrp"); + r1 = tcgetpgrp(EXTRACT_FIXNUM(args[1])); + ret1 = errno_or_false(r1); + VECTOR_REF(*args,0) = ENTER_FIXNUM(r1); + return ret1; + } + +scheme_value df_open_ctty(long nargs, scheme_value *args) +{ + extern int open_ctty(const char *, int ); + scheme_value ret1; + int r1; + + cig_check_nargs(3, nargs, "open_ctty"); + r1 = open_ctty(cig_string_body(args[2]), EXTRACT_FIXNUM(args[1])); + ret1 = errno_or_false(r1); + VECTOR_REF(*args,0) = ENTER_FIXNUM(r1); + return ret1; + } + diff --git a/scsh/tty.scm b/scsh/tty.scm index 218c1fd..b4d8a0b 100644 --- a/scsh/tty.scm +++ b/scsh/tty.scm @@ -14,6 +14,7 @@ ;;; Rehacked by Olin 8/95. (foreign-source + "#include " "#include " "" "/* Make sure foreign-function stubs interface to the C funs correctly: */" @@ -280,3 +281,59 @@ (define (decode-baud-rate code) ; value of BAUD/9600 -> 9600 (car (vector-ref baud-rates code))) + + +;;; Set/Get tty process group +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(define (set-tty-process-group port/fd proc-group) + (call/fdes port/fd + (lambda (fd) + (%set-tty-process-group fd (if (integer? proc-group) + proc-group + (proc:pid proc-group)))))) + +(define-simple-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)) + (to-scheme integer errno_or_false)) + +(define (tty-process-group port/fd) + (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)) + (multi-rep (to-scheme pid_t errno_or_false) + pid_t)) + +;;; (open-control-tty fname [flags]) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Open a control tty, return a port. +;;; This procedure is only guaranteed to work when the process doesn't already +;;; have a control tty -- e.g., right after a (BECOME-PROCESS-LEADER) call. +;;; This limted functionality is about all we can provide portably across BSD, +;;; SunOS, and SVR4. + +(define (open-control-tty ttyname maybe-flags) + (let ((flags (optional-arg maybe-flags open/read+write))) + (receive (errno fd) (open-control-tty/errno ttyname flags) + (if errno + (errno-error errno open-control-tty ttyname flags) + + (let* ((access (bitwise-and flags open/access-mask)) + (port ((if (or (= access open/read) (= access open/read+write)) + make-input-fdport + make-output-fdport) + fd))) + (%install-port fd port) + port))))) + +(define-foreign open-control-tty/errno (open_ctty (string ttyname) + (fixnum flags)) + (multi-rep (to-scheme integer errno_or_false) + integer)) +