libgfortran/io/intrinsics.c

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