home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / mitsch75.zip / scheme-7_5_17-src.zip / scheme-7.5.17 / src / microcode / prntio.c < prev    next >
C/C++ Source or Header  |  2000-12-05  |  8KB  |  270 lines
  1. /* -*-C-*-
  2.  
  3. $Id: prntio.c,v 1.13 2000/12/05 21:23:47 cph Exp $
  4.  
  5. Copyright (c) 1993-2000 Massachusetts Institute of Technology
  6.  
  7. This program is free software; you can redistribute it and/or modify
  8. it under the terms of the GNU General Public License as published by
  9. the Free Software Foundation; either version 2 of the License, or (at
  10. your option) any later version.
  11.  
  12. This program is distributed in the hope that it will be useful, but
  13. WITHOUT ANY WARRANTY; without even the implied warranty of
  14. MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  15. General Public License for more details.
  16.  
  17. You should have received a copy of the GNU General Public License
  18. along with this program; if not, write to the Free Software
  19. Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  20. */
  21.  
  22. /* Primitives to do the NT equivalent of Unix select. */
  23.  
  24. #include <windows.h>
  25. #include "scheme.h"
  26. #include "prims.h"
  27. #include "ntio.h"
  28. #include "nt.h"
  29. #include "ntscreen.h"
  30. #include "ntgui.h"
  31. #include "syscall.h"
  32. #include "ntproc.h"
  33. #include "ostty.h"
  34.  
  35. extern HANDLE master_tty_window;
  36. extern Tchannel EXFUN (arg_to_channel, (SCHEME_OBJECT, int));
  37.  
  38. static Tchannel * object_to_channel_vector
  39.   (SCHEME_OBJECT, int, unsigned long *, long *);
  40. static long wait_for_multiple_objects (unsigned long, Tchannel *, long, int);
  41. static long wait_for_multiple_objects_1 (unsigned long, Tchannel *, long, int);
  42.  
  43. DEFINE_PRIMITIVE ("CHANNEL-DESCRIPTOR", Prim_channel_descriptor, 1, 1, 0)
  44. {
  45.   PRIMITIVE_HEADER (1);
  46.   PRIMITIVE_RETURN (ulong_to_integer (arg_channel (1)));
  47. }
  48.  
  49. DEFINE_PRIMITIVE ("WIN32-GUI-TRACE", Prim_win32_gui_trace, 2, 2, 0)
  50. {
  51.   PRIMITIVE_HEADER (2);
  52.   {
  53.     win32_trace_level = (arg_ulong_integer (1));
  54.     if (win32_trace_file != 0)
  55.       {
  56.     fflush (win32_trace_file);
  57.     fclose (win32_trace_file);
  58.     win32_trace_file = 0;
  59.       }
  60.     if (win32_trace_level > 0)
  61.       win32_trace_file
  62.     = (fopen ((((ARG_REF (2)) == SHARP_F)
  63.            ? WIN32_TRACE_FILENAME
  64.            : (STRING_ARG (2))),
  65.           "w"));
  66.   }
  67.   PRIMITIVE_RETURN (UNSPECIFIC);
  68. }
  69.  
  70. DEFINE_PRIMITIVE ("NT:MSGWAITFORMULTIPLEOBJECTS", Prim_nt_msgwaitformultipleobjects, 4, 4, 0)
  71. {
  72.   PRIMITIVE_HEADER (4);
  73.   error_unimplemented_primitive ();
  74.   PRIMITIVE_RETURN (UNSPECIFIC);
  75. }
  76.  
  77. DEFINE_PRIMITIVE ("NT:WAITFORMULTIPLEOBJECTS", Prim_nt_waitformultipleobjects, 3, 3, 0)
  78. {
  79.   PRIMITIVE_HEADER (3);
  80.   {
  81.     SCHEME_OBJECT channel_vector = (VECTOR_ARG (1));
  82.     int blockp = (BOOLEAN_ARG (3));
  83.     unsigned long nc;
  84.     long console_index = (-1);
  85.     Tchannel * channels;
  86.     long result;
  87.  
  88.     if (BOOLEAN_ARG (2))
  89.       error_bad_range_arg (2);
  90.     transaction_begin ();
  91.     channels
  92.       = (object_to_channel_vector
  93.      (channel_vector, 1, (&nc), (&console_index)));
  94.     result
  95.       = (wait_for_multiple_objects (nc, channels, console_index, blockp));
  96.     transaction_commit ();
  97.     PRIMITIVE_RETURN (long_to_integer (result));
  98.   }
  99. }
  100.  
  101. static Tchannel *
  102. object_to_channel_vector (SCHEME_OBJECT channel_vector,
  103.               int argno,
  104.               unsigned long * ncp,
  105.               long * console_index)
  106. {
  107.   unsigned int index = 0;
  108.   Tchannel tty_input_channel = (OS_tty_input_channel ());
  109.   unsigned long nc = (VECTOR_LENGTH (channel_vector));
  110.   Tchannel * channels
  111.     = ((nc == 0) ? 0 : (dstack_alloc (nc * (sizeof (Tchannel)))));
  112.   while (index < nc)
  113.     {
  114.       Tchannel channel
  115.     = (arg_to_channel ((VECTOR_REF (channel_vector, (index))), argno));
  116.       if (channel == tty_input_channel)
  117.     {
  118.       (*console_index) = index;
  119.       (channels[index]) = NO_CHANNEL;
  120.     }
  121.       else
  122.     (channels[index]) = channel;
  123.       index += 1;
  124.     }
  125.   (*ncp) = nc;
  126.   return (channels);
  127. }
  128.  
  129. static long
  130. wait_for_multiple_objects (unsigned long n_channels, Tchannel * channels,
  131.                long console_index, int blockp)
  132. {
  133.   if (win32_trace_level > 1)
  134.     {
  135.       fprintf (win32_trace_file, "wait_for_multiple_objects: ");
  136.       fprintf (win32_trace_file, "n_channels=%d console_index=%d blockp=%d\n",
  137.            n_channels, console_index, blockp);
  138.       fflush (win32_trace_file);
  139.     }
  140.   {
  141.     long result
  142.       = (wait_for_multiple_objects_1
  143.      (n_channels, channels, console_index, blockp));
  144.     if (win32_trace_level > 1)
  145.       {
  146.     fprintf (win32_trace_file, "wait_for_multiple_objects: ");
  147.     fprintf (win32_trace_file, "result=0x%x\n", result);
  148.     fflush (win32_trace_file);
  149.       }
  150.     return (result);
  151.   }
  152. }
  153.  
  154. static long
  155. wait_for_multiple_objects_1 (unsigned long n_channels, Tchannel * channels,
  156.                  long console_index, int blockp)
  157. {
  158.   while (1)
  159.     {
  160.       if (console_index < 0)
  161.     {
  162.       if (pending_interrupts_p ())
  163.         return (-2);
  164.     }
  165.       else if (Screen_pending_events_p ())
  166.     return (console_index);
  167.       else
  168.     {
  169.       MSG m;
  170.       while (PeekMessage ((&m), 0, 0, 0, PM_NOREMOVE))
  171.         {
  172.           if ((m . message) != WM_SCHEME_INTERRUPT)
  173.         return (console_index);
  174.           else if (pending_interrupts_p ())
  175.         return (-2);
  176.           else
  177.         PeekMessage ((&m), 0, 0, 0, PM_REMOVE);
  178.         }
  179.     }
  180.       {
  181.     unsigned int index;
  182.     for (index = 0; (index < n_channels); index += 1)
  183.       if ((index != ((unsigned long) console_index))
  184.           && ((NT_channel_n_read (channels[index])) != (-1)))
  185.         return (index);
  186.       }
  187.       if (OS_process_any_status_change ())
  188.     return (-3);
  189.       if (!blockp)
  190.     return (-1);
  191.       /* Block waiting for a message to arrive.  The asynchronous
  192.      interrupt thread guarantees that a message will arrive in a
  193.      reasonable amount of time.  */
  194.       if ((MsgWaitForMultipleObjects (0, 0, FALSE, INFINITE, QS_ALLINPUT))
  195.       == WAIT_FAILED)
  196.     NT_error_api_call
  197.       ((GetLastError ()), apicall_MsgWaitForMultipleObjects);
  198.     }
  199. }
  200.  
  201. #define PROCESS_CHANNEL_ARG(arg, type, channel)                \
  202. {                                    \
  203.   if ((ARG_REF (arg)) == SHARP_F)                    \
  204.     (type) = process_channel_type_none;                    \
  205.   else if ((ARG_REF (arg)) == (LONG_TO_FIXNUM (-1)))            \
  206.     (type) = process_channel_type_inherit;                \
  207.   else                                    \
  208.     {                                    \
  209.       (type) = process_channel_type_explicit;                \
  210.       (channel) = (arg_channel (arg));                    \
  211.     }                                    \
  212. }
  213.  
  214. static void
  215. parse_subprocess_options (int arg, int * hide_windows_p)
  216. {
  217.   SCHEME_OBJECT options = (VECTOR_ARG (arg));
  218.   if ((VECTOR_LENGTH (options)) < 1)
  219.     error_bad_range_arg (arg);
  220.   (*hide_windows_p) = (OBJECT_TO_BOOLEAN (VECTOR_REF (options, 0)));
  221. }
  222.  
  223. DEFINE_PRIMITIVE ("NT-MAKE-SUBPROCESS", Prim_NT_make_subprocess, 8, 8,
  224.   "(FILENAME CMD-LINE ENV WORK-DIR STDIN STDOUT STDERR OPTIONS)\n\
  225. Create a subprocess.\n\
  226. FILENAME is the program to run.\n\
  227. CMD-LINE a string containing the program's invocation.\n\
  228. ENV is a string to pass as the program's environment;\n\
  229.   #F means inherit Scheme's environment.\n\
  230. WORK-DIR is a string to pass as the program's working directory;\n\
  231.   #F means inherit Scheme's working directory.\n\
  232. STDIN is the input channel for the subprocess.\n\
  233. STDOUT is the output channel for the subprocess.\n\
  234. STDERR is the error channel for the subprocess.\n\
  235.   Each channel arg can take these values:\n\
  236.   #F means none;\n\
  237.   -1 means use the corresponding channel from Scheme;\n\
  238.   otherwise the argument must be a channel.\n\
  239. OPTIONS is a vector of options.")
  240. {
  241.   PRIMITIVE_HEADER (8);
  242.   {
  243.     CONST char * filename = (STRING_ARG (1));
  244.     CONST char * command_line = (STRING_ARG (2));
  245.     CONST char * env = (((ARG_REF (3)) == SHARP_F) ? 0 : (STRING_ARG (3)));
  246.     CONST char * working_directory
  247.       = (((ARG_REF (4)) == SHARP_F) ? 0 : (STRING_ARG (4)));
  248.     enum process_channel_type channel_in_type;
  249.     Tchannel channel_in;
  250.     enum process_channel_type channel_out_type;
  251.     Tchannel channel_out;
  252.     enum process_channel_type channel_err_type;
  253.     Tchannel channel_err;
  254.     int hide_windows_p;
  255.  
  256.     PROCESS_CHANNEL_ARG (5, channel_in_type, channel_in);
  257.     PROCESS_CHANNEL_ARG (6, channel_out_type, channel_out);
  258.     PROCESS_CHANNEL_ARG (7, channel_err_type, channel_err);
  259.     parse_subprocess_options (8, (&hide_windows_p));
  260.     PRIMITIVE_RETURN
  261.       (long_to_integer
  262.        (NT_make_subprocess
  263.     (filename, command_line, env, working_directory,
  264.      channel_in_type, channel_in,
  265.      channel_out_type, channel_out,
  266.      channel_err_type, channel_err,
  267.      hide_windows_p)));
  268.   }
  269. }
  270.