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);
}
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);
}
static s48_ref_t
shared_object_dlclose(s48_call_t call, s48_ref_t handle)
{
HINSTANCE native_handle = s48_extract_value_2(call, handle, HINSTANCE);
if (!FreeLibrary(native_handle) < 0)
s48_os_error_2(call, "shared_object_dlclose", GetLastError(), 1, handle);
return s48_unspecific_2(call);
}
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);
}
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);
}
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;
}
}
static s48_ref_t
shared_object_dlsym(s48_call_t call, s48_ref_t handle, s48_ref_t name)
{
void *entry;
HINSTANCE native_handle;
char *native_name;
native_handle = s48_extract_value_2(call, handle, HINSTANCE);
native_name = s48_extract_byte_vector_readonly_2(call, name);
entry = GetProcAddress(native_handle, native_name);
if (entry == NULL)
s48_os_error_2(call, "shared_object_dlsym", GetLastError(), 2,
handle, name);
return s48_enter_pointer_2(call, entry);
}
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 s48_ref_t
shared_object_dlopen(s48_call_t call, s48_ref_t name, s48_ref_t complete_name_p)
{
HINSTANCE handle;
s48_ref_t res;
char *full_name;
WCHAR* name_utf16;
size_t len = strlen(s48_extract_byte_vector_readonly_2(call, name));
if (!s48_false_p_2(call, complete_name_p))
{
full_name = s48_make_local_buf(call, len + 5);
memcpy(full_name,
s48_extract_byte_vector_readonly_2(call, name),
len);
memcpy(full_name + len,
".dll",
5);
len += 4;
}
else
full_name = s48_extract_byte_vector_readonly_2(call, name);
name_utf16 = malloc(sizeof(WCHAR) * (len + 1));
if (name_utf16 == NULL)
s48_out_of_memory_error_2(call);
s48_utf_8of16_to_utf_16(full_name, name_utf16, NULL);
handle = LoadLibraryW(name_utf16);
free(name_utf16);
if (handle == NULL)
s48_os_error_2(call, "shared_object_dlopen", GetLastError(), 1, name);
res = s48_make_value_2(call, HINSTANCE);
s48_set_value_2(call, res, HINSTANCE, handle);
return res;
}
s48_ref_t scm_ctermid(s48_call_t call) {
char* ret = ctermid(0);
if (ret == NULL)
s48_os_error_2(call, "scm_ctermid", errno, 0);
return s48_enter_byte_string_2(call, ret);
}
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_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);
}
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_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_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);
}
