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