libguile/fports.c

   1 /*      Copyright (C) 1995,1996 Free Software Foundation, Inc.
   2  *
   3  * This program is free software; you can redistribute it and/or modify
   4  * it under the terms of the GNU General Public License as published by
   5  * the Free Software Foundation; either version 2, or (at your option)
   6  * any later version.
   7  *
   8  * This program is distributed in the hope that it will be useful,
   9  * but WITHOUT ANY WARRANTY; without even the implied warranty of
  10  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  11  * GNU General Public License for more details.
  12  *
  13  * You should have received a copy of the GNU General Public License
  14  * along with this software; see the file COPYING.  If not, write to
  15  * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
  16  *
  17  * As a special exception, the Free Software Foundation gives permission
  18  * for additional uses of the text contained in its release of GUILE.
  19  *
  20  * The exception is that, if you link the GUILE library with other files
  21  * to produce an executable, this does not by itself cause the
  22  * resulting executable to be covered by the GNU General Public License.
  23  * Your use of that executable is in no way restricted on account of
  24  * linking the GUILE library code into it.
  25  *
  26  * This exception does not however invalidate any other reasons why
  27  * the executable file might be covered by the GNU General Public License.
  28  *
  29  * This exception applies only to the code released by the
  30  * Free Software Foundation under the name GUILE.  If you copy
  31  * code from other Free Software Foundation releases into a copy of
  32  * GUILE, as the General Public License permits, the exception does
  33  * not apply to the code that you add in this way.  To avoid misleading
  34  * anyone as to the status of such modified files, you must delete
  35  * this exception notice from them.
  36  *
  37  * If you write modifications of your own for GUILE, it is your choice
  38  * whether to permit this exception to apply to your modifications.
  39  * If you do not wish that, delete this exception notice.
  40  */
  41 \f
  42
  43 #include <stdio.h>
  44 #include "_scm.h"
  45 #include "markers.h"
  46
  47 #include "fports.h"
  48
  49 #ifdef HAVE_STRING_H
  50 #include <string.h>
  51 #endif
  52 #ifdef HAVE_UNISTD_H
  53 #include <unistd.h>
  54 #else
  55 scm_sizet fwrite ();
  56 #endif
  57
  58
  59 #ifdef __IBMC__
  60 #include <io.h>
  61 #include <direct.h>
  62 #else
  63 #ifndef MSDOS
  64 #ifndef ultrix
  65 #ifndef vms
  66 #ifdef _DCC
  67 #include <ioctl.h>
  68 #define setbuf(stream, buf) setvbuf(stream, buf, _IONBF, 0)
  69 #else
  70 #ifdef MWC
  71 #include <sys/io.h>
  72 #else
  73 #ifndef THINK_C
  74 #ifndef ARM_ULIB
  75 #include <sys/ioctl.h>
  76 #endif
  77 #endif
  78 #endif
  79 #endif
  80 #endif
  81 #endif
  82 #endif
  83 #endif
  84 \f
  85
  86 /* {Ports - file ports}
  87  *
  88  */
  89
  90 /* should be called with SCM_DEFER_INTS active */
  91
  92 SCM
  93 scm_setbuf0 (port)
  94      SCM port;
  95 {
  96 #ifndef NOSETBUF
  97 #ifndef MSDOS
  98 #ifdef FIONREAD
  99 #ifndef ultrix
 100   SCM_SYSCALL (setbuf ((FILE *)SCM_STREAM (port), 0););
 101 #endif
 102 #endif
 103 #endif
 104 #endif
 105   return SCM_UNSPECIFIED;
 106 }
 107
 108 /* Return the flags that characterize a port based on the mode
 109  * string used to open a file for that port.
 110  *
 111  * See PORT FLAGS in scm.h
 112  */
 113
 114 long
 115 scm_mode_bits (modes)
 116      char *modes;
 117 {
 118   return (SCM_OPN
 119           | (strchr (modes, 'r') || strchr (modes, '+') ? SCM_RDNG : 0)
 120           | (   strchr (modes, 'w')
 121              || strchr (modes, 'a')
 122              || strchr (modes, '+') ? SCM_WRTNG : 0)
 123           | (strchr (modes, '0') ? SCM_BUF0 : 0));
 124 }
 125
 126
 127 /* scm_open_file
 128  * Return a new port open on a given file.
 129  *
 130  * The mode string must match the pattern: [rwa+]** which
 131  * is interpreted in the usual unix way.
 132  *
 133  * Return the new port.
 134  */
 135 SCM_PROC(s_open_file, "open-file", 2, 0, 0, scm_open_file);
 136
 137 SCM
 138 scm_open_file (filename, modes)
 139      SCM filename;
 140      SCM modes;
 141 {
 142   SCM port;
 143   FILE *f;
 144   char *file;
 145   char *mode;
 146
 147   SCM_ASSERT (SCM_NIMP (filename) && SCM_ROSTRINGP (filename), filename, SCM_ARG1, s_open_file);
 148   SCM_ASSERT (SCM_NIMP (modes) && SCM_ROSTRINGP (modes), modes, SCM_ARG2, s_open_file);
 149   if (SCM_SUBSTRP (filename))
 150     filename = scm_makfromstr (SCM_ROCHARS (filename), SCM_ROLENGTH (filename), 0);
 151   if (SCM_SUBSTRP (modes))
 152     modes = scm_makfromstr (SCM_ROCHARS (modes), SCM_ROLENGTH (modes), 0);
 153
 154   file = SCM_ROCHARS (filename);
 155   mode = SCM_ROCHARS (modes);
 156
 157   SCM_NEWCELL (port);
 158   SCM_DEFER_INTS;
 159   SCM_SYSCALL (f = fopen (file, mode));
 160   if (!f)
 161     {
 162       scm_syserror_msg (s_open_file, "%s: %S",
 163                         scm_listify (scm_makfrom0str (strerror (errno)),
 164                                      filename,
 165                                      SCM_UNDEFINED));
 166     }
 167   else
 168     {
 169       struct scm_port_table * pt;
 170
 171       pt = scm_add_to_port_table (port);
 172       SCM_SETPTAB_ENTRY (port, pt);
 173       SCM_SETCAR (port, scm_tc16_fport | scm_mode_bits (mode));
 174       SCM_SETSTREAM (port, (SCM) f);
 175       if (SCM_BUF0 & SCM_CAR (port))
 176         scm_setbuf0 (port);
 177       SCM_PTAB_ENTRY (port)->file_name = filename;
 178     }
 179   SCM_ALLOW_INTS;
 180   return port;
 181 }
 182
 183
 184 /* Build a Scheme port from an open stdio port, FILE.
 185    MODE indicates whether FILE is open for reading or writing; it uses
 186       the same notation as open-file's second argument.
 187    If NAME is non-zero, use it as the port's filename.
 188
 189    scm_stdio_to_port sets the revealed count for FILE's file
 190    descriptor to 1, so that FILE won't be closed when the port object
 191    is GC'd.  */
 192 SCM
 193 scm_stdio_to_port (file, mode, name)
 194      FILE *file;
 195      char *mode;
 196      char *name;
 197 {
 198   long mode_bits = scm_mode_bits (mode);
 199   SCM port;
 200   struct scm_port_table * pt;
 201
 202   SCM_NEWCELL (port);
 203   SCM_DEFER_INTS;
 204   {
 205     pt = scm_add_to_port_table (port);
 206     SCM_SETPTAB_ENTRY (port, pt);
 207     SCM_SETCAR (port, (scm_tc16_fport | mode_bits));
 208     SCM_SETSTREAM (port, (SCM) file);
 209     if (SCM_BUF0 & SCM_CAR (port))
 210       scm_setbuf0 (port);
 211     SCM_PTAB_ENTRY (port)->file_name = scm_makfrom0str (name);
 212   }
 213   SCM_ALLOW_INTS;
 214   scm_set_port_revealed_x (port, SCM_MAKINUM (1));
 215   return port;
 216 }
 217
 218
 219 /* Return the mode flags from an open port.
 220  * Some modes such as "append" are only used when opening
 221  * a file and are not returned here.  */
 222
 223 SCM_PROC(s_port_mode, "port-mode", 1, 0, 0, scm_port_mode);
 224
 225 SCM
 226 scm_port_mode (port)
 227      SCM port;
 228 {
 229   char modes[3];
 230   modes[0] = '\0';
 231   SCM_ASSERT (SCM_NIMP (port) && SCM_OPPORTP (port), port, SCM_ARG1, s_port_mode);
 232   if (SCM_CAR (port) & SCM_RDNG) {
 233     if (SCM_CAR (port) & SCM_WRTNG)
 234       strcpy (modes, "r+");
 235     else
 236       strcpy (modes, "r");
 237   }
 238   else if (SCM_CAR (port) & SCM_WRTNG)
 239     strcpy (modes, "w");
 240   if (SCM_CAR (port) & SCM_BUF0)
 241     strcat (modes, "0");
 242   return scm_makfromstr (modes, strlen (modes), 0);
 243 }
 244
 245
 246
 247 static int prinfport SCM_P ((SCM exp, SCM port, scm_print_state *pstate));
 248
 249 static int
 250 prinfport (exp, port, pstate)
 251      SCM exp;
 252      SCM port;
 253      scm_print_state *pstate;
 254 {
 255   SCM name;
 256   char * c;
 257   if (SCM_CLOSEDP (exp))
 258     {
 259       c = "file";
 260     }
 261   else
 262     {
 263       name = SCM_PTAB_ENTRY (exp)->file_name;
 264       if (SCM_NIMP (name) && SCM_ROSTRINGP (name))
 265         c = SCM_ROCHARS (name);
 266       else
 267         c = "file";
 268     }
 269
 270   scm_prinport (exp, port, c);
 271   return !0;
 272 }
 273
 274
 275
 276 static int scm_fgetc SCM_P ((FILE * s));
 277
 278 static int
 279 scm_fgetc (s)
 280      FILE * s;
 281 {
 282   if (feof (s))
 283     return EOF;
 284   else
 285     return fgetc (s);
 286 }
 287
 288 #ifdef vms
 289
 290 static scm_sizet pwrite SCM_P ((char *ptr, scm_sizet size, nitems, FILE *port));
 291
 292 static scm_sizet
 293 pwrite (ptr, size, nitems, port)
 294      char *ptr;
 295      scm_sizet size, nitems;
 296      FILE *port;
 297 {
 298   scm_sizet len = size * nitems;
 299   scm_sizet i = 0;
 300   for (; i < len; i++)
 301     putc (ptr[i], port);
 302   return len;
 303 }
 304
 305 #define ffwrite pwrite
 306 #else
 307 #define ffwrite fwrite
 308 #endif
 309
 310 \f
 311 /* This otherwise pointless code helps some poor
 312  * crippled C compilers cope with life.
 313  */
 314
 315 static int local_fclose SCM_P ((FILE *fp));
 316
 317 static int
 318 local_fclose (fp)
 319      FILE * fp;
 320 {
 321   return fclose (fp);
 322 }
 323
 324 static int local_fflush SCM_P ((FILE *fp));
 325
 326 static int
 327 local_fflush (fp)
 328      FILE * fp;
 329 {
 330   return fflush (fp);
 331 }
 332
 333 static int local_fputc SCM_P ((int c, FILE *fp));
 334
 335 static int
 336 local_fputc (c, fp)
 337      int c;
 338      FILE * fp;
 339 {
 340   return fputc (c, fp);
 341 }
 342
 343 static int local_fputs SCM_P ((char *s, FILE *fp));
 344
 345 static int
 346 local_fputs (s, fp)
 347      char * s;
 348      FILE * fp;
 349 {
 350   return fputs (s, fp);
 351 }
 352
 353 static scm_sizet local_ffwrite SCM_P ((void *ptr, int size, int nitems, FILE *fp));
 354
 355 static scm_sizet
 356 local_ffwrite (ptr, size, nitems, fp)
 357      void * ptr;
 358      int size;
 359      int nitems;
 360      FILE * fp;
 361 {
 362   return ffwrite (ptr, size, nitems, fp);
 363 }
 364
 365 \f
 366 scm_ptobfuns scm_fptob =
 367 {
 368   scm_mark0,
 369   (int (*) SCM_P ((SCM))) local_fclose,
 370   prinfport,
 371   0,
 372   (int (*) SCM_P ((int, SCM))) local_fputc,
 373   (int (*) SCM_P ((char *, SCM))) local_fputs,
 374   (scm_sizet (*) SCM_P ((char *, scm_sizet, scm_sizet, SCM))) local_ffwrite,
 375   (int (*) SCM_P ((SCM))) local_fflush,
 376   (int (*) SCM_P ((SCM))) scm_fgetc,
 377   (int (*) SCM_P ((SCM))) local_fclose
 378 };
 379
 380 /* {Pipe ports}
 381  */
 382 scm_ptobfuns scm_pipob =
 383 {
 384   scm_mark0,
 385   0,                            /* replaced by pclose in scm_init_ioext() */
 386   0,                            /* replaced by prinpipe in scm_init_ioext() */
 387   0,
 388   (int (*) SCM_P ((int, SCM))) local_fputc,
 389   (int (*) SCM_P ((char *, SCM))) local_fputs,
 390   (scm_sizet (*) SCM_P ((char *, scm_sizet, scm_sizet, SCM))) local_ffwrite,
 391   (int (*) SCM_P ((SCM))) local_fflush,
 392   (int (*) SCM_P ((SCM))) scm_fgetc,
 393   0
 394 };                              /* replaced by pclose in scm_init_ioext() */
 395
 396 void
 397 scm_init_fports ()
 398 {
 399 #include "fports.x"
 400 }