s48_ref_t sch_tcsendbreak(s48_call_t call, s48_ref_t sch_fd, s48_ref_t sch_duration) {
if (tcsendbreak (s48_extract_long_2(call, sch_fd),
s48_extract_long_2(call, sch_duration)) == -1)
s48_os_error_2(call, "sch_tcsendbreak", errno, 2, sch_fd, sch_duration);
return s48_unspecific_2(call);
}
static s48_ref_t
posix_pipe(s48_call_t call)
{ int fildes[2],
status;
s48_ref_t in_channel, out_channel;
s48_ref_t id = s48_enter_string_latin_1_2 (call, "pipe");
RETRY_OR_RAISE_NEG(status, pipe(fildes));
in_channel = s48_add_channel_2(call, s48_channel_status_input_2(call), id, fildes[0]);
if (!s48_channel_p_2(call, in_channel)) {
ps_close_fd(fildes[0]); /* retries if interrupted */
ps_close_fd(fildes[1]); /* retries if interrupted */
s48_raise_scheme_exception_2(call, s48_extract_long_2(call, in_channel), 0); }
RETRY_OR_RAISE_NEG(status, fcntl(fildes[1], F_SETFL, O_NONBLOCK));
out_channel = s48_add_channel_2(call, s48_channel_status_output_2(call), id, fildes[1]);
if (!s48_channel_p_2(call, out_channel)) {
s48_close_channel(fildes[0]);
ps_close_fd(fildes[1]); /* retries if interrupted */
s48_raise_scheme_exception_2(call, s48_extract_long_2(call, in_channel), 0); }
return s48_cons_2(call, in_channel, out_channel);
}
static s48_ref_t
posix_initialize_named_errnos(s48_call_t call)
{
int i, length;
s48_ref_t named_errnos;
s48_shared_binding_check_2(call, posix_errnos_vector_binding);
named_errnos = s48_shared_binding_ref_2(call, posix_errnos_vector_binding);
if(! s48_vector_p_2(call, named_errnos))
s48_assertion_violation_2(call,
"posix_initialize_named_errnos", "not a vector", 1,
named_errnos);
length = s48_unsafe_vector_length_2(call, named_errnos);
for(i = 0; i < length; i++) {
s48_ref_t named_errno = s48_unsafe_vector_ref_2(call, named_errnos, i);
int canonical = s48_extract_long_2(call, s48_unsafe_record_ref_2(call, named_errno, 1));
int c_errno = errno_map[canonical];
s48_ref_t scm_errno = (c_errno == -1) ?
s48_false_2(call) :
s48_enter_long_2(call, c_errno);
s48_unsafe_record_set_2(call, named_errno, 2, scm_errno); }
return s48_unspecific_2(call);
}
s48_ref_t scheme_tcgetattr(s48_call_t call, s48_ref_t sch_fd,
s48_ref_t sch_control_chars) {
struct termios t;
int fd = s48_extract_long_2(call, sch_fd);
int i;
int result;
s48_ref_t sch_iflag = s48_unspecific_2(call);
s48_ref_t sch_oflag = s48_unspecific_2(call);
s48_ref_t sch_cflag = s48_unspecific_2(call);
s48_ref_t sch_lflag = s48_unspecific_2(call);
s48_ref_t sch_ispeed = s48_unspecific_2(call);
s48_ref_t sch_ospeed = s48_unspecific_2(call);
s48_ref_t sch_retval = s48_unspecific_2(call);
if (isatty(fd) == 0) {
fprintf(stderr, "%d is not a tty\n", fd);
return s48_false_2(call);
}
result = tcgetattr(s48_extract_long_2(call, sch_fd), &t);
if (result == -1) {
s48_os_error_2(call, "scheme_tcgetattr", errno, 2, sch_fd, sch_control_chars);
}
for (i = 0; i < NCCS; i++)
s48_string_set_2(call, sch_control_chars, i, t.c_cc[i]);
{
sch_iflag = s48_enter_long_2(call, t.c_iflag);
sch_oflag = s48_enter_long_2(call, t.c_oflag);
sch_cflag = s48_enter_long_2(call, t.c_cflag);
sch_lflag = s48_enter_long_2(call, t.c_lflag);
sch_ispeed = s48_enter_long_2(call, cfgetispeed(&t));
sch_ospeed = s48_enter_long_2(call, cfgetospeed(&t));
sch_retval = s48_cons_2(call, sch_ospeed, s48_null_2(call));
sch_retval = s48_cons_2(call, sch_ispeed, sch_retval);
sch_retval = s48_cons_2(call, sch_lflag, sch_retval);
sch_retval = s48_cons_2(call, sch_cflag, sch_retval);
sch_retval = s48_cons_2(call, sch_oflag, sch_retval);
sch_retval = s48_cons_2(call, sch_iflag, sch_retval);
return sch_retval;
}
}
/* The order of these is known to the Scheme code. */
static int
extract_syslog_options(s48_call_t call, s48_ref_t sch_syslog_options)
{
long options = s48_extract_long_2(call, sch_syslog_options);
return
(00001 & options ? LOG_CONS : 0) |
(00002 & options ? LOG_ODELAY : 0) |
(00004 & options ? LOG_NDELAY : 0) |
(00010 & options ? LOG_PID : 0);
(00020 & options ? LOG_NOWAIT : 0);
}
static s48_ref_t
posix_dup(s48_call_t call, s48_ref_t channel, s48_ref_t new_mode)
{
int new_fd, old_fd, flags;
long status;
s48_ref_t s48_status;
s48_ref_t old_mode;
s48_ref_t new_channel;
if (!s48_channel_p_2(call, channel) ||
s48_eq_p_2(call, s48_channel_status_2(call, channel), s48_channel_status_closed_2(call)))
s48_assertion_violation_2(call, "posix_dup", "not an open channel", 1, channel);
old_fd = s48_unsafe_extract_long_2(call, s48_unsafe_channel_os_index_2(call, channel));
old_mode = s48_unsafe_channel_status_2(call, channel);
RETRY_OR_RAISE_NEG(new_fd, dup(old_fd));
s48_status = s48_set_channel_os_index_2(call, channel, new_fd);
if (!s48_true_p_2(call, s48_status)) {
ps_close_fd(new_fd); /* retries if interrupted */
s48_raise_scheme_exception_2(call, s48_extract_long_2(call, s48_status), 1, channel); }
if (s48_eq_p_2(call, new_mode, s48_channel_status_output_2(call))
&& s48_eq_p_2(call, old_mode, s48_channel_status_input_2(call))) {
RETRY_OR_RAISE_NEG(flags, fcntl(new_fd, F_GETFL));
RETRY_OR_RAISE_NEG(status, fcntl(new_fd, F_SETFL, flags | O_NONBLOCK)); }
new_channel = s48_add_channel_2(call,
s48_false_p_2(call, new_mode) ? old_mode : new_mode,
s48_unsafe_channel_id_2(call, channel),
old_fd);
if (!s48_channel_p_2(call, new_channel)) {
ps_close_fd(old_fd); /* retries if interrupted */
s48_raise_scheme_exception_2(call, s48_extract_long_2(call, new_channel), 1, channel); }
return new_channel;
}
s48_ref_t make_ctty(s48_call_t call, s48_ref_t sch_fd) {
int fd = s48_extract_long_2(call, sch_fd);
#if defined(TIOCSCTTY) && !defined(CIBAUD) && !defined(__hpux)
/* 4.3+BSD way to acquire control tty. !CIBAUD rules out SunOS.
** This code stolen from Steven's *Advanced Prog. in the Unix Env.*
*/
if( (fd >= 0) && (ioctl(fd, TIOCSCTTY, (char *) 0) < 0) ) {
s48_os_error_2(call, "make_ctty", errno, 1, sch_fd);
}
#endif
return s48_unspecific_2(call);
}
static s48_ref_t
posix_dup2(s48_call_t call, s48_ref_t channel, s48_ref_t new_fd)
{
s48_ref_t new_channel;
s48_ref_t s48_status;
int status;
int new_c_fd, old_c_fd;
if (!s48_channel_p_2(call, channel) ||
s48_eq_p_2(call, s48_channel_status_2(call, channel), s48_channel_status_closed_2(call)))
s48_assertion_violation_2(call, "posix_dup2", "not an open channel", 1, channel);
if (!s48_fixnum_p_2(call, new_fd) || new_fd < 0)
s48_assertion_violation_2(call, "posix_dup2", "fd not a nonnegative fixnum", 1, new_fd);
old_c_fd = s48_extract_long_2(call, s48_unsafe_channel_os_index_2(call, channel));
new_c_fd = s48_extract_long_2(call, new_fd);
s48_close_channel(new_c_fd);
RETRY_OR_RAISE_NEG(status, dup2(old_c_fd, new_c_fd));
s48_status = s48_set_channel_os_index_2(call, channel, new_c_fd);
if (!s48_true_p_2(call, s48_status)) {
ps_close_fd(new_c_fd); /* retries if interrupted */
s48_raise_scheme_exception_2(call, s48_extract_long_2(call, s48_status), 1, channel); }
new_channel = s48_add_channel_2(call,
s48_unsafe_channel_status_2(call, channel),
s48_unsafe_channel_id_2(call, channel),
old_c_fd);
if (!s48_channel_p_2(call, new_channel)) {
ps_close_fd(old_c_fd); /* retries if interrupted */
s48_raise_scheme_exception_2(call, s48_extract_long_2(call, new_channel), 1, channel); }
return new_channel;
}
s48_ref_t scheme_tcsetattr(s48_call_t call, s48_ref_t sch_fd, s48_ref_t sch_option,
s48_ref_t sch_control_chars,
s48_ref_t sch_iflag,
s48_ref_t sch_oflag,
s48_ref_t sch_cflag,
s48_ref_t sch_lflag,
s48_ref_t sch_ispeed, s48_ref_t sch_ospeed,
s48_ref_t sch_min, s48_ref_t sch_time) {
struct termios t;
memcpy(t.c_cc, s48_extract_latin_1_from_string_2(call, sch_control_chars), NCCS);
/* This first clause of this conditional test will hopefully
** resolve the branch at compile time. However, since VMIN/VEOF
** and VTIME/VEOL are allowed by POSIX to colllide, we have to check.
** If they do collide, we set EOF & EOL in canonical mode, and MIN & TIME
** in raw mode. Ah, Unix.
*/
t.c_iflag = s48_extract_long_2(call, sch_iflag);
t.c_oflag = s48_extract_long_2(call, sch_oflag);
t.c_cflag = s48_extract_long_2(call, sch_cflag);
t.c_lflag = s48_extract_long_2(call, sch_lflag);
if( (VMIN != VEOF && VTIME != VEOL) || !(t.c_lflag & ICANON) ) {
t.c_cc[VMIN] = s48_extract_long_2(call, sch_min);
t.c_cc[VTIME] = s48_extract_long_2(call, sch_time);
}
cfsetispeed(&t, s48_extract_long_2(call, sch_ispeed));
cfsetospeed(&t, s48_extract_long_2(call, sch_ospeed));
if (tcsetattr(s48_extract_long_2(call, sch_fd),
s48_extract_long_2(call, sch_option),
&t)
== -1)
s48_os_error_2(call, "scheme_tcsetattr", errno, 1, sch_fd);
return s48_unspecific_2(call);
}
static int
extract_syslog_mask(s48_call_t call, s48_ref_t sch_syslog_mask)
{
long syslog_mask = s48_extract_long_2(call, sch_syslog_mask);
return
(00001 & syslog_mask ? LOG_MASK(LOG_EMERG) : 0) |
(00002 & syslog_mask ? LOG_MASK(LOG_ALERT) : 0) |
(00004 & syslog_mask ? LOG_MASK(LOG_CRIT) : 0) |
(00010 & syslog_mask ? LOG_MASK(LOG_ERR) : 0) |
(00010 & syslog_mask ? LOG_MASK(LOG_WARNING) : 0) |
(00010 & syslog_mask ? LOG_MASK(LOG_NOTICE) : 0) |
(00010 & syslog_mask ? LOG_MASK(LOG_INFO) : 0) |
(00020 & syslog_mask ? LOG_MASK(LOG_DEBUG) : 0);
}
s48_ref_t open_ctty(s48_call_t call, s48_ref_t sch_ttyname, s48_ref_t sch_flags) {
int fd = open(s48_extract_byte_vector_2(call, sch_ttyname),
s48_extract_long_2(call, sch_flags));
#if defined(TIOCSCTTY) && !defined(CIBAUD) && !defined(__hpux)
/* 4.3+BSD way to acquire control tty. !CIBAUD rules out SunOS.
** This code stolen from Steven's *Advanced Prog. in the Unix Env.*
*/
if( (fd >= 0) && (ioctl(fd, TIOCSCTTY, (char *) 0) < 0) ) {
int e = errno;
close(fd);
s48_os_error_2(call, "open_ctty", e, 2, sch_ttyname, sch_flags);
}
#endif
if (fd == -1)
s48_os_error_2(call, "open_ctty", errno, 2, sch_ttyname, sch_flags);
return s48_enter_long_2(call, fd);
}
s48_ref_t pty2tty(s48_call_t call, s48_ref_t sch_fd) {
int fd = s48_extract_long_2(call, sch_fd);
#if defined (HAVE_ISASTREAM) && defined (I_PUSH)
if (isastream (fd))
{
# if defined (I_FIND)
# define stream_module_pushed(fd, module) (ioctl (fd, I_FIND, module) == 1)
# else
# define stream_module_pushed(fd, module) 0
# endif
if ((! stream_module_pushed (fd, "ptem")) &&
(ioctl (fd, I_PUSH, "ptem") < 0))
s48_os_error_2(call, "pty2tty", errno, 1, sch_fd);
if ((! stream_module_pushed (fd, "ldterm")) &&
(ioctl (fd, I_PUSH, "ldterm") < 0))
s48_os_error_2(call, "pty2tty", errno, 1, sch_fd);
if ((! stream_module_pushed (fd, "ttcompat")) &&
(ioctl (fd, I_PUSH, "ttcompat") < 0))
s48_os_error_2(call, "pty2tty", errno, 1, sch_fd);
}
#endif /* defined (HAVE_ISASTREAM) && defined (I_PUSH) */
return s48_unspecific_2(call);
}
static int
extract_syslog_facility(s48_call_t call, s48_ref_t sch_syslog_facility)
{
return syslog_facilities[s48_extract_long_2(call, sch_syslog_facility)];
}
static int
extract_syslog_level(s48_call_t call, s48_ref_t sch_syslog_level)
{
return syslog_levels[s48_extract_long_2(call, sch_syslog_level)];
}
s48_ref_t sch_tcdrain(s48_call_t call, s48_ref_t sch_fd) {
if (tcdrain (s48_extract_long_2(call, sch_fd)) == -1)
s48_os_error_2(call, "sch_tcdrain", errno, 1, sch_fd);
return s48_unspecific_2(call);
}
s48_ref_t sch_tcflow(s48_call_t call, s48_ref_t sch_fd, s48_ref_t sch_action) {
if (tcflow (s48_extract_long_2(call, sch_fd),
s48_extract_long_2(call, sch_action)) == -1)
s48_os_error_2(call, "sch_tcflow", errno, 2, sch_fd, sch_action);
return s48_unspecific_2(call);
}
s48_ref_t sch_ttyname(s48_call_t call, s48_ref_t sch_fd) {
char* ret = ttyname (s48_extract_long_2(call, sch_fd));
if (ret == NULL)
s48_os_error_2(call, "sch_ttyname", errno, 1, sch_fd);
return s48_enter_byte_string_2(call, ret);
}
s48_ref_t sch_isatty(s48_call_t call, s48_ref_t sch_fd) {
return ((isatty (s48_extract_long_2(call, sch_fd))) ? s48_true_2(call) : s48_false_2(call));
}
s48_ref_t sch_tcsetpgrp (s48_call_t call, s48_ref_t sch_fd, s48_ref_t sch_pid) {
if (tcsetpgrp (s48_extract_long_2(call, sch_fd),
s48_extract_long_2(call, sch_pid)) == -1)
s48_os_error_2(call, "sch_tcsetpgrp", errno, 2, sch_fd, sch_pid);
return s48_unspecific_2(call);
}
s48_ref_t sch_tcgetpgrp(s48_call_t call, s48_ref_t sch_fd) {
int ret = tcgetpgrp (s48_extract_long_2(call, sch_fd));
if (ret == -1)
s48_os_error_2(call, "sch_tcgetpgrp", errno, 1, sch_fd);
return s48_enter_long_2(call, ret);
}
