libgfortran/io/intrinsics.c

   1 /* Implementation of the FGET, FGETC, FPUT, FPUTC, FLUSH
   2    FTELL, TTYNAM and ISATTY intrinsics.
   3    Copyright (C) 2005-2015 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 #include <stdlib.h>
  30 #include <string.h>
  31
  32
  33 static const int five = 5;
  34 static const int six = 6;
  35
  36 extern int PREFIX(fgetc) (const int *, char *, gfc_charlen_type);
  37 export_proto_np(PREFIX(fgetc));
  38
  39 int
  40 PREFIX(fgetc) (const int * unit, char * c, gfc_charlen_type c_len)
  41 {
  42   int ret;
  43   gfc_unit * u = find_unit (*unit);
  44
  45   if (u == NULL)
  46     return -1;
  47
  48   fbuf_reset (u);
  49   if (u->mode == WRITING)
  50     {
  51       sflush (u->s);
  52       u->mode = READING;
  53     }
  54
  55   memset (c, ' ', c_len);
  56   ret = sread (u->s, c, 1);
  57   unlock_unit (u);
  58
  59   if (ret < 0)
  60     return ret;
  61
  62   if (ret != 1)
  63     return -1;
  64   else
  65     return 0;
  66 }
  67
  68
  69 #define FGETC_SUB(kind) \
  70   extern void fgetc_i ## kind ## _sub \
  71     (const int *, char *, GFC_INTEGER_ ## kind *, gfc_charlen_type); \
  72   export_proto(fgetc_i ## kind ## _sub); \
  73   void fgetc_i ## kind ## _sub \
  74   (const int * unit, char * c, GFC_INTEGER_ ## kind * st, gfc_charlen_type c_len) \
  75     { if (st != NULL) \
  76         *st = PREFIX(fgetc) (unit, c, c_len); \
  77       else \
  78         PREFIX(fgetc) (unit, c, c_len); }
  79
  80 FGETC_SUB(1)
  81 FGETC_SUB(2)
  82 FGETC_SUB(4)
  83 FGETC_SUB(8)
  84
  85
  86 extern int PREFIX(fget) (char *, gfc_charlen_type);
  87 export_proto_np(PREFIX(fget));
  88
  89 int
  90 PREFIX(fget) (char * c, gfc_charlen_type c_len)
  91 {
  92   return PREFIX(fgetc) (&five, c, c_len);
  93 }
  94
  95
  96 #define FGET_SUB(kind) \
  97   extern void fget_i ## kind ## _sub \
  98     (char *, GFC_INTEGER_ ## kind *, gfc_charlen_type); \
  99   export_proto(fget_i ## kind ## _sub); \
 100   void fget_i ## kind ## _sub \
 101   (char * c, GFC_INTEGER_ ## kind * st, gfc_charlen_type c_len) \
 102     { if (st != NULL) \
 103         *st = PREFIX(fgetc) (&five, c, c_len); \
 104       else \
 105         PREFIX(fgetc) (&five, c, c_len); }
 106
 107 FGET_SUB(1)
 108 FGET_SUB(2)
 109 FGET_SUB(4)
 110 FGET_SUB(8)
 111
 112
 113
 114 extern int PREFIX(fputc) (const int *, char *, gfc_charlen_type);
 115 export_proto_np(PREFIX(fputc));
 116
 117 int
 118 PREFIX(fputc) (const int * unit, char * c,
 119                gfc_charlen_type c_len __attribute__((unused)))
 120 {
 121   ssize_t s;
 122   gfc_unit * u = find_unit (*unit);
 123
 124   if (u == NULL)
 125     return -1;
 126
 127   fbuf_reset (u);
 128   if (u->mode == READING)
 129     {
 130       sflush (u->s);
 131       u->mode = WRITING;
 132     }
 133
 134   s = swrite (u->s, c, 1);
 135   unlock_unit (u);
 136   if (s < 0)
 137     return -1;
 138   return 0;
 139 }
 140
 141
 142 #define FPUTC_SUB(kind) \
 143   extern void fputc_i ## kind ## _sub \
 144     (const int *, char *, GFC_INTEGER_ ## kind *, gfc_charlen_type); \
 145   export_proto(fputc_i ## kind ## _sub); \
 146   void fputc_i ## kind ## _sub \
 147   (const int * unit, char * c, GFC_INTEGER_ ## kind * st, gfc_charlen_type c_len) \
 148     { if (st != NULL) \
 149         *st = PREFIX(fputc) (unit, c, c_len); \
 150       else \
 151         PREFIX(fputc) (unit, c, c_len); }
 152
 153 FPUTC_SUB(1)
 154 FPUTC_SUB(2)
 155 FPUTC_SUB(4)
 156 FPUTC_SUB(8)
 157
 158
 159 extern int PREFIX(fput) (char *, gfc_charlen_type);
 160 export_proto_np(PREFIX(fput));
 161
 162 int
 163 PREFIX(fput) (char * c, gfc_charlen_type c_len)
 164 {
 165   return PREFIX(fputc) (&six, c, c_len);
 166 }
 167
 168
 169 #define FPUT_SUB(kind) \
 170   extern void fput_i ## kind ## _sub \
 171     (char *, GFC_INTEGER_ ## kind *, gfc_charlen_type); \
 172   export_proto(fput_i ## kind ## _sub); \
 173   void fput_i ## kind ## _sub \
 174   (char * c, GFC_INTEGER_ ## kind * st, gfc_charlen_type c_len) \
 175     { if (st != NULL) \
 176         *st = PREFIX(fputc) (&six, c, c_len); \
 177       else \
 178         PREFIX(fputc) (&six, c, c_len); }
 179
 180 FPUT_SUB(1)
 181 FPUT_SUB(2)
 182 FPUT_SUB(4)
 183 FPUT_SUB(8)
 184
 185
 186 /* SUBROUTINE FLUSH(UNIT)
 187    INTEGER, INTENT(IN), OPTIONAL :: UNIT  */
 188
 189 extern void flush_i4 (GFC_INTEGER_4 *);
 190 export_proto(flush_i4);
 191
 192 void
 193 flush_i4 (GFC_INTEGER_4 *unit)
 194 {
 195   gfc_unit *us;
 196
 197   /* flush all streams */
 198   if (unit == NULL)
 199     flush_all_units ();
 200   else
 201     {
 202       us = find_unit (*unit);
 203       if (us != NULL)
 204         {
 205           sflush (us->s);
 206           unlock_unit (us);
 207         }
 208     }
 209 }
 210
 211
 212 extern void flush_i8 (GFC_INTEGER_8 *);
 213 export_proto(flush_i8);
 214
 215 void
 216 flush_i8 (GFC_INTEGER_8 *unit)
 217 {
 218   gfc_unit *us;
 219
 220   /* flush all streams */
 221   if (unit == NULL)
 222     flush_all_units ();
 223   else
 224     {
 225       us = find_unit (*unit);
 226       if (us != NULL)
 227         {
 228           sflush (us->s);
 229           unlock_unit (us);
 230         }
 231     }
 232 }
 233
 234 /* FSEEK intrinsic */
 235
 236 extern void fseek_sub (int *, GFC_IO_INT *, int *, int *);
 237 export_proto(fseek_sub);
 238
 239 void
 240 fseek_sub (int * unit, GFC_IO_INT * offset, int * whence, int * status)
 241 {
 242   gfc_unit * u = find_unit (*unit);
 243   ssize_t result = -1;
 244
 245   if (u != NULL)
 246     {
 247       result = sseek(u->s, *offset, *whence);
 248
 249       unlock_unit (u);
 250     }
 251
 252   if (status)
 253     *status = (result < 0 ? -1 : 0);
 254 }
 255
 256
 257
 258 /* FTELL intrinsic */
 259
 260 static gfc_offset
 261 gf_ftell (int unit)
 262 {
 263   gfc_unit * u = find_unit (unit);
 264   if (u == NULL)
 265     return -1;
 266   int pos = fbuf_reset (u);
 267   if (pos != 0)
 268     sseek (u->s, pos, SEEK_CUR);
 269   gfc_offset ret = stell (u->s);
 270   unlock_unit (u);
 271   return ret;
 272 }
 273
 274
 275 /* Here is the ftell function with an incorrect return type; retained
 276    due to ABI compatibility.  */
 277
 278 extern size_t PREFIX(ftell) (int *);
 279 export_proto_np(PREFIX(ftell));
 280
 281 size_t
 282 PREFIX(ftell) (int * unit)
 283 {
 284   return gf_ftell (*unit);
 285 }
 286
 287
 288 /* Here is the ftell function with the correct return type, ensuring
 289    that large files can be supported as long as the target supports
 290    large integers; as of 4.8 the FTELL intrinsic function will call
 291    this one instead of the old ftell above.  */
 292
 293 extern GFC_IO_INT PREFIX(ftell2) (int *);
 294 export_proto_np(PREFIX(ftell2));
 295
 296 GFC_IO_INT
 297 PREFIX(ftell2) (int * unit)
 298 {
 299   return gf_ftell (*unit);
 300 }
 301
 302
 303 #define FTELL_SUB(kind) \
 304   extern void ftell_i ## kind ## _sub (int *, GFC_INTEGER_ ## kind *); \
 305   export_proto(ftell_i ## kind ## _sub); \
 306   void \
 307   ftell_i ## kind ## _sub (int * unit, GFC_INTEGER_ ## kind * offset) \
 308   { \
 309     *offset = gf_ftell (*unit);                 \
 310   }
 311
 312 FTELL_SUB(1)
 313 FTELL_SUB(2)
 314 FTELL_SUB(4)
 315 FTELL_SUB(8)
 316
 317
 318
 319 /* LOGICAL FUNCTION ISATTY(UNIT)
 320    INTEGER, INTENT(IN) :: UNIT */
 321
 322 extern GFC_LOGICAL_4 isatty_l4 (int *);
 323 export_proto(isatty_l4);
 324
 325 GFC_LOGICAL_4
 326 isatty_l4 (int *unit)
 327 {
 328   gfc_unit *u;
 329   GFC_LOGICAL_4 ret = 0;
 330
 331   u = find_unit (*unit);
 332   if (u != NULL)
 333     {
 334       ret = (GFC_LOGICAL_4) stream_isatty (u->s);
 335       unlock_unit (u);
 336     }
 337   return ret;
 338 }
 339
 340
 341 extern GFC_LOGICAL_8 isatty_l8 (int *);
 342 export_proto(isatty_l8);
 343
 344 GFC_LOGICAL_8
 345 isatty_l8 (int *unit)
 346 {
 347   gfc_unit *u;
 348   GFC_LOGICAL_8 ret = 0;
 349
 350   u = find_unit (*unit);
 351   if (u != NULL)
 352     {
 353       ret = (GFC_LOGICAL_8) stream_isatty (u->s);
 354       unlock_unit (u);
 355     }
 356   return ret;
 357 }
 358
 359
 360 /* SUBROUTINE TTYNAM(UNIT,NAME)
 361    INTEGER,SCALAR,INTENT(IN) :: UNIT
 362    CHARACTER,SCALAR,INTENT(OUT) :: NAME */
 363
 364 extern void ttynam_sub (int *, char *, gfc_charlen_type);
 365 export_proto(ttynam_sub);
 366
 367 void
 368 ttynam_sub (int *unit, char * name, gfc_charlen_type name_len)
 369 {
 370   gfc_unit *u;
 371   int nlen;
 372   int err = 1;
 373
 374   u = find_unit (*unit);
 375   if (u != NULL)
 376     {
 377       err = stream_ttyname (u->s, name, name_len);
 378       if (err == 0)
 379         {
 380           nlen = strlen (name);
 381           memset (&name[nlen], ' ', name_len - nlen);
 382         }
 383
 384       unlock_unit (u);
 385     }
 386   if (err != 0)
 387     memset (name, ' ', name_len);
 388 }
 389
 390
 391 extern void ttynam (char **, gfc_charlen_type *, int);
 392 export_proto(ttynam);
 393
 394 void
 395 ttynam (char ** name, gfc_charlen_type * name_len, int unit)
 396 {
 397   gfc_unit *u;
 398
 399   u = find_unit (unit);
 400   if (u != NULL)
 401     {
 402       *name = xmalloc (TTY_NAME_MAX);
 403       int err = stream_ttyname (u->s, *name, TTY_NAME_MAX);
 404       if (err == 0)
 405         {
 406           *name_len = strlen (*name);
 407           unlock_unit (u);
 408           return;
 409         }
 410       free (*name);
 411       unlock_unit (u);
 412     }
 413
 414   *name_len = 0;
 415   *name = NULL;
 416 }