*/
-/* Primitives to perform I/O to and from files. */
+/* Primitives to make Unix subprocesses. This file is misnamed for
+ hysterical raisins -- it should be pruxproc.c. */
#include "scheme.h"
#include "prims.h"
#include "osio.h"
#include "ux.h"
-#include "uxselect.h"
#include "uxproc.h"
extern int UX_channel_descriptor (Tchannel channel);
static const char ** string_vector_arg (int arg);
static int string_vector_p (SCHEME_OBJECT vector);
static const char ** convert_string_vector (SCHEME_OBJECT vector);
-\f
-DEFINE_PRIMITIVE ("SELECT-REGISTRY-SIZE", Prim_selreg_size, 0, 0, 0)
-{
- PRIMITIVE_HEADER (0);
- PRIMITIVE_RETURN (long_to_integer (UX_select_registry_size ()));
-}
-
-DEFINE_PRIMITIVE ("SELECT-REGISTRY-LUB", Prim_selreg_lub, 0, 0, 0)
-{
- PRIMITIVE_HEADER (0);
- PRIMITIVE_RETURN (long_to_integer (UX_select_registry_lub ()));
-}
-
-DEFINE_PRIMITIVE ("SELECT-REGISTRY-CLEAR-ALL", Prim_selreg_clear_all, 1, 1, 0)
-{
- PRIMITIVE_HEADER (1);
- UX_select_registry_clear_all (STRING_ARG (1));
- PRIMITIVE_RETURN (UNSPECIFIC);
-}
-
-DEFINE_PRIMITIVE ("SELECT-REGISTRY-SET", Prim_selreg_set, 2, 2, 0)
-{
- PRIMITIVE_HEADER (2);
- UX_select_registry_set ((STRING_ARG (1)), (arg_nonnegative_integer (2)));
- PRIMITIVE_RETURN (UNSPECIFIC);
-}
-
-DEFINE_PRIMITIVE ("SELECT-REGISTRY-CLEAR", Prim_selreg_clear, 2, 2, 0)
-{
- PRIMITIVE_HEADER (2);
- UX_select_registry_clear ((STRING_ARG (1)), (arg_nonnegative_integer (2)));
- PRIMITIVE_RETURN (UNSPECIFIC);
-}
-
-DEFINE_PRIMITIVE ("SELECT-REGISTRY-IS-SET?", Prim_selreg_is_set_p, 2, 2, 0)
-{
- PRIMITIVE_HEADER (2);
- PRIMITIVE_RETURN
- (BOOLEAN_TO_OBJECT
- (UX_select_registry_is_set
- ((STRING_ARG (1)), (arg_nonnegative_integer (2)))));
-}
DEFINE_PRIMITIVE ("CHANNEL-DESCRIPTOR", Prim_channel_descriptor, 1, 1, 0)
{
PRIMITIVE_RETURN (long_to_integer (UX_channel_descriptor (arg_channel (1))));
}
\f
-DEFINE_PRIMITIVE ("SELECT-DESCRIPTOR", Prim_select_descriptor, 2, 2, 0)
-{
- PRIMITIVE_HEADER (2);
- switch (UX_select_descriptor ((arg_nonnegative_integer (1)),
- (BOOLEAN_ARG (2))))
- {
- case select_input_none:
- PRIMITIVE_RETURN (LONG_TO_UNSIGNED_FIXNUM (0));
- case select_input_argument:
- PRIMITIVE_RETURN (LONG_TO_UNSIGNED_FIXNUM (1));
- case select_input_process_status:
- PRIMITIVE_RETURN (LONG_TO_FIXNUM (-1));
- case select_input_interrupt:
- PRIMITIVE_RETURN (LONG_TO_FIXNUM (-2));
- default:
- error_external_return ();
- PRIMITIVE_RETURN (UNSPECIFIC);
- }
-}
-
-DEFINE_PRIMITIVE ("SELECT-REGISTRY-TEST", Prim_selreg_test, 3, 3, 0)
-{
- PRIMITIVE_HEADER (3);
- CHECK_ARG (3, VECTOR_P);
- {
- void * position = dstack_position;
- unsigned int lub = (UX_select_registry_lub ());
- unsigned int * fds = (dstack_alloc ((sizeof (unsigned int)) * lub));
- unsigned int nfds;
- SCHEME_OBJECT result = SHARP_F;
-
- if ((VECTOR_LENGTH (ARG_REF (3))) != lub)
- error_bad_range_arg (3);
- switch (UX_select_registry_test ((STRING_ARG (1)), (BOOLEAN_ARG (2)),
- fds, (&nfds)))
- {
- case select_input_none:
- result = (LONG_TO_UNSIGNED_FIXNUM (0));
- break;
- case select_input_argument:
- {
- unsigned int * scan_fds = fds;
- unsigned int * end_fds = (scan_fds + nfds);
- SCHEME_OBJECT * scan_vector = (VECTOR_LOC ((ARG_REF (3)), 0));
- while (scan_fds < end_fds)
- (*scan_vector++) = (LONG_TO_UNSIGNED_FIXNUM (*scan_fds++));
- }
- result = (LONG_TO_UNSIGNED_FIXNUM (nfds));
- break;
- case select_input_process_status:
- result = (LONG_TO_FIXNUM (-1));
- break;
- case select_input_interrupt:
- result = (LONG_TO_FIXNUM (-2));
- break;
- default:
- error_external_return ();
- break;
- }
- dstack_set_position (position);
- PRIMITIVE_RETURN (result);
- }
-}
-\f
#define PROCESS_CHANNEL_ARG(arg, type, channel) \
{ \
if ((ARG_REF (arg)) == SHARP_F) \
#include "prims.h"
#include "ux.h"
#include "uxio.h"
-#include "uxselect.h"
#include "uxproc.h"
\f
Tchannel OS_channel_table_size;
struct channel * channel_table;
#ifndef HAVE_POLL
-static SELECT_TYPE input_descriptors;
#ifdef HAVE_SELECT
static struct timeval zero_timeout;
#endif
}
add_reload_cleanup (UX_channel_close_all);
#ifndef HAVE_POLL
- FD_ZERO (&input_descriptors);
#ifdef HAVE_SELECT
(zero_timeout . tv_sec) = 0;
(zero_timeout . tv_usec) = 0;
}
#endif /* not HAVE_POLL */
-\f
-#ifdef HAVE_POLL
-
-/* poll(2) */
-
-unsigned int
-UX_select_registry_size (void)
-{
- return ((sizeof (struct pollfd)) * OS_channel_table_size);
-}
-
-unsigned int
-UX_select_registry_lub (void)
-{
- return (OS_channel_table_size);
-}
-
-void
-UX_select_registry_clear_all (void * fds)
-{
- struct pollfd * scan = fds;
- struct pollfd * end = (scan + OS_channel_table_size);
- for (; (scan < end); scan += 1)
- {
- (scan -> fd) = (-1);
- (scan -> events) = 0;
- }
-}
-
-void
-UX_select_registry_set (void * fds, unsigned int fd)
-{
- struct pollfd * scan = fds;
- struct pollfd * end = (scan + OS_channel_table_size);
- for (; (scan < end); scan += 1)
- if (((scan -> fd) == (-1)) || ((scan -> fd) == fd))
- {
- (scan -> fd) = fd;
- (scan -> events) = POLLIN;
- break;
- }
-}
-
-void
-UX_select_registry_clear (void * fds, unsigned int fd)
-{
- struct pollfd * scan = fds;
- struct pollfd * end = (scan + OS_channel_table_size);
- for (; (scan < end); scan += 1)
- if ((scan -> fd) == fd)
- {
- /* Shift any subsequent entries down. */
- for (; (((scan + 1) < end) && ((scan -> fd) != (-1))); scan += 1)
- (*scan) = (* (scan + 1));
- (scan -> fd) = (-1);
- (scan -> events) = 0;
- return;
- }
-}
-
-int
-UX_select_registry_is_set (void * fds, unsigned int fd)
-{
- struct pollfd * scan = fds;
- struct pollfd * end = (scan + OS_channel_table_size);
- for (; (scan < end); scan += 1)
- if ((scan -> fd) == fd)
- return (1);
- return (0);
-}
-
-static unsigned int
-count_select_registry_entries (struct pollfd * pfds)
-{
- struct pollfd * end = (pfds + OS_channel_table_size);
- struct pollfd * scan;
- for (scan = pfds; (scan < end); scan += 1)
- if ((scan -> fd) == (-1))
- break;
- return (scan - pfds);
-}
-
-enum select_input
-UX_select_registry_test (void * input_fds,
- int blockp,
- unsigned int * output_fds,
- unsigned int * output_nfds)
-{
- struct pollfd * pfds = input_fds;
- unsigned int n_pfds = (count_select_registry_entries (pfds));
- while (1)
- {
- int nfds = (poll (pfds, n_pfds, (blockp ? INFTIM : 0)));
- if (nfds > 0)
- {
- if (output_nfds != 0)
- (*output_nfds) = nfds;
- if (output_fds != 0)
- {
- struct pollfd * scan = pfds;
- struct pollfd * end = (scan + n_pfds);
- while (scan < end)
- {
- if (((scan -> fd) != (-1)) && ((scan -> revents) != 0))
- {
- (*output_fds++) = (scan -> fd);
- if ((--nfds) == 0)
- break;
- }
- scan += 1;
- }
- }
- return (select_input_argument);
- }
- else if (nfds == 0)
- {
- if (!blockp)
- return (select_input_none);
- }
- else if (! ((errno == EINTR) || (errno == EAGAIN)))
- error_system_call (errno, syscall_select);
- else if (OS_process_any_status_change ())
- return (select_input_process_status);
- if (pending_interrupts_p ())
- return (select_input_interrupt);
- }
-}
-
-enum select_input
-UX_select_descriptor (unsigned int fd, int blockp)
-{
- struct pollfd pfds [1];
- int nfds;
-
- ((pfds [0]) . fd) = fd;
- ((pfds [0]) . events) = POLLIN;
- while (1)
- {
- nfds = (poll (pfds, 1, (blockp ? INFTIM : 0)));
- if (nfds > 0)
- return (select_input_argument);
- else if (nfds == 0)
- {
- if (!blockp)
- return (select_input_none);
- }
- else if (errno != EINTR)
- error_system_call (errno, syscall_select);
- else if (OS_process_any_status_change ())
- return (select_input_process_status);
- if (pending_interrupts_p ())
- return (select_input_interrupt);
- }
-}
-
-enum select_input
-UX_select_input (int fd, int blockp)
-{
- return (UX_select_descriptor (fd, blockp));
-}
-
-#else /* not HAVE_POLL */
-\f
-/* select(2) */
-
-unsigned int
-UX_select_registry_size (void)
-{
- return (sizeof (SELECT_TYPE));
-}
-
-unsigned int
-UX_select_registry_lub (void)
-{
- return (FD_SETSIZE);
-}
-
-void
-UX_select_registry_clear_all (void * fds)
-{
- FD_ZERO ((SELECT_TYPE *) fds);
-}
-
-void
-UX_select_registry_set (void * fds, unsigned int fd)
-{
- FD_SET (fd, ((SELECT_TYPE *) fds));
-}
-
-void
-UX_select_registry_clear (void * fds, unsigned int fd)
-{
- FD_CLR (fd, ((SELECT_TYPE *) fds));
-}
-
-int
-UX_select_registry_is_set (void * fds, unsigned int fd)
-{
- return (FD_ISSET (fd, ((SELECT_TYPE *) fds)));
-}
-
-enum select_input
-UX_select_registry_test (void * input_fds,
- int blockp,
- unsigned int * output_fds,
- unsigned int * output_nfds)
-{
-#ifdef HAVE_SELECT
- while (1)
- {
- SELECT_TYPE readable;
- int nfds;
-
- readable = (* ((SELECT_TYPE *) input_fds));
- INTERRUPTABLE_EXTENT
- (nfds,
- ((OS_process_any_status_change ())
- ? ((errno = EINTR), (-1))
- : (UX_select (FD_SETSIZE,
- (&readable),
- ((SELECT_TYPE *) 0),
- ((SELECT_TYPE *) 0),
- (blockp
- ? ((struct timeval *) 0)
- : (&zero_timeout))))));
- if (nfds > 0)
- {
- unsigned int i = 0;
- if (output_nfds != 0)
- (*output_nfds) = nfds;
- if (output_fds != 0)
- while (1)
- {
- if (FD_ISSET (i, (&readable)))
- {
- (*output_fds++) = i;
- if ((--nfds) == 0)
- break;
- }
- i += 1;
- }
- return (select_input_argument);
- }
- else if (nfds == 0)
- {
- if (!blockp)
- return (select_input_none);
- }
- else if (errno != EINTR)
- error_system_call (errno, syscall_select);
- else if (OS_process_any_status_change ())
- return (select_input_process_status);
- if (pending_interrupts_p ())
- return (select_input_interrupt);
- }
-#else
- error_system_call (ENOSYS, syscall_select);
- return (select_input_argument);
-#endif
-}
-
-enum select_input
-UX_select_descriptor (unsigned int fd, int blockp)
-{
-#ifdef HAVE_SELECT
- SELECT_TYPE readable;
-
- FD_ZERO (&readable);
- FD_SET (fd, (&readable));
- return (UX_select_registry_test ((&readable), blockp, 0, 0));
-#else
- error_system_call (ENOSYS, syscall_select);
- return (select_input_argument);
-#endif
-}
-
-enum select_input
-UX_select_input (int fd, int blockp)
-{
- SELECT_TYPE readable;
- unsigned int fds [FD_SETSIZE];
- unsigned int nfds;
-
- readable = input_descriptors;
- FD_SET (fd, (&readable));
- {
- enum select_input s =
- (UX_select_registry_test ((&readable), blockp, fds, (&nfds)));
- if (s != select_input_argument)
- return (s);
- }
- {
- unsigned int * scan = fds;
- unsigned int * end = (scan + nfds);
- while (scan < end)
- if ((*scan++) == fd)
- return (select_input_argument);
- }
- return (select_input_other);
-}
-
-#endif /* not HAVE_POLL */
+++ /dev/null
-/* -*-C-*-
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007, 2008, 2009, 2010 Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-*/
-
-#ifndef SCM_UXSELECT_H
-#define SCM_UXSELECT_H
-
-enum select_input
-{
- select_input_argument,
- select_input_other,
- select_input_none,
- select_input_process_status,
- select_input_interrupt
-};
-
-extern enum select_input UX_select_input (int fd, int blockp);
-extern unsigned int UX_select_registry_size (void);
-extern unsigned int UX_select_registry_lub (void);
-extern void UX_select_registry_clear_all (void * fds);
-extern void UX_select_registry_set (void * fds, unsigned int fd);
-extern void UX_select_registry_clear (void * fds, unsigned int fd);
-extern int UX_select_registry_is_set (void * fds, unsigned int fd);
-extern enum select_input UX_select_registry_test
- (void * input_fds, int blockp,
- unsigned int * output_fds, unsigned int * output_nfds);
-extern enum select_input UX_select_descriptor
- (unsigned int fd, int blockp);
-
-#endif /* SCM_UXSELECT_H */
projects / mit-scheme.git / commitdiff