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 #ifdef __STDC__
  92 SCM
  93 scm_setbuf0 (SCM port)
  94 #else
  95 SCM
  96 scm_setbuf0 (port)
  97      SCM port;
  98 #endif
  99 {
 100 #ifndef NOSETBUF
 101 #ifndef MSDOS
 102 #ifdef FIONREAD
 103 #ifndef ultrix
 104   SCM_SYSCALL (setbuf ((FILE *)SCM_STREAM (port), 0););
 105 #endif
 106 #endif
 107 #endif
 108 #endif
 109   return SCM_UNSPECIFIED;
 110 }
 111
 112 /* Return the flags that characterize a port based on the mode
 113  * string used to open a file for that port.
 114  *
 115  * See PORT FLAGS in scm.h
 116  */
 117 #ifdef __STDC__
 118 long
 119 scm_mode_bits (char *modes)
 120 #else
 121 long
 122 scm_mode_bits (modes)
 123      char *modes;
 124 #endif
 125 {
 126   return (SCM_OPN
 127           | (strchr (modes, 'r') || strchr (modes, '+') ? SCM_RDNG : 0)
 128           | (   strchr (modes, 'w')
 129              || strchr (modes, 'a')
 130              || strchr (modes, '+') ? SCM_WRTNG : 0)
 131           | (strchr (modes, '0') ? SCM_BUF0 : 0));
 132 }
 133
 134
 135 /* scm_open_file
 136  * Return a new port open on a given file.
 137  *
 138  * The mode string must match the pattern: [rwa+]** which
 139  * is interpreted in the usual unix way.
 140  *
 141  * Return the new port.
 142  */
 143
 144 #ifdef __STDC__
 145 SCM
 146 scm_mkfile (char * name, char * modes)
 147 #else
 148 SCM
 149 scm_mkfile (name, modes)
 150      char * name;
 151      char * modes;
 152 #endif
 153 {
 154   register SCM port;
 155   FILE *f;
 156   SCM_NEWCELL (port);
 157   SCM_DEFER_INTS;
 158   SCM_SYSCALL (f = fopen (name, modes));
 159   if (!f)
 160     {
 161       SCM_ALLOW_INTS;
 162       port = SCM_BOOL_F;
 163     }
 164   else
 165     {
 166       struct scm_port_table * pt;
 167       pt = scm_add_to_port_table (port);
 168       SCM_SETPTAB_ENTRY (port, pt);
 169       if (SCM_BUF0 & (SCM_CAR (port) = scm_tc16_fport | scm_mode_bits (modes)))
 170         scm_setbuf0 (port);
 171       SCM_SETSTREAM (port, (SCM)f);
 172       SCM_PTAB_ENTRY (port)->file_name = scm_makfrom0str (name);
 173       SCM_ALLOW_INTS;
 174     }
 175   return port;
 176 }
 177
 178 SCM_PROC(s_open_file, "open-file", 2, 0, 0, scm_open_file);
 179 #ifdef __STDC__
 180 SCM
 181 scm_open_file (SCM filename, SCM modes)
 182 #else
 183 SCM
 184 scm_open_file (filename, modes)
 185      SCM filename;
 186      SCM modes;
 187 #endif
 188 {
 189   SCM port;
 190   SCM_ASSERT (SCM_NIMP (filename) && SCM_ROSTRINGP (filename), filename, SCM_ARG1, s_open_file);
 191   SCM_ASSERT (SCM_NIMP (modes) && SCM_ROSTRINGP (modes), modes, SCM_ARG2, s_open_file);
 192   if (SCM_SUBSTRP (filename))
 193     filename = scm_makfromstr (SCM_ROCHARS (filename), SCM_ROLENGTH (filename), 0);
 194   if (SCM_SUBSTRP (modes))
 195     modes = scm_makfromstr (SCM_ROCHARS (modes), SCM_ROLENGTH (modes), 0);
 196   port = scm_mkfile (SCM_ROCHARS (filename), SCM_ROCHARS (modes));
 197
 198   if (port == SCM_BOOL_F) {
 199     SCM_SYSERROR_M (s_open_file, "%S: %S",
 200                     scm_listify (scm_makfrom0str (strerror (errno)),
 201                                  filename,
 202                                  SCM_UNDEFINED));
 203     /* Force the compiler to keep filename and modes alive.  */
 204     scm_cons (filename, modes);
 205   }
 206   return port;
 207 }
 208
 209 /* Return the mode flags from an open port.
 210  * Some modes such as "append" are only used when opening
 211  * a file and are not returned here.
 212  */
 213
 214 SCM_PROC(s_port_mode, "port-mode", 1, 0, 0, scm_port_mode);
 215 #ifdef __STDC__
 216 SCM
 217 scm_port_mode (SCM port)
 218 #else
 219 SCM
 220 scm_port_mode (port)
 221      SCM port;
 222 #endif
 223 {
 224   char modes[3];
 225   modes[0] = '\0';
 226   SCM_ASSERT (SCM_NIMP (port) && SCM_OPPORTP (port), port, SCM_ARG1, s_port_mode);
 227   if (SCM_CAR (port) & SCM_RDNG) {
 228     if (SCM_CAR (port) & SCM_WRTNG)
 229       strcpy (modes, "r+");
 230     else
 231       strcpy (modes, "r");
 232   }
 233   else if (SCM_CAR (port) & SCM_WRTNG)
 234     strcpy (modes, "w");
 235   if (SCM_CAR (port) & SCM_BUF0)
 236     strcat (modes, "0");
 237   return scm_makfromstr (modes, strlen (modes), 0);
 238 }
 239
 240
 241 #ifdef __STDC__
 242 static int
 243 prinfport (SCM exp, SCM port, int writing)
 244 #else
 245 static int
 246 prinfport (exp, port, writing)
 247      SCM exp;
 248      SCM port;
 249      int writing;
 250 #endif
 251 {
 252   SCM name;
 253   char * c;
 254   if (SCM_CLOSEDP (exp))
 255     {
 256       c = "file";
 257     }
 258   else
 259     {
 260       name = SCM_PTAB_ENTRY (exp)->file_name;
 261       if (SCM_NIMP (name) && SCM_ROSTRINGP (name))
 262         c = SCM_ROCHARS (name);
 263       else
 264         c = "file";
 265     }
 266
 267   scm_prinport (exp, port, c);
 268   return !0;
 269 }
 270
 271
 272 #ifdef __STDC__
 273 static int
 274 scm_fgetc (FILE * s)
 275 #else
 276 static int
 277 scm_fgetc (s)
 278      FILE * s;
 279 #endif
 280 {
 281   if (feof (s))
 282     return EOF;
 283   else
 284     return fgetc (s);
 285 }
 286
 287 #ifdef vms
 288 #ifdef __STDC__
 289 static scm_sizet
 290 pwrite (char *ptr, scm_sizet size, nitems, FILE *port)
 291 #else
 292 static scm_sizet
 293 pwrite (ptr, size, nitems, port)
 294      char *ptr;
 295      scm_sizet size, nitems;
 296      FILE *port;
 297 #endif
 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 static int
 316 local_fclose (fp)
 317      FILE * fp;
 318 {
 319   return fclose (fp);
 320 }
 321
 322 static int
 323 local_fflush (fp)
 324      FILE * fp;
 325 {
 326   return fflush (fp);
 327 }
 328
 329 static int
 330 local_fputc (c, fp)
 331      int c;
 332      FILE * fp;
 333 {
 334   return fputc (c, fp);
 335 }
 336
 337 static int
 338 local_fputs (s, fp)
 339      char * s;
 340      FILE * fp;
 341 {
 342   return fputs (s, fp);
 343 }
 344
 345 static scm_sizet
 346 local_ffwrite (ptr, size, nitems, fp)
 347      void * ptr;
 348      int size;
 349      int nitems;
 350      FILE * fp;
 351 {
 352   return ffwrite (ptr, size, nitems, fp);
 353 }
 354
 355 \f
 356 scm_ptobfuns scm_fptob =
 357 {
 358   scm_mark0,
 359   local_fclose,
 360   prinfport,
 361   0,
 362   local_fputc,
 363   local_fputs,
 364   local_ffwrite,
 365   local_fflush,
 366   scm_fgetc,
 367   local_fclose
 368 };
 369
 370 /* {Pipe ports}
 371  */
 372 scm_ptobfuns scm_pipob =
 373 {
 374   scm_mark0,
 375   0,                            /* replaced by pclose in scm_init_ioext() */
 376   0,                            /* replaced by prinpipe in scm_init_ioext() */
 377   0,
 378   local_fputc,
 379   local_fputs,
 380   local_ffwrite,
 381   local_fflush,
 382   scm_fgetc,
 383   0
 384 };                              /* replaced by pclose in scm_init_ioext() */
 385
 386
 387 #ifdef __STDC__
 388 void
 389 scm_init_fports (void)
 390 #else
 391 void
 392 scm_init_fports ()
 393 #endif
 394 {
 395 #include "fports.x"
 396 }
 397