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 / prosio.c < prev    next >
C/C++ Source or Header  |  2001-01-04  |  7KB  |  238 lines
  1. /* -*-C-*-
  2.  
  3. $Id: prosio.c,v 1.18 2001/01/04 22:07:42 cph Exp $
  4.  
  5. Copyright (c) 1987-1999 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.  
  28. #ifndef CLOSE_CHANNEL_HOOK
  29. #define CLOSE_CHANNEL_HOOK(channel)
  30. #endif
  31.  
  32. Tchannel
  33. DEFUN (arg_to_channel, (argument, arg_number),
  34.        SCHEME_OBJECT argument AND
  35.        int arg_number)
  36. {
  37.   if (! ((INTEGER_P (argument)) && (integer_to_long_p (argument))))
  38.     error_wrong_type_arg (arg_number);
  39.   {
  40.     fast long channel = (integer_to_long (argument));
  41.     if (! ((channel >= 0) || (channel < ((long) OS_channel_table_size))))
  42.       error_wrong_type_arg (arg_number);
  43.     return (channel);
  44.   }
  45. }
  46.  
  47. Tchannel
  48. DEFUN (arg_channel, (arg_number), int arg_number)
  49. {
  50.   fast Tchannel channel =
  51.     (arg_to_channel ((ARG_REF (arg_number)), arg_number));
  52.   if (! (OS_channel_open_p (channel)))
  53.     error_bad_range_arg (arg_number);
  54.   return (channel);
  55. }
  56.  
  57. DEFINE_PRIMITIVE ("CHANNEL-CLOSE", Prim_channel_close, 1, 1,
  58.   "Close file CHANNEL-NUMBER.")
  59. {
  60.   PRIMITIVE_HEADER (1);
  61.   {
  62.     fast Tchannel channel = (arg_to_channel ((ARG_REF (1)), 1));
  63.     if (OS_channel_open_p (channel))
  64.       {
  65.     CLOSE_CHANNEL_HOOK (channel);
  66.     OS_channel_close (channel);
  67.       }
  68.   }
  69.   PRIMITIVE_RETURN (UNSPECIFIC);
  70. }
  71.  
  72. DEFINE_PRIMITIVE ("CHANNEL-TABLE", Prim_channel_table, 0, 0,
  73.   "Return a vector of all channels in the channel table.")
  74. {
  75.   PRIMITIVE_HEADER (0);
  76.   {
  77.     Tchannel channel;
  78.     for (channel = 0; (channel < OS_channel_table_size); channel += 1)
  79.       if (OS_channel_open_p (channel))
  80.     obstack_grow ((&scratch_obstack), (&channel), (sizeof (Tchannel)));
  81.   }
  82.   {
  83.     unsigned int n_channels =
  84.       ((obstack_object_size ((&scratch_obstack))) / (sizeof (Tchannel)));
  85.     if (n_channels == 0)
  86.       PRIMITIVE_RETURN (SHARP_F);
  87.     {
  88.       Tchannel * channels = (obstack_finish (&scratch_obstack));
  89.       Tchannel * scan_channels = channels;
  90.       SCHEME_OBJECT vector =
  91.     (allocate_marked_vector (TC_VECTOR, n_channels, 1));
  92.       SCHEME_OBJECT * scan_vector = (VECTOR_LOC (vector, 0));
  93.       SCHEME_OBJECT * end_vector = (scan_vector + n_channels);
  94.       while (scan_vector < end_vector)
  95.     (*scan_vector++) = (long_to_integer (*scan_channels++));
  96.       obstack_free ((&scratch_obstack), channels);
  97.       PRIMITIVE_RETURN (vector);
  98.     }
  99.   }
  100. }
  101.  
  102. DEFINE_PRIMITIVE ("CHANNEL-TYPE", Prim_channel_type, 1, 1,
  103.   "Return (as a nonnegative integer) the type of CHANNEL.")
  104. {
  105.   PRIMITIVE_HEADER (1);
  106.   PRIMITIVE_RETURN
  107.     (long_to_integer ((long) (OS_channel_type (arg_channel (1)))));
  108. }
  109.  
  110. /* Must match definition of `enum channel_type' in "osio.h".  */
  111. static char * channel_type_names [] =
  112. {
  113.   "unknown",
  114.   "file",
  115.   "unix-pipe",
  116.   "unix-fifo",
  117.   "terminal",
  118.   "unix-pty-master",
  119.   "unix-stream-socket",
  120.   "tcp-stream-socket",
  121.   "tcp-server-socket",
  122.   "directory",
  123.   "unix-character-device",
  124.   "unix-block-device",
  125.   "os/2-console",
  126.   "os/2-unnamed-pipe",
  127.   "os/2-named-pipe",
  128.   "win32-anonymous-pipe",
  129.   "win32-named-pipe"
  130. };
  131.  
  132. DEFINE_PRIMITIVE ("CHANNEL-TYPE-NAME", Prim_channel_type_name, 1, 1,
  133.   "Return (as a string) the type of CHANNEL.")
  134. {
  135.   enum channel_type type;
  136.   unsigned int index;
  137.   PRIMITIVE_HEADER (1);
  138.   type = (OS_channel_type (arg_channel (1)));
  139.   if (type == channel_type_unknown)
  140.     PRIMITIVE_RETURN (SHARP_F);
  141.   index = ((unsigned int) type);
  142.   if (index >= ((sizeof (channel_type_names)) / (sizeof (char *))))
  143.     PRIMITIVE_RETURN (SHARP_F);
  144.   PRIMITIVE_RETURN
  145.     (char_pointer_to_string ((unsigned char *) (channel_type_names [index])));
  146. }
  147.  
  148. DEFINE_PRIMITIVE ("CHANNEL-READ", Prim_channel_read, 4, 4,
  149.   "Read characters from CHANNEL, storing them in STRING.\n\
  150. Third and fourth args START and END specify the substring to use.\n\
  151. Attempt to fill that substring unless end-of-file is reached.\n\
  152. Return the number of characters actually read from CHANNEL.")
  153. {
  154.   PRIMITIVE_HEADER (4);
  155.   {
  156.     unsigned long length;
  157.     char * buffer = (arg_extended_string (2, (&length)));
  158.     unsigned long end = (arg_ulong_index_integer (4, (length + 1)));
  159.     unsigned long start = (arg_ulong_index_integer (3, (end + 1)));
  160.     long nread =
  161.       (OS_channel_read ((arg_channel (1)),
  162.             (buffer + start),
  163.             (end - start)));
  164.     PRIMITIVE_RETURN ((nread < 0) ? SHARP_F : (long_to_integer (nread)));
  165.   }
  166. }
  167.  
  168. DEFINE_PRIMITIVE ("CHANNEL-WRITE", Prim_channel_write, 4, 4,
  169.   "Write characters to CHANNEL, reading them from STRING.\n\
  170. Third and fourth args START and END specify the substring to use.")
  171. {
  172.   PRIMITIVE_HEADER (4);
  173.   {
  174.     unsigned long length;
  175.     CONST char * buffer = (arg_extended_string (2, (&length)));
  176.     unsigned long end = (arg_ulong_index_integer (4, (length + 1)));
  177.     unsigned long start = (arg_ulong_index_integer (3, (end + 1)));
  178.     long nwritten =
  179.       (OS_channel_write ((arg_channel (1)),
  180.              (buffer + start),
  181.              (end - start)));
  182.     PRIMITIVE_RETURN ((nwritten < 0) ? SHARP_F : (long_to_integer (nwritten)));
  183.   }
  184. }
  185.  
  186. DEFINE_PRIMITIVE ("CHANNEL-BLOCKING?", Prim_channel_blocking_p, 1, 1,
  187.   "Return #F iff CHANNEL is in non-blocking mode.\n\
  188. Otherwise, CHANNEL is in blocking mode.\n\
  189. If CHANNEL can be put in non-blocking mode, #T is returned.\n\
  190. If it cannot, 0 is returned.")
  191. {
  192.   PRIMITIVE_HEADER (1);
  193.   {
  194.     int result = (OS_channel_nonblocking_p (arg_channel (1)));
  195.     PRIMITIVE_RETURN
  196.       ((result < 0)
  197.        ? (LONG_TO_UNSIGNED_FIXNUM (0))
  198.        : (BOOLEAN_TO_OBJECT (result == 0)));
  199.   }
  200. }
  201.  
  202. DEFINE_PRIMITIVE ("CHANNEL-NONBLOCKING", Prim_channel_nonblocking, 1, 1,
  203.   "Put CHANNEL in non-blocking mode.")
  204. {
  205.   PRIMITIVE_HEADER (1);
  206.   OS_channel_nonblocking (arg_channel (1));
  207.   PRIMITIVE_RETURN (UNSPECIFIC);
  208. }
  209.  
  210. DEFINE_PRIMITIVE ("CHANNEL-BLOCKING", Prim_channel_blocking, 1, 1,
  211.   "Put CHANNEL in blocking mode.")
  212. {
  213.   PRIMITIVE_HEADER (1);
  214.   OS_channel_blocking (arg_channel (1));
  215.   PRIMITIVE_RETURN (UNSPECIFIC);
  216. }
  217.  
  218. DEFINE_PRIMITIVE ("MAKE-PIPE", Prim_make_pipe, 0, 0,
  219.   "Return a cons of two channels, the reader and writer of a pipe.")
  220. {
  221.   PRIMITIVE_HEADER (0);
  222.   {
  223.     SCHEME_OBJECT result = (cons (SHARP_F, SHARP_F));
  224.     Tchannel reader;
  225.     Tchannel writer;
  226.     OS_make_pipe ((&reader), (&writer));
  227.     SET_PAIR_CAR (result, (long_to_integer (reader)));
  228.     SET_PAIR_CDR (result, (long_to_integer (writer)));
  229.     PRIMITIVE_RETURN (result);
  230.   }
  231. }
  232.  
  233. DEFINE_PRIMITIVE ("HAVE-SELECT?", Prim_have_select_p, 0, 0, 0)
  234. {
  235.   PRIMITIVE_HEADER (0);
  236.   PRIMITIVE_RETURN (BOOLEAN_TO_OBJECT (OS_have_select_p));
  237. }
  238.