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 / pruxio.c < prev    next >
C/C++ Source or Header  |  2000-12-05  |  9KB  |  279 lines
  1. /* -*-C-*-
  2.  
  3. $Id: pruxio.c,v 1.8 2000/12/05 21:23:48 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 perform I/O to and from files. */
  23.  
  24. #include "scheme.h"
  25. #include "prims.h"
  26. #include "osio.h"
  27. #include "ux.h"
  28. #include "uxselect.h"
  29. #include "uxproc.h"
  30.  
  31. #ifndef __hp9000s700
  32. /* Blows up HP 9000/700 compiler (HP-UX 8.05)!  */
  33. extern Tchannel EXFUN (arg_channel, (int arg_number));
  34. extern int EXFUN (UX_channel_descriptor, (Tchannel channel));
  35. #endif
  36.  
  37. static CONST char ** EXFUN (string_vector_arg, (int arg));
  38. static int EXFUN (string_vector_p, (SCHEME_OBJECT vector));
  39. static CONST char ** EXFUN (convert_string_vector, (SCHEME_OBJECT vector));
  40.  
  41. DEFINE_PRIMITIVE ("SELECT-REGISTRY-SIZE", Prim_selreg_size, 0, 0, 0)
  42. {
  43.   PRIMITIVE_HEADER (0);
  44.   PRIMITIVE_RETURN (long_to_integer (UX_select_registry_size ()));
  45. }
  46.  
  47. DEFINE_PRIMITIVE ("SELECT-REGISTRY-LUB", Prim_selreg_lub, 0, 0, 0)
  48. {
  49.   PRIMITIVE_HEADER (0);
  50.   PRIMITIVE_RETURN (long_to_integer (UX_select_registry_lub ()));
  51. }
  52.  
  53. DEFINE_PRIMITIVE ("SELECT-REGISTRY-CLEAR-ALL", Prim_selreg_clear_all, 1, 1, 0)
  54. {
  55.   PRIMITIVE_HEADER (1);
  56.   UX_select_registry_clear_all (STRING_ARG (1));
  57.   PRIMITIVE_RETURN (UNSPECIFIC);
  58. }
  59.  
  60. DEFINE_PRIMITIVE ("SELECT-REGISTRY-SET", Prim_selreg_set, 2, 2, 0)
  61. {
  62.   PRIMITIVE_HEADER (2);
  63.   UX_select_registry_set ((STRING_ARG (1)), (arg_nonnegative_integer (2)));
  64.   PRIMITIVE_RETURN (UNSPECIFIC);
  65. }
  66.  
  67. DEFINE_PRIMITIVE ("SELECT-REGISTRY-CLEAR", Prim_selreg_clear, 2, 2, 0)
  68. {
  69.   PRIMITIVE_HEADER (2);
  70.   UX_select_registry_clear ((STRING_ARG (1)), (arg_nonnegative_integer (2)));
  71.   PRIMITIVE_RETURN (UNSPECIFIC);
  72. }
  73.  
  74. DEFINE_PRIMITIVE ("SELECT-REGISTRY-IS-SET?", Prim_selreg_is_set_p, 2, 2, 0)
  75. {
  76.   PRIMITIVE_HEADER (2);
  77.   PRIMITIVE_RETURN
  78.     (BOOLEAN_TO_OBJECT
  79.      (UX_select_registry_is_set
  80.       ((STRING_ARG (1)), (arg_nonnegative_integer (2)))));
  81. }
  82.  
  83. DEFINE_PRIMITIVE ("CHANNEL-DESCRIPTOR", Prim_channel_descriptor, 1, 1, 0)
  84. {
  85.   PRIMITIVE_HEADER (1);
  86.   PRIMITIVE_RETURN (long_to_integer (UX_channel_descriptor (arg_channel (1))));
  87. }
  88.  
  89. DEFINE_PRIMITIVE ("SELECT-DESCRIPTOR", Prim_select_descriptor, 2, 2, 0)
  90. {
  91.   PRIMITIVE_HEADER (2);
  92.   switch (UX_select_descriptor ((arg_nonnegative_integer (1)),
  93.                 (BOOLEAN_ARG (2))))
  94.     {
  95.     case select_input_none:
  96.       PRIMITIVE_RETURN (LONG_TO_UNSIGNED_FIXNUM (0));
  97.     case select_input_argument:
  98.       PRIMITIVE_RETURN (LONG_TO_UNSIGNED_FIXNUM (1));
  99.     case select_input_process_status:
  100.       PRIMITIVE_RETURN (LONG_TO_FIXNUM (-1));
  101.     case select_input_interrupt:
  102.       PRIMITIVE_RETURN (LONG_TO_FIXNUM (-2));
  103.     default:
  104.       error_external_return ();
  105.       PRIMITIVE_RETURN (UNSPECIFIC);
  106.     }
  107. }
  108.  
  109. DEFINE_PRIMITIVE ("SELECT-REGISTRY-TEST", Prim_selreg_test, 3, 3, 0)
  110. {
  111.   PRIMITIVE_HEADER (3);
  112.   CHECK_ARG (3, VECTOR_P);
  113.   {
  114.     PTR position = dstack_position;
  115.     unsigned int lub = (UX_select_registry_lub ());
  116.     unsigned int * fds = (dstack_alloc ((sizeof (unsigned int)) * lub));
  117.     unsigned int nfds;
  118.     SCHEME_OBJECT result = SHARP_F;
  119.  
  120.     if ((VECTOR_LENGTH (ARG_REF (3))) != lub)
  121.       error_bad_range_arg (3);
  122.     switch (UX_select_registry_test ((STRING_ARG (1)), (BOOLEAN_ARG (2)),
  123.                      fds, (&nfds)))
  124.       {
  125.       case select_input_none:
  126.     result = (LONG_TO_UNSIGNED_FIXNUM (0));
  127.     break;
  128.       case select_input_argument:
  129.     {
  130.       unsigned int * scan_fds = fds;
  131.       unsigned int * end_fds = (scan_fds + nfds);
  132.       SCHEME_OBJECT * scan_vector = (VECTOR_LOC ((ARG_REF (3)), 0));
  133.       while (scan_fds < end_fds)
  134.         (*scan_vector++) = (LONG_TO_UNSIGNED_FIXNUM (*scan_fds++));
  135.     }
  136.     result = (LONG_TO_UNSIGNED_FIXNUM (nfds));
  137.     break;
  138.       case select_input_process_status:
  139.     result = (LONG_TO_FIXNUM (-1));
  140.     break;
  141.       case select_input_interrupt:
  142.     result = (LONG_TO_FIXNUM (-2));
  143.     break;
  144.       default:
  145.     error_external_return ();
  146.     break;
  147.       }
  148.     dstack_set_position (position);
  149.     PRIMITIVE_RETURN (result);
  150.   }
  151. }
  152.  
  153. #define PROCESS_CHANNEL_ARG(arg, type, channel)                \
  154. {                                    \
  155.   if ((ARG_REF (arg)) == SHARP_F)                    \
  156.     (type) = process_channel_type_none;                    \
  157.   else if ((ARG_REF (arg)) == (LONG_TO_FIXNUM (-1)))            \
  158.     (type) = process_channel_type_inherit;                \
  159.   else if ((ARG_REF (arg)) == (LONG_TO_FIXNUM (-2)))            \
  160.     {                                    \
  161.       if (ctty_type != process_ctty_type_explicit)            \
  162.     error_bad_range_arg (arg);                    \
  163.       (type) = process_channel_type_ctty;                \
  164.     }                                    \
  165.   else                                    \
  166.     {                                    \
  167.       (type) = process_channel_type_explicit;                \
  168.       (channel) = (arg_channel (arg));                    \
  169.     }                                    \
  170. }
  171.  
  172. DEFINE_PRIMITIVE ("UX-MAKE-SUBPROCESS", Prim_UX_make_subprocess, 8, 8,
  173.   "(FILENAME ARGV ENV WORK-DIR STDIN STDOUT STDERR)\n\
  174. Create a subprocess.\n\
  175. FILENAME is the program to run.\n\
  176. ARGV is a vector of strings to pass to the program as arguments.\n\
  177. ENV is a vector of strings to pass as the program's environment;\n\
  178.   #F means inherit Scheme's environment.\n\
  179. WORK-DIR is a string to pass as the program's working directory;\n\
  180.   #F means inherit Scheme's working directory.\n\
  181. CTTY specifies the program's controlling terminal:\n\
  182.   #F means none;\n\
  183.   -1 means use Scheme's controlling terminal in background;\n\
  184.   -2 means use Scheme's controlling terminal in foreground;\n\
  185.   string means open that terminal.\n\
  186. STDIN is the input channel for the subprocess.\n\
  187. STDOUT is the output channel for the subprocess.\n\
  188. STDERR is the error channel for the subprocess.\n\
  189.   Each channel arg can take these values:\n\
  190.   #F means none;\n\
  191.   -1 means use the corresponding channel from Scheme;\n\
  192.   -2 means use the controlling terminal (valid only when CTTY is a string);\n\
  193.   otherwise the argument must be a channel.")
  194. {
  195.   PRIMITIVE_HEADER (8);
  196.   {
  197.     PTR position = dstack_position;
  198.     CONST char * filename = (STRING_ARG (1));
  199.     CONST char ** argv = (string_vector_arg (2));
  200.     CONST char ** env
  201.       = (((ARG_REF (3)) == SHARP_F) ? 0 : (string_vector_arg (3)));
  202.     CONST char * working_directory
  203.       = (((ARG_REF (4)) == SHARP_F) ? 0 : (STRING_ARG (4)));
  204.     enum process_ctty_type ctty_type;
  205.     char * ctty_name = 0;
  206.     enum process_channel_type channel_in_type;
  207.     Tchannel channel_in = NO_CHANNEL;
  208.     enum process_channel_type channel_out_type;
  209.     Tchannel channel_out = NO_CHANNEL;
  210.     enum process_channel_type channel_err_type;
  211.     Tchannel channel_err = NO_CHANNEL;
  212.  
  213.     if ((ARG_REF (5)) == SHARP_F)
  214.       ctty_type = process_ctty_type_none;
  215.     else if ((ARG_REF (5)) == (LONG_TO_FIXNUM (-1)))
  216.       ctty_type = process_ctty_type_inherit_bg;
  217.     else if ((ARG_REF (5)) == (LONG_TO_FIXNUM (-2)))
  218.       ctty_type = process_ctty_type_inherit_fg;
  219.     else
  220.       {
  221.     ctty_type = process_ctty_type_explicit;
  222.     ctty_name = (STRING_ARG (5));
  223.       }
  224.     PROCESS_CHANNEL_ARG (6, channel_in_type, channel_in);
  225.     PROCESS_CHANNEL_ARG (7, channel_out_type, channel_out);
  226.     PROCESS_CHANNEL_ARG (8, channel_err_type, channel_err);
  227.     {
  228.       Tprocess process =
  229.     (OS_make_subprocess
  230.      (filename, argv, env, working_directory,
  231.       ctty_type, ctty_name,
  232.       channel_in_type, channel_in,
  233.       channel_out_type, channel_out,
  234.       channel_err_type, channel_err));
  235.       dstack_set_position (position);
  236.       PRIMITIVE_RETURN (long_to_integer (process));
  237.     }
  238.   }
  239. }
  240.  
  241. static CONST char **
  242. DEFUN (string_vector_arg, (arg), int arg)
  243. {
  244.   SCHEME_OBJECT vector = (ARG_REF (arg));
  245.   if (!string_vector_p (vector))
  246.     error_wrong_type_arg (arg);
  247.   return (convert_string_vector (vector));
  248. }
  249.  
  250. static int
  251. DEFUN (string_vector_p, (vector), SCHEME_OBJECT vector)
  252. {
  253.   if (! (VECTOR_P (vector)))
  254.     return (0);
  255.   {
  256.     unsigned long length = (VECTOR_LENGTH (vector));
  257.     SCHEME_OBJECT * scan = (VECTOR_LOC (vector, 0));
  258.     SCHEME_OBJECT * end = (scan + length);
  259.     while (scan < end)
  260.       if (! (STRING_P (*scan++)))
  261.     return (0);
  262.   }
  263.   return (1);
  264. }
  265.  
  266. static CONST char **
  267. DEFUN (convert_string_vector, (vector), SCHEME_OBJECT vector)
  268. {
  269.   unsigned long length = (VECTOR_LENGTH (vector));
  270.   char ** result = (dstack_alloc ((length + 1) * (sizeof (char *))));
  271.   SCHEME_OBJECT * scan = (VECTOR_LOC (vector, 0));
  272.   SCHEME_OBJECT * end = (scan + length);
  273.   char ** scan_result = result;
  274.   while (scan < end)
  275.     (*scan_result++) = ((char *) (STRING_LOC ((*scan++), 0)));
  276.   (*scan_result) = 0;
  277.   return ((CONST char **) result);
  278. }
  279.