/* -*-C-*-
-$Id: os2proc.c,v 1.3 1995/10/09 05:54:35 cph Exp $
+$Id: os2proc.c,v 1.4 1997/10/22 05:24:30 cph Exp $
-Copyright (c) 1995 Massachusetts Institute of Technology
+Copyright (c) 1995-97 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
static void transfer_stdio (HFILE, Tchannel, enum process_channel_type);
static Tprocess allocate_process (void);
static void allocate_process_abort (void *);
-static PSZ rewrite_arguments (char * const *);
-static PSZ rewrite_environment (char * const *);
static void child_wait_thread (void *);
static Tprocess find_process (PID);
}
\f
Tprocess
-OS_make_subprocess (const char * filename,
- char * const * argv,
- char * const * envp,
- const char * working_directory,
- enum process_ctty_type ctty_type,
- char * ctty_name,
- enum process_channel_type channel_in_type,
- Tchannel channel_in,
- enum process_channel_type channel_out_type,
- Tchannel channel_out,
- enum process_channel_type channel_err_type,
- Tchannel channel_err)
+OS2_make_subprocess (const char * filename,
+ const char * command_line,
+ const char * environment,
+ const char * working_directory,
+ enum process_channel_type channel_in_type,
+ Tchannel channel_in,
+ enum process_channel_type channel_out_type,
+ Tchannel channel_out,
+ enum process_channel_type channel_err_type,
+ Tchannel channel_err)
{
- if ((ctty_type != process_ctty_type_none)
- || (channel_in_type == process_channel_type_ctty)
- || (channel_out_type == process_channel_type_ctty)
- || (channel_err_type == process_channel_type_ctty))
- OS2_error_anonymous ();
transaction_begin ();
save_process_state (working_directory != 0);
transfer_stdio (0, channel_in, channel_in_type);
lock_process_status ();
child = (allocate_process ());
STD_API_CALL
- (dos_exec_pgm,
- (error_object,
- (sizeof (error_object)),
- EXEC_ASYNCRESULT,
- (rewrite_arguments (argv)),
- ((envp == 0) ? 0 : (rewrite_environment (envp))),
- (& result_codes),
- ((PSZ) filename)));
+ (dos_exec_pgm, (error_object,
+ (sizeof (error_object)),
+ EXEC_ASYNCRESULT,
+ ((PSZ) command_line),
+ ((PSZ) environment),
+ (& result_codes),
+ ((PSZ) filename)));
(PROCESS_ID (child)) = (result_codes . codeTerminate);
(PROCESS_RAW_STATUS (child)) = process_status_running;
(PROCESS_RAW_REASON (child)) = 0;
OS_process_deallocate (process);
}
\f
-static PSZ
-rewrite_arguments (char * const * argv)
-{
- unsigned long nargs = 0;
- unsigned long length = 0;
- while ((argv [nargs]) != 0)
- {
- length += (strlen (argv [nargs]));
- nargs += 1;
- }
- {
- PSZ result = (dstack_alloc (length + ((nargs < 2) ? 2 : nargs) + 1));
- PSZ scan_result = result;
- if (nargs == 0)
- (*scan_result++) = '\0';
- else
- {
- unsigned long limit = (nargs - 1);
- unsigned long index = 0;
- while (1)
- {
- const char * arg = (argv [index]);
- while (1)
- {
- char c = (*arg++);
- if (c == '\0')
- break;
- (*scan_result++) = c;
- }
- if (index == limit)
- break;
- (*scan_result++) = ((index == 0) ? '\0' : ' ');
- index += 1;
- }
- }
- (*scan_result++) = '\0';
- (*scan_result) = '\0';
- return (result);
- }
-}
-
-static PSZ
-rewrite_environment (char * const * envp)
-{
- unsigned long length;
- char * const * scan_env;
- const char * binding;
- PSZ result;
- PSZ scan_result;
-
- length = 0;
- scan_env = envp;
- while ((binding = (*scan_env++)) != 0)
- length += ((strlen (binding)) + 1);
- result = (dstack_alloc (length + 1));
- scan_result = result;
- scan_env = envp;
- while ((binding = (*scan_env++)) != 0)
- while (((*scan_result++) = (*binding++)) != '\0')
- ;
- (*scan_result) = '\0';
- return (result);
-}
-\f
void
OS_process_deallocate (Tprocess process)
{
}
int
-OS2_process_any_status_change (void)
+OS_process_any_status_change (void)
{
return (process_tick != sync_tick);
}
return (process);
return (NO_PROCESS);
}
+\f
+/* OBSOLETE */
+
+static PSZ rewrite_arguments (const char **);
+static PSZ rewrite_environment (const char **);
+
+Tprocess
+OS_make_subprocess (const char * filename,
+ const char ** argv,
+ const char ** envp,
+ const char * working_directory,
+ enum process_ctty_type ctty_type,
+ char * ctty_name,
+ enum process_channel_type channel_in_type,
+ Tchannel channel_in,
+ enum process_channel_type channel_out_type,
+ Tchannel channel_out,
+ enum process_channel_type channel_err_type,
+ Tchannel channel_err)
+{
+ if ((ctty_type != process_ctty_type_none)
+ || (channel_in_type == process_channel_type_ctty)
+ || (channel_out_type == process_channel_type_ctty)
+ || (channel_err_type == process_channel_type_ctty))
+ OS2_error_anonymous ();
+ return (OS2_make_subprocess (filename,
+ (rewrite_arguments (argv)),
+ (rewrite_environment (envp)),
+ working_directory,
+ channel_in_type, channel_in,
+ channel_out_type, channel_out,
+ channel_err_type, channel_err));
+}
+
+static PSZ
+rewrite_arguments (const char ** argv)
+{
+ unsigned long nargs = 0;
+ unsigned long length = 0;
+ while ((argv [nargs]) != 0)
+ {
+ length += (strlen (argv [nargs]));
+ nargs += 1;
+ }
+ {
+ PSZ result = (dstack_alloc (length + ((nargs < 2) ? 2 : nargs) + 1));
+ PSZ scan_result = result;
+ if (nargs == 0)
+ (*scan_result++) = '\0';
+ else
+ {
+ unsigned long limit = (nargs - 1);
+ unsigned long index = 0;
+ while (1)
+ {
+ const char * arg = (argv [index]);
+ while (1)
+ {
+ char c = (*arg++);
+ if (c == '\0')
+ break;
+ (*scan_result++) = c;
+ }
+ if (index == limit)
+ break;
+ (*scan_result++) = ((index == 0) ? '\0' : ' ');
+ index += 1;
+ }
+ }
+ (*scan_result++) = '\0';
+ (*scan_result) = '\0';
+ return (result);
+ }
+}
+
+static PSZ
+rewrite_environment (const char ** envp)
+{
+ unsigned long length;
+ const char ** scan_env;
+ const char * binding;
+ PSZ result;
+ PSZ scan_result;
+
+ length = 0;
+ scan_env = envp;
+ while ((binding = (*scan_env++)) != 0)
+ length += ((strlen (binding)) + 1);
+ result = (dstack_alloc (length + 1));
+ scan_result = result;
+ scan_env = envp;
+ while ((binding = (*scan_env++)) != 0)
+ while (((*scan_result++) = (*binding++)) != '\0')
+ ;
+ (*scan_result) = '\0';
+ return (result);
+}
/* -*-C-*-
-$Id: osproc.h,v 1.8 1993/06/24 07:09:06 gjr Exp $
+$Id: osproc.h,v 1.9 1997/10/22 05:24:39 cph Exp $
-Copyright (c) 1990-92 Massachusetts Institute of Technology
+Copyright (c) 1990-97 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
#define NO_PROCESS OS_process_table_size
extern enum process_jc_status scheme_jc_status;
+/* OS_make_subprocess is obsolete; use OS-specific procedure. */
extern Tprocess EXFUN
(OS_make_subprocess,
(CONST char * filename,
- char * CONST * argv,
- char * CONST * env,
+ CONST char ** argv,
+ CONST char ** env,
CONST char * working_directory,
enum process_ctty_type ctty_type,
char * ctty_name,
extern enum process_jc_status EXFUN (OS_process_jc_status, (Tprocess process));
extern int EXFUN (OS_process_status_sync, (Tprocess process));
extern int EXFUN (OS_process_status_sync_all, (void));
+extern int EXFUN (OS_process_any_status_change, (void));
extern enum process_status EXFUN (OS_process_status, (Tprocess process));
extern unsigned short EXFUN (OS_process_reason, (Tprocess process));
/* -*-C-*-
-$Id: pros2io.c,v 1.5 1995/11/03 01:22:21 cph Exp $
+$Id: pros2io.c,v 1.6 1997/10/22 05:24:52 cph Exp $
-Copyright (c) 1994-95 Massachusetts Institute of Technology
+Copyright (c) 1994-97 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
#include "scheme.h"
#include "prims.h"
#include "os2.h"
+#include "osproc.h"
-extern int OS2_process_any_status_change (void);
extern qid_t OS2_channel_thread_descriptor (Tchannel);
+extern Tprocess OS2_make_subprocess
+ (const char *, PSZ, PSZ, const char *,
+ enum process_channel_type, Tchannel,
+ enum process_channel_type, Tchannel,
+ enum process_channel_type, Tchannel);
\f
DEFINE_PRIMITIVE ("OS2-SELECT-REGISTRY-LUB", Prim_OS2_select_registry_lub, 0, 0, 0)
{
case mat_not_available:
PRIMITIVE_RETURN (LONG_TO_UNSIGNED_FIXNUM (1));
case mat_interrupt:
- if (OS2_process_any_status_change ())
+ if (OS_process_any_status_change ())
PRIMITIVE_RETURN (LONG_TO_UNSIGNED_FIXNUM (3));
else
PRIMITIVE_RETURN (LONG_TO_UNSIGNED_FIXNUM (2));
PRIMITIVE_RETURN (LONG_TO_UNSIGNED_FIXNUM (0));
else if (!interruptp)
PRIMITIVE_RETURN (LONG_TO_UNSIGNED_FIXNUM (1));
- else if (!OS2_process_any_status_change ())
+ else if (!OS_process_any_status_change ())
PRIMITIVE_RETURN (LONG_TO_UNSIGNED_FIXNUM (2));
else
PRIMITIVE_RETURN (LONG_TO_UNSIGNED_FIXNUM (3));
}
}
+\f
+#define PROCESS_CHANNEL_ARG(arg, type, channel) \
+{ \
+ if ((ARG_REF (arg)) == SHARP_F) \
+ (type) = process_channel_type_none; \
+ else if ((ARG_REF (arg)) == (LONG_TO_FIXNUM (-1))) \
+ (type) = process_channel_type_inherit; \
+ else \
+ { \
+ (type) = process_channel_type_explicit; \
+ (channel) = (arg_channel (arg)); \
+ } \
+}
+
+DEFINE_PRIMITIVE ("OS2-MAKE-SUBPROCESS", Prim_OS2_make_subprocess, 7, 7,
+ "(FILENAME CMD-LINE ENV WORK-DIR STDIN STDOUT STDERR)\n\
+Create a subprocess.\n\
+FILENAME is the program to run.\n\
+CMD-LINE a string containing the program's invocation.\n\
+ENV is a string to pass as the program's environment;\n\
+ #F means inherit Scheme's environment.\n\
+WORK-DIR is a string to pass as the program's working directory;\n\
+ #F means inherit Scheme's working directory.\n\
+STDIN is the input channel for the subprocess.\n\
+STDOUT is the output channel for the subprocess.\n\
+STDERR is the error channel for the subprocess.\n\
+ Each channel arg can take these values:\n\
+ #F means none;\n\
+ -1 means use the corresponding channel from Scheme;\n\
+ otherwise the argument must be a channel.")
+{
+ PRIMITIVE_HEADER (7);
+ {
+ CONST char * filename = (STRING_ARG (1));
+ CONST char * command_line = (STRING_ARG (2));
+ CONST char * env = (((ARG_REF (3)) == SHARP_F) ? 0 (STRING_ARG (3)));
+ CONST char * working_directory
+ = (((ARG_REF (4)) == SHARP_F) ? 0 (STRING_ARG (4)));
+ enum process_channel_type channel_in_type;
+ Tchannel channel_in;
+ enum process_channel_type channel_out_type;
+ Tchannel channel_out;
+ enum process_channel_type channel_err_type;
+ Tchannel channel_err;
+
+ PROCESS_CHANNEL_ARG (5, channel_in_type, channel_in);
+ PROCESS_CHANNEL_ARG (6, channel_out_type, channel_out);
+ PROCESS_CHANNEL_ARG (7, channel_err_type, channel_err);
+ PRIMITIVE_RETURN
+ (long_to_integer
+ (OS2_make_subprocess
+ (filename, command_line, env, working_directory,
+ channel_in_type, channel_in,
+ channel_out_type, channel_out,
+ channel_err_type, channel_err)));
+ }
+}
/* -*-C-*-
-$Id: pruxio.c,v 1.4 1993/04/27 08:38:14 cph Exp $
+$Id: pruxio.c,v 1.5 1997/10/22 05:25:09 cph Exp $
-Copyright (c) 1993 Massachusetts Institute of Technology
+Copyright (c) 1993-97 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
extern Tchannel EXFUN (arg_channel, (int arg_number));
extern int EXFUN (UX_channel_descriptor, (Tchannel channel));
#endif
+
+static CONST char ** EXFUN (string_vector_arg, (int arg));
+static int EXFUN (string_vector_p, (SCHEME_OBJECT vector));
+static CONST char ** EXFUN (convert_string_vector, (SCHEME_OBJECT vector));
\f
DEFINE_PRIMITIVE ("SELECT-REGISTRY-SIZE", Prim_selreg_size, 0, 0, 0)
{
PRIMITIVE_RETURN (result);
}
}
+\f
+#define PROCESS_CHANNEL_ARG(arg, type, channel) \
+{ \
+ if ((ARG_REF (arg)) == SHARP_F) \
+ (type) = process_channel_type_none; \
+ else if ((ARG_REF (arg)) == (LONG_TO_FIXNUM (-1))) \
+ (type) = process_channel_type_inherit; \
+ else if ((ARG_REF (arg)) == (LONG_TO_FIXNUM (-2))) \
+ { \
+ if (ctty_type != process_ctty_type_explicit) \
+ error_bad_range_arg (arg); \
+ (type) = process_channel_type_ctty; \
+ } \
+ else \
+ { \
+ (type) = process_channel_type_explicit; \
+ (channel) = (arg_channel (arg)); \
+ } \
+}
+
+DEFINE_PRIMITIVE ("UX-MAKE-SUBPROCESS", Prim_UX_make_subprocess, 8, 8,
+ "(FILENAME ARGV ENV WORK-DIR STDIN STDOUT STDERR)\n\
+Create a subprocess.\n\
+FILENAME is the program to run.\n\
+ARGV is a vector of strings to pass to the program as arguments.\n\
+ENV is a vector of strings to pass as the program's environment;\n\
+ #F means inherit Scheme's environment.\n\
+WORK-DIR is a string to pass as the program's working directory;\n\
+ #F means inherit Scheme's working directory.\n\
+CTTY specifies the program's controlling terminal:\n\
+ #F means none;\n\
+ -1 means use Scheme's controlling terminal in background;\n\
+ -2 means use Scheme's controlling terminal in foreground;\n\
+ string means open that terminal.\n\
+STDIN is the input channel for the subprocess.\n\
+STDOUT is the output channel for the subprocess.\n\
+STDERR is the error channel for the subprocess.\n\
+ Each channel arg can take these values:\n\
+ #F means none;\n\
+ -1 means use the corresponding channel from Scheme;\n\
+ -2 means use the controlling terminal (valid only when CTTY is a string);\n\
+ otherwise the argument must be a channel.")
+{
+ PRIMITIVE_HEADER (8);
+ {
+ PTR position = dstack_position;
+ CONST char * filename = (STRING_ARG (1));
+ CONST char ** argv = (string_vector_arg (2));
+ CONST char ** env
+ = (((ARG_REF (3)) == SHARP_F) ? 0 : (string_vector_arg (3)));
+ CONST char * working_directory
+ = (((ARG_REF (4)) == SHARP_F) ? 0 : (STRING_ARG (4)));
+ enum process_ctty_type ctty_type;
+ char * ctty_name = 0;
+ enum process_channel_type channel_in_type;
+ Tchannel channel_in;
+ enum process_channel_type channel_out_type;
+ Tchannel channel_out;
+ enum process_channel_type channel_err_type;
+ Tchannel channel_err;
+
+ if ((ARG_REF (5)) == SHARP_F)
+ ctty_type = process_ctty_type_none;
+ else if ((ARG_REF (5)) == (LONG_TO_FIXNUM (-1)))
+ ctty_type = process_ctty_type_inherit_bg;
+ else if ((ARG_REF (5)) == (LONG_TO_FIXNUM (-2)))
+ ctty_type = process_ctty_type_inherit_fg;
+ else
+ {
+ ctty_type = process_ctty_type_explicit;
+ ctty_name = (STRING_ARG (5));
+ }
+ PROCESS_CHANNEL_ARG (6, channel_in_type, channel_in);
+ PROCESS_CHANNEL_ARG (7, channel_out_type, channel_out);
+ PROCESS_CHANNEL_ARG (8, channel_err_type, channel_err);
+ {
+ Tprocess process =
+ (OS_make_subprocess
+ (filename, argv, env, working_directory,
+ ctty_type, ctty_name,
+ channel_in_type, channel_in,
+ channel_out_type, channel_out,
+ channel_err_type, channel_err));
+ dstack_set_position (position);
+ PRIMITIVE_RETURN (long_to_integer (process));
+ }
+ }
+}
+
+static CONST char **
+DEFUN (string_vector_arg, (arg), int arg)
+{
+ SCHEME_OBJECT vector = (ARG_REF (arg));
+ if (!string_vector_p (vector))
+ error_wrong_type_arg (arg);
+ return (convert_string_vector (vector));
+}
+
+static int
+DEFUN (string_vector_p, (vector), SCHEME_OBJECT vector)
+{
+ if (! (VECTOR_P (vector)))
+ return (0);
+ {
+ unsigned long length = (VECTOR_LENGTH (vector));
+ SCHEME_OBJECT * scan = (VECTOR_LOC (vector, 0));
+ SCHEME_OBJECT * end = (scan + length);
+ while (scan < end)
+ if (! (STRING_P (*scan++)))
+ return (0);
+ }
+ return (1);
+}
+
+static CONST char **
+DEFUN (convert_string_vector, (vector), SCHEME_OBJECT vector)
+{
+ unsigned long length = (VECTOR_LENGTH (vector));
+ char ** result = (dstack_alloc ((length + 1) * (sizeof (char *))));
+ SCHEME_OBJECT * scan = (VECTOR_LOC (vector, 0));
+ SCHEME_OBJECT * end = (scan + length);
+ char ** scan_result = result;
+ while (scan < end)
+ (*scan_result++) = ((char *) (STRING_LOC ((*scan++), 0)));
+ (*scan_result) = 0;
+ return (result);
+}
/* -*-C-*-
-$Id: uxio.c,v 1.40 1997/01/01 22:57:45 cph Exp $
+$Id: uxio.c,v 1.41 1997/10/22 05:25:17 cph Exp $
Copyright (c) 1990-97 Massachusetts Institute of Technology
#include "ux.h"
#include "uxio.h"
#include "uxselect.h"
+#include "uxproc.h"
\f
size_t OS_channel_table_size;
struct channel * channel_table;
#ifdef HAVE_SELECT
CONST int OS_have_select_p = 1;
-extern int EXFUN (UX_process_any_status_change, (void));
#ifndef SELECT_DECLARED
extern int EXFUN (UX_select,
(int, SELECT_TYPE *, SELECT_TYPE *, SELECT_TYPE *,
readable = (* ((SELECT_TYPE *) input_fds));
INTERRUPTABLE_EXTENT
(nfds,
- ((UX_process_any_status_change ())
+ ((OS_process_any_status_change ())
? ((errno = EINTR), (-1))
: (UX_select (FD_SETSIZE,
(&readable),
}
else if (errno != EINTR)
error_system_call (errno, syscall_select);
- else if (UX_process_any_status_change ())
+ else if (OS_process_any_status_change ())
return (select_input_process_status);
if (pending_interrupts_p ())
return (select_input_interrupt);
#else /* HAVE_POLL */
CONST int OS_have_select_p = 1;
-extern int EXFUN (UX_process_any_status_change, (void));
unsigned int
DEFUN_VOID (UX_select_registry_size)
}
else if (! ((errno == EINTR) || (errno == EAGAIN)))
error_system_call (errno, syscall_select);
- else if (UX_process_any_status_change ())
+ else if (OS_process_any_status_change ())
return (select_input_process_status);
if (pending_interrupts_p ())
return (select_input_interrupt);
}
else if (errno != EINTR)
error_system_call (errno, syscall_select);
- else if (UX_process_any_status_change ())
+ else if (OS_process_any_status_change ())
return (select_input_process_status);
if (pending_interrupts_p ())
return (select_input_interrupt);
/* -*-C-*-
-$Id: uxproc.c,v 1.20 1997/05/01 03:51:13 cph Exp $
+$Id: uxproc.c,v 1.21 1997/10/22 05:25:31 cph Exp $
Copyright (c) 1990-97 Massachusetts Institute of Technology
channel_out_type, channel_out,
channel_err_type, channel_err),
CONST char * filename AND
- char * CONST * argv AND
- char * CONST * envp AND
+ CONST char ** argv AND
+ CONST char ** envp AND
CONST char * working_directory AND
enum process_ctty_type ctty_type AND
char * ctty_name AND
}
int
-DEFUN_VOID (UX_process_any_status_change)
+DEFUN_VOID (OS_process_any_status_change)
{
return (process_tick != sync_tick);
}
projects / mit-scheme.git / commitdiff