libgfortran/io/intrinsics.c

   1 /* Implementation of the FGET, FGETC, FPUT, FPUTC, FLUSH
   2    FTELL, TTYNAM and ISATTY intrinsics.
   3    Copyright (C) 2005, 2007, 2009, 2010 Free Software Foundation, Inc.
   4
   5 This file is part of the GNU Fortran runtime library (libgfortran).
   6
   7 Libgfortran is free software; you can redistribute it and/or
   8 modify it under the terms of the GNU General Public
   9 License as published by the Free Software Foundation; either
  10 version 3 of the License, or (at your option) any later version.
  11
  12 Libgfortran is distributed in the hope that it will be useful,
  13 but WITHOUT ANY WARRANTY; without even the implied warranty of
  14 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  15 GNU General Public License for more details.
  16
  17 Under Section 7 of GPL version 3, you are granted additional
  18 permissions described in the GCC Runtime Library Exception, version
  19 3.1, as published by the Free Software Foundation.
  20
  21 You should have received a copy of the GNU General Public License and
  22 a copy of the GCC Runtime Library Exception along with this program;
  23 see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see
  24 <http://www.gnu.org/licenses/>.  */
  25
  26 #include "io.h"
  27 #include "fbuf.h"
  28 #include "unix.h"
  29
  30 #ifdef HAVE_STDLIB_H
  31 #include <stdlib.h>
  32 #endif
  33
  34 #include <string.h>
  35
  36 static const int five = 5;
  37 static const int six = 6;
  38
  39 extern int PREFIX(fgetc) (const int *, char *, gfc_charlen_type);
  40 export_proto_np(PREFIX(fgetc));
  41
  42 int
  43 PREFIX(fgetc) (const int * unit, char * c, gfc_charlen_type c_len)
  44 {
  45   int ret;
  46   gfc_unit * u = find_unit (*unit);
  47
  48   if (u == NULL)
  49     return -1;
  50
  51   fbuf_reset (u);
  52   if (u->mode == WRITING)
  53     {
  54       sflush (u->s);
  55       u->mode = READING;
  56     }
  57
  58   memset (c, ' ', c_len);
  59   ret = sread (u->s, c, 1);
  60   unlock_unit (u);
  61
  62   if (ret < 0)
  63     return ret;
  64
  65   if (ret != 1)
  66     return -1;
  67   else
  68     return 0;
  69 }
  70
  71
  72 #define FGETC_SUB(kind) \
  73   extern void fgetc_i ## kind ## _sub \
  74     (const int *, char *, GFC_INTEGER_ ## kind *, gfc_charlen_type); \
  75   export_proto(fgetc_i ## kind ## _sub); \
  76   void fgetc_i ## kind ## _sub \
  77   (const int * unit, char * c, GFC_INTEGER_ ## kind * st, gfc_charlen_type c_len) \
  78     { if (st != NULL) \
  79         *st = PREFIX(fgetc) (unit, c, c_len); \
  80       else \
  81         PREFIX(fgetc) (unit, c, c_len); }
  82
  83 FGETC_SUB(1)
  84 FGETC_SUB(2)
  85 FGETC_SUB(4)
  86 FGETC_SUB(8)
  87
  88
  89 extern int PREFIX(fget) (char *, gfc_charlen_type);
  90 export_proto_np(PREFIX(fget));
  91
  92 int
  93 PREFIX(fget) (char * c, gfc_charlen_type c_len)
  94 {
  95   return PREFIX(fgetc) (&five, c, c_len);
  96 }
  97
  98
  99 #define FGET_SUB(kind) \
 100   extern void fget_i ## kind ## _sub \
 101     (char *, GFC_INTEGER_ ## kind *, gfc_charlen_type); \
 102   export_proto(fget_i ## kind ## _sub); \
 103   void fget_i ## kind ## _sub \
 104   (char * c, GFC_INTEGER_ ## kind * st, gfc_charlen_type c_len) \
 105     { if (st != NULL) \
 106         *st = PREFIX(fgetc) (&five, c, c_len); \
 107       else \
 108         PREFIX(fgetc) (&five, c, c_len); }
 109
 110 FGET_SUB(1)
 111 FGET_SUB(2)
 112 FGET_SUB(4)
 113 FGET_SUB(8)
 114
 115
 116
 117 extern int PREFIX(fputc) (const int *, char *, gfc_charlen_type);
 118 export_proto_np(PREFIX(fputc));
 119
 120 int
 121 PREFIX(fputc) (const int * unit, char * c,
 122                gfc_charlen_type c_len __attribute__((unused)))
 123 {
 124   ssize_t s;
 125   gfc_unit * u = find_unit (*unit);
 126
 127   if (u == NULL)
 128     return -1;
 129
 130   fbuf_reset (u);
 131   if (u->mode == READING)
 132     {
 133       sflush (u->s);
 134       u->mode = WRITING;
 135     }
 136
 137   s = swrite (u->s, c, 1);
 138   unlock_unit (u);
 139   if (s < 0)
 140     return -1;
 141   return 0;
 142 }
 143
 144
 145 #define FPUTC_SUB(kind) \
 146   extern void fputc_i ## kind ## _sub \
 147     (const int *, char *, GFC_INTEGER_ ## kind *, gfc_charlen_type); \
 148   export_proto(fputc_i ## kind ## _sub); \
 149   void fputc_i ## kind ## _sub \
 150   (const int * unit, char * c, GFC_INTEGER_ ## kind * st, gfc_charlen_type c_len) \
 151     { if (st != NULL) \
 152         *st = PREFIX(fputc) (unit, c, c_len); \
 153       else \
 154         PREFIX(fputc) (unit, c, c_len); }
 155
 156 FPUTC_SUB(1)
 157 FPUTC_SUB(2)
 158 FPUTC_SUB(4)
 159 FPUTC_SUB(8)
 160
 161
 162 extern int PREFIX(fput) (char *, gfc_charlen_type);
 163 export_proto_np(PREFIX(fput));
 164
 165 int
 166 PREFIX(fput) (char * c, gfc_charlen_type c_len)
 167 {
 168   return PREFIX(fputc) (&six, c, c_len);
 169 }
 170
 171
 172 #define FPUT_SUB(kind) \
 173   extern void fput_i ## kind ## _sub \
 174     (char *, GFC_INTEGER_ ## kind *, gfc_charlen_type); \
 175   export_proto(fput_i ## kind ## _sub); \
 176   void fput_i ## kind ## _sub \
 177   (char * c, GFC_INTEGER_ ## kind * st, gfc_charlen_type c_len) \
 178     { if (st != NULL) \
 179         *st = PREFIX(fputc) (&six, c, c_len); \
 180       else \
 181         PREFIX(fputc) (&six, c, c_len); }
 182
 183 FPUT_SUB(1)
 184 FPUT_SUB(2)
 185 FPUT_SUB(4)
 186 FPUT_SUB(8)
 187
 188
 189 /* SUBROUTINE FLUSH(UNIT)
 190    INTEGER, INTENT(IN), OPTIONAL :: UNIT  */
 191
 192 extern void flush_i4 (GFC_INTEGER_4 *);
 193 export_proto(flush_i4);
 194
 195 void
 196 flush_i4 (GFC_INTEGER_4 *unit)
 197 {
 198   gfc_unit *us;
 199
 200   /* flush all streams */
 201   if (unit == NULL)
 202     flush_all_units ();
 203   else
 204     {
 205       us = find_unit (*unit);
 206       if (us != NULL)
 207         {
 208           sflush (us->s);
 209           unlock_unit (us);
 210         }
 211     }
 212 }
 213
 214
 215 extern void flush_i8 (GFC_INTEGER_8 *);
 216 export_proto(flush_i8);
 217
 218 void
 219 flush_i8 (GFC_INTEGER_8 *unit)
 220 {
 221   gfc_unit *us;
 222
 223   /* flush all streams */
 224   if (unit == NULL)
 225     flush_all_units ();
 226   else
 227     {
 228       us = find_unit (*unit);
 229       if (us != NULL)
 230         {
 231           sflush (us->s);
 232           unlock_unit (us);
 233         }
 234     }
 235 }
 236
 237 /* FSEEK intrinsic */
 238
 239 extern void fseek_sub (int *, GFC_IO_INT *, int *, int *);
 240 export_proto(fseek_sub);
 241
 242 void
 243 fseek_sub (int * unit, GFC_IO_INT * offset, int * whence, int * status)
 244 {
 245   gfc_unit * u = find_unit (*unit);
 246   ssize_t result = -1;
 247
 248   if (u != NULL && is_seekable(u->s))
 249     {
 250       result = sseek(u->s, *offset, *whence);
 251
 252       unlock_unit (u);
 253     }
 254
 255   if (status)
 256     *status = (result < 0 ? -1 : 0);
 257 }
 258
 259
 260
 261 /* FTELL intrinsic */
 262
 263 static gfc_offset
 264 gf_ftell (int unit)
 265 {
 266   gfc_unit * u = find_unit (unit);
 267   if (u == NULL)
 268     return -1;
 269   int pos = fbuf_reset (u);
 270   if (pos != 0)
 271     sseek (u->s, pos, SEEK_CUR);
 272   gfc_offset ret = stell (u->s);
 273   unlock_unit (u);
 274   return ret;
 275 }
 276
 277 extern size_t PREFIX(ftell) (int *);
 278 export_proto_np(PREFIX(ftell));
 279
 280 size_t
 281 PREFIX(ftell) (int * unit)
 282 {
 283   gfc_unit * u = find_unit (*unit);
 284   gfc_offset ret;
 285   if (u == NULL)
 286     return ((size_t) -1);
 287   ret = stell (u->s) + fbuf_reset (u);
 288   unlock_unit (u);
 289   return ret;
 290 }
 291
 292 #define FTELL_SUB(kind) \
 293   extern void ftell_i ## kind ## _sub (int *, GFC_INTEGER_ ## kind *); \
 294   export_proto(ftell_i ## kind ## _sub); \
 295   void \
 296   ftell_i ## kind ## _sub (int * unit, GFC_INTEGER_ ## kind * offset) \
 297   { \
 298     gfc_unit * u = find_unit (*unit); \
 299     if (u == NULL) \
 300       *offset = -1; \
 301     else \
 302       { \
 303         *offset = stell (u->s) + fbuf_reset (u);        \
 304         unlock_unit (u); \
 305       } \
 306   }
 307
 308 FTELL_SUB(1)
 309 FTELL_SUB(2)
 310 FTELL_SUB(4)
 311 FTELL_SUB(8)
 312
 313
 314
 315 /* LOGICAL FUNCTION ISATTY(UNIT)
 316    INTEGER, INTENT(IN) :: UNIT */
 317
 318 extern GFC_LOGICAL_4 isatty_l4 (int *);
 319 export_proto(isatty_l4);
 320
 321 GFC_LOGICAL_4
 322 isatty_l4 (int *unit)
 323 {
 324   gfc_unit *u;
 325   GFC_LOGICAL_4 ret = 0;
 326
 327   u = find_unit (*unit);
 328   if (u != NULL)
 329     {
 330       ret = (GFC_LOGICAL_4) stream_isatty (u->s);
 331       unlock_unit (u);
 332     }
 333   return ret;
 334 }
 335
 336
 337 extern GFC_LOGICAL_8 isatty_l8 (int *);
 338 export_proto(isatty_l8);
 339
 340 GFC_LOGICAL_8
 341 isatty_l8 (int *unit)
 342 {
 343   gfc_unit *u;
 344   GFC_LOGICAL_8 ret = 0;
 345
 346   u = find_unit (*unit);
 347   if (u != NULL)
 348     {
 349       ret = (GFC_LOGICAL_8) stream_isatty (u->s);
 350       unlock_unit (u);
 351     }
 352   return ret;
 353 }
 354
 355
 356 /* SUBROUTINE TTYNAM(UNIT,NAME)
 357    INTEGER,SCALAR,INTENT(IN) :: UNIT
 358    CHARACTER,SCALAR,INTENT(OUT) :: NAME */
 359
 360 extern void ttynam_sub (int *, char *, gfc_charlen_type);
 361 export_proto(ttynam_sub);
 362
 363 void
 364 ttynam_sub (int *unit, char * name, gfc_charlen_type name_len)
 365 {
 366   gfc_unit *u;
 367   char * n;
 368   int i;
 369
 370   memset (name, ' ', name_len);
 371   u = find_unit (*unit);
 372   if (u != NULL)
 373     {
 374       n = stream_ttyname (u->s);
 375       if (n != NULL)
 376         {
 377           i = 0;
 378           while (*n && i < name_len)
 379             name[i++] = *(n++);
 380         }
 381       unlock_unit (u);
 382     }
 383 }
 384
 385
 386 extern void ttynam (char **, gfc_charlen_type *, int);
 387 export_proto(ttynam);
 388
 389 void
 390 ttynam (char ** name, gfc_charlen_type * name_len, int unit)
 391 {
 392   gfc_unit *u;
 393
 394   u = find_unit (unit);
 395   if (u != NULL)
 396     {
 397       *name = stream_ttyname (u->s);
 398       if (*name != NULL)
 399         {
 400           *name_len = strlen (*name);
 401           *name = strdup (*name);
 402           unlock_unit (u);
 403           return;
 404         }
 405       unlock_unit (u);
 406     }
 407
 408   *name_len = 0;
 409   *name = NULL;
 410 }