libguile/fports.c

   1 /*      Copyright (C) 1995,1996,1997 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, Inc., 59 Temple Place, Suite 330,
  16  * Boston, MA 02111-1307 USA
  17  *
  18  * As a special exception, the Free Software Foundation gives permission
  19  * for additional uses of the text contained in its release of GUILE.
  20  *
  21  * The exception is that, if you link the GUILE library with other files
  22  * to produce an executable, this does not by itself cause the
  23  * resulting executable to be covered by the GNU General Public License.
  24  * Your use of that executable is in no way restricted on account of
  25  * linking the GUILE library code into it.
  26  *
  27  * This exception does not however invalidate any other reasons why
  28  * the executable file might be covered by the GNU General Public License.
  29  *
  30  * This exception applies only to the code released by the
  31  * Free Software Foundation under the name GUILE.  If you copy
  32  * code from other Free Software Foundation releases into a copy of
  33  * GUILE, as the General Public License permits, the exception does
  34  * not apply to the code that you add in this way.  To avoid misleading
  35  * anyone as to the status of such modified files, you must delete
  36  * this exception notice from them.
  37  *
  38  * If you write modifications of your own for GUILE, it is your choice
  39  * whether to permit this exception to apply to your modifications.
  40  * If you do not wish that, delete this exception notice.  */
  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 #ifndef ultrix
  99   SCM_SYSCALL (setbuf ((FILE *)SCM_STREAM (port), 0););
 100 #endif
 101 #endif
 102 #endif
 103   return SCM_UNSPECIFIED;
 104 }
 105
 106 /* Return the flags that characterize a port based on the mode
 107  * string used to open a file for that port.
 108  *
 109  * See PORT FLAGS in scm.h
 110  */
 111
 112 long
 113 scm_mode_bits (modes)
 114      char *modes;
 115 {
 116   return (SCM_OPN
 117           | (strchr (modes, 'r') || strchr (modes, '+') ? SCM_RDNG : 0)
 118           | (   strchr (modes, 'w')
 119              || strchr (modes, 'a')
 120              || strchr (modes, '+') ? SCM_WRTNG : 0)
 121           | (strchr (modes, '0') ? SCM_BUF0 : 0));
 122 }
 123
 124
 125 /* scm_open_file
 126  * Return a new port open on a given file.
 127  *
 128  * The mode string must match the pattern: [rwa+]** which
 129  * is interpreted in the usual unix way.
 130  *
 131  * Return the new port.
 132  */
 133 SCM_PROC(s_open_file, "open-file", 2, 0, 0, scm_open_file);
 134
 135 SCM
 136 scm_open_file (filename, modes)
 137      SCM filename;
 138      SCM modes;
 139 {
 140   SCM port;
 141   FILE *f;
 142   char *file;
 143   char *mode;
 144
 145   SCM_ASSERT (SCM_NIMP (filename) && SCM_ROSTRINGP (filename), filename, SCM_ARG1, s_open_file);
 146   SCM_ASSERT (SCM_NIMP (modes) && SCM_ROSTRINGP (modes), modes, SCM_ARG2, s_open_file);
 147   if (SCM_SUBSTRP (filename))
 148     filename = scm_makfromstr (SCM_ROCHARS (filename), SCM_ROLENGTH (filename), 0);
 149   if (SCM_SUBSTRP (modes))
 150     modes = scm_makfromstr (SCM_ROCHARS (modes), SCM_ROLENGTH (modes), 0);
 151
 152   file = SCM_ROCHARS (filename);
 153   mode = SCM_ROCHARS (modes);
 154
 155   SCM_NEWCELL (port);
 156   SCM_DEFER_INTS;
 157   SCM_SYSCALL (f = fopen (file, mode));
 158   if (!f)
 159     {
 160       int en = errno;
 161
 162       scm_syserror_msg (s_open_file, "%s: %S",
 163                         scm_listify (scm_makfrom0str (strerror (errno)),
 164                                      filename,
 165                                      SCM_UNDEFINED),
 166                         en);
 167     }
 168   else
 169     {
 170       struct scm_port_table * pt;
 171
 172       pt = scm_add_to_port_table (port);
 173       SCM_SETPTAB_ENTRY (port, pt);
 174       SCM_SETCAR (port, scm_tc16_fport | scm_mode_bits (mode));
 175       SCM_SETSTREAM (port, (SCM) f);
 176       if (SCM_BUF0 & SCM_CAR (port))
 177         scm_setbuf0 (port);
 178       SCM_PTAB_ENTRY (port)->file_name = filename;
 179     }
 180   SCM_ALLOW_INTS;
 181   return port;
 182 }
 183
 184
 185 /* Build a Scheme port from an open stdio port, FILE.
 186    MODE indicates whether FILE is open for reading or writing; it uses
 187       the same notation as open-file's second argument.
 188    If NAME is non-zero, use it as the port's filename.
 189
 190    scm_stdio_to_port sets the revealed count for FILE's file
 191    descriptor to 1, so that FILE won't be closed when the port object
 192    is GC'd.  */
 193 SCM
 194 scm_stdio_to_port (file, mode, name)
 195      FILE *file;
 196      char *mode;
 197      char *name;
 198 {
 199   long mode_bits = scm_mode_bits (mode);
 200   SCM port;
 201   struct scm_port_table * pt;
 202
 203   SCM_NEWCELL (port);
 204   SCM_DEFER_INTS;
 205   {
 206     pt = scm_add_to_port_table (port);
 207     SCM_SETPTAB_ENTRY (port, pt);
 208     SCM_SETCAR (port, (scm_tc16_fport | mode_bits));
 209     SCM_SETSTREAM (port, (SCM) file);
 210     if (SCM_BUF0 & SCM_CAR (port))
 211       scm_setbuf0 (port);
 212     SCM_PTAB_ENTRY (port)->file_name = scm_makfrom0str (name);
 213   }
 214   SCM_ALLOW_INTS;
 215   scm_set_port_revealed_x (port, SCM_MAKINUM (1));
 216   return port;
 217 }
 218
 219
 220 /* Return the mode flags from an open port.
 221  * Some modes such as "append" are only used when opening
 222  * a file and are not returned here.  */
 223
 224 SCM_PROC(s_port_mode, "port-mode", 1, 0, 0, scm_port_mode);
 225
 226 SCM
 227 scm_port_mode (port)
 228      SCM port;
 229 {
 230   char modes[3];
 231   modes[0] = '\0';
 232   SCM_ASSERT (SCM_NIMP (port) && SCM_OPPORTP (port), port, SCM_ARG1, s_port_mode);
 233   if (SCM_CAR (port) & SCM_RDNG) {
 234     if (SCM_CAR (port) & SCM_WRTNG)
 235       strcpy (modes, "r+");
 236     else
 237       strcpy (modes, "r");
 238   }
 239   else if (SCM_CAR (port) & SCM_WRTNG)
 240     strcpy (modes, "w");
 241   if (SCM_CAR (port) & SCM_BUF0)
 242     strcat (modes, "0");
 243   return scm_makfromstr (modes, strlen (modes), 0);
 244 }
 245
 246
 247
 248 static int prinfport SCM_P ((SCM exp, SCM port, scm_print_state *pstate));
 249
 250 static int
 251 prinfport (exp, port, pstate)
 252      SCM exp;
 253      SCM port;
 254      scm_print_state *pstate;
 255 {
 256   SCM name;
 257   char * c;
 258   if (SCM_CLOSEDP (exp))
 259     {
 260       c = "file";
 261     }
 262   else
 263     {
 264       name = SCM_PTAB_ENTRY (exp)->file_name;
 265       if (SCM_NIMP (name) && SCM_ROSTRINGP (name))
 266         c = SCM_ROCHARS (name);
 267       else
 268         c = "file";
 269     }
 270
 271   scm_prinport (exp, port, c);
 272   return !0;
 273 }
 274
 275
 276
 277 static int scm_fgetc SCM_P ((FILE * s));
 278
 279 static int
 280 scm_fgetc (s)
 281      FILE * s;
 282 {
 283   if (feof (s))
 284     return EOF;
 285   else
 286     return fgetc (s);
 287 }
 288
 289 #ifdef vms
 290
 291 static scm_sizet pwrite SCM_P ((char *ptr, scm_sizet size, nitems, FILE *port));
 292
 293 static scm_sizet
 294 pwrite (ptr, size, nitems, port)
 295      char *ptr;
 296      scm_sizet size, nitems;
 297      FILE *port;
 298 {
 299   scm_sizet len = size * nitems;
 300   scm_sizet i = 0;
 301   for (; i < len; i++)
 302     putc (ptr[i], port);
 303   return len;
 304 }
 305
 306 #define ffwrite pwrite
 307 #else
 308 #define ffwrite fwrite
 309 #endif
 310
 311 \f
 312 /* This otherwise pointless code helps some poor
 313  * crippled C compilers cope with life.
 314  */
 315
 316 static int local_fclose SCM_P ((FILE *fp));
 317
 318 static int
 319 local_fclose (fp)
 320      FILE * fp;
 321 {
 322   return fclose (fp);
 323 }
 324
 325 static int local_fflush SCM_P ((FILE *fp));
 326
 327 static int
 328 local_fflush (fp)
 329      FILE * fp;
 330 {
 331   return fflush (fp);
 332 }
 333
 334 static int local_fputc SCM_P ((int c, FILE *fp));
 335
 336 static int
 337 local_fputc (c, fp)
 338      int c;
 339      FILE * fp;
 340 {
 341   return fputc (c, fp);
 342 }
 343
 344 static int local_fputs SCM_P ((char *s, FILE *fp));
 345
 346 static int
 347 local_fputs (s, fp)
 348      char * s;
 349      FILE * fp;
 350 {
 351   return fputs (s, fp);
 352 }
 353
 354 static scm_sizet local_ffwrite SCM_P ((void *ptr, int size, int nitems, FILE *fp));
 355
 356 static scm_sizet
 357 local_ffwrite (ptr, size, nitems, fp)
 358      void * ptr;
 359      int size;
 360      int nitems;
 361      FILE * fp;
 362 {
 363   return ffwrite (ptr, size, nitems, fp);
 364 }
 365
 366 /* On SunOS, there's no declaration for pclose in the headers, so
 367    putting it directly in the initializer for scm_pipob doesn't really
 368    fly.  We could add an extern declaration for it, but then it'll
 369    mismatch on some systems that do have a declaration.  So we just
 370    wrap it up this way.  */
 371 static int
 372 local_pclose (fp)
 373      FILE * fp;
 374 {
 375   return pclose (fp);
 376 }
 377
 378 \f
 379 scm_ptobfuns scm_fptob =
 380 {
 381   scm_mark0,
 382   (int (*) SCM_P ((SCM))) local_fclose,
 383   prinfport,
 384   0,
 385   (int (*) SCM_P ((int, SCM))) local_fputc,
 386   (int (*) SCM_P ((char *, SCM))) local_fputs,
 387   (scm_sizet (*) SCM_P ((char *, scm_sizet, scm_sizet, SCM))) local_ffwrite,
 388   (int (*) SCM_P ((SCM))) local_fflush,
 389   (int (*) SCM_P ((SCM))) scm_fgetc,
 390   (int (*) SCM_P ((SCM))) local_fclose
 391 };
 392
 393 /* {Pipe ports} */
 394 scm_ptobfuns scm_pipob =
 395 {
 396   scm_mark0,
 397   (int (*) SCM_P ((SCM))) local_pclose,
 398   scm_prinport,
 399   0,
 400   (int (*) SCM_P ((int, SCM))) local_fputc,
 401   (int (*) SCM_P ((char *, SCM))) local_fputs,
 402   (scm_sizet (*) SCM_P ((char *, scm_sizet, scm_sizet, SCM))) local_ffwrite,
 403   (int (*) SCM_P ((SCM))) local_fflush,
 404   (int (*) SCM_P ((SCM))) scm_fgetc,
 405   (int (*) SCM_P ((SCM))) local_pclose
 406 };
 407
 408 void
 409 scm_init_fports ()
 410 {
 411 #include "fports.x"
 412 }