libgfortran/io/intrinsics.c

   1 /* Implementation of the FGET, FGETC, FPUT, FPUTC, FLUSH
   2    FTELL, TTYNAM and ISATTY intrinsics.
   3    Copyright (C) 2005-2016 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 extern GFC_IO_INT PREFIX(ftell) (int *);
 276 export_proto_np(PREFIX(ftell));
 277
 278 GFC_IO_INT
 279 PREFIX(ftell) (int * unit)
 280 {
 281   return gf_ftell (*unit);
 282 }
 283
 284
 285 #define FTELL_SUB(kind) \
 286   extern void ftell_i ## kind ## _sub (int *, GFC_INTEGER_ ## kind *); \
 287   export_proto(ftell_i ## kind ## _sub); \
 288   void \
 289   ftell_i ## kind ## _sub (int * unit, GFC_INTEGER_ ## kind * offset) \
 290   { \
 291     *offset = gf_ftell (*unit);                 \
 292   }
 293
 294 FTELL_SUB(1)
 295 FTELL_SUB(2)
 296 FTELL_SUB(4)
 297 FTELL_SUB(8)
 298
 299
 300
 301 /* LOGICAL FUNCTION ISATTY(UNIT)
 302    INTEGER, INTENT(IN) :: UNIT */
 303
 304 extern GFC_LOGICAL_4 isatty_l4 (int *);
 305 export_proto(isatty_l4);
 306
 307 GFC_LOGICAL_4
 308 isatty_l4 (int *unit)
 309 {
 310   gfc_unit *u;
 311   GFC_LOGICAL_4 ret = 0;
 312
 313   u = find_unit (*unit);
 314   if (u != NULL)
 315     {
 316       ret = (GFC_LOGICAL_4) stream_isatty (u->s);
 317       unlock_unit (u);
 318     }
 319   return ret;
 320 }
 321
 322
 323 extern GFC_LOGICAL_8 isatty_l8 (int *);
 324 export_proto(isatty_l8);
 325
 326 GFC_LOGICAL_8
 327 isatty_l8 (int *unit)
 328 {
 329   gfc_unit *u;
 330   GFC_LOGICAL_8 ret = 0;
 331
 332   u = find_unit (*unit);
 333   if (u != NULL)
 334     {
 335       ret = (GFC_LOGICAL_8) stream_isatty (u->s);
 336       unlock_unit (u);
 337     }
 338   return ret;
 339 }
 340
 341
 342 /* SUBROUTINE TTYNAM(UNIT,NAME)
 343    INTEGER,SCALAR,INTENT(IN) :: UNIT
 344    CHARACTER,SCALAR,INTENT(OUT) :: NAME */
 345
 346 extern void ttynam_sub (int *, char *, gfc_charlen_type);
 347 export_proto(ttynam_sub);
 348
 349 void
 350 ttynam_sub (int *unit, char * name, gfc_charlen_type name_len)
 351 {
 352   gfc_unit *u;
 353   int nlen;
 354   int err = 1;
 355
 356   u = find_unit (*unit);
 357   if (u != NULL)
 358     {
 359       err = stream_ttyname (u->s, name, name_len);
 360       if (err == 0)
 361         {
 362           nlen = strlen (name);
 363           memset (&name[nlen], ' ', name_len - nlen);
 364         }
 365
 366       unlock_unit (u);
 367     }
 368   if (err != 0)
 369     memset (name, ' ', name_len);
 370 }
 371
 372
 373 extern void ttynam (char **, gfc_charlen_type *, int);
 374 export_proto(ttynam);
 375
 376 void
 377 ttynam (char ** name, gfc_charlen_type * name_len, int unit)
 378 {
 379   gfc_unit *u;
 380
 381   u = find_unit (unit);
 382   if (u != NULL)
 383     {
 384       *name = xmalloc (TTY_NAME_MAX);
 385       int err = stream_ttyname (u->s, *name, TTY_NAME_MAX);
 386       if (err == 0)
 387         {
 388           *name_len = strlen (*name);
 389           unlock_unit (u);
 390           return;
 391         }
 392       free (*name);
 393       unlock_unit (u);
 394     }
 395
 396   *name_len = 0;
 397   *name = NULL;
 398 }