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