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); }