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 Free Software Foundation, Inc.
   4
   5 This file is part of the GNU Fortran 95 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
  28 #ifdef HAVE_STDLIB_H
  29 #include <stdlib.h>
  30 #endif
  31
  32 #include <string.h>
  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 && is_seekable(u->s))
 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 extern size_t PREFIX(ftell) (int *);
 262 export_proto_np(PREFIX(ftell));
 263
 264 size_t
 265 PREFIX(ftell) (int * unit)
 266 {
 267   gfc_unit * u = find_unit (*unit);
 268   size_t ret;
 269   if (u == NULL)
 270     return ((size_t) -1);
 271   ret = (size_t) stell (u->s);
 272   unlock_unit (u);
 273   return ret;
 274 }
 275
 276 #define FTELL_SUB(kind) \
 277   extern void ftell_i ## kind ## _sub (int *, GFC_INTEGER_ ## kind *); \
 278   export_proto(ftell_i ## kind ## _sub); \
 279   void \
 280   ftell_i ## kind ## _sub (int * unit, GFC_INTEGER_ ## kind * offset) \
 281   { \
 282     gfc_unit * u = find_unit (*unit); \
 283     if (u == NULL) \
 284       *offset = -1; \
 285     else \
 286       { \
 287         *offset = stell (u->s); \
 288         unlock_unit (u); \
 289       } \
 290   }
 291
 292 FTELL_SUB(1)
 293 FTELL_SUB(2)
 294 FTELL_SUB(4)
 295 FTELL_SUB(8)
 296
 297
 298
 299 /* LOGICAL FUNCTION ISATTY(UNIT)
 300    INTEGER, INTENT(IN) :: UNIT */
 301
 302 extern GFC_LOGICAL_4 isatty_l4 (int *);
 303 export_proto(isatty_l4);
 304
 305 GFC_LOGICAL_4
 306 isatty_l4 (int *unit)
 307 {
 308   gfc_unit *u;
 309   GFC_LOGICAL_4 ret = 0;
 310
 311   u = find_unit (*unit);
 312   if (u != NULL)
 313     {
 314       ret = (GFC_LOGICAL_4) stream_isatty (u->s);
 315       unlock_unit (u);
 316     }
 317   return ret;
 318 }
 319
 320
 321 extern GFC_LOGICAL_8 isatty_l8 (int *);
 322 export_proto(isatty_l8);
 323
 324 GFC_LOGICAL_8
 325 isatty_l8 (int *unit)
 326 {
 327   gfc_unit *u;
 328   GFC_LOGICAL_8 ret = 0;
 329
 330   u = find_unit (*unit);
 331   if (u != NULL)
 332     {
 333       ret = (GFC_LOGICAL_8) stream_isatty (u->s);
 334       unlock_unit (u);
 335     }
 336   return ret;
 337 }
 338
 339
 340 /* SUBROUTINE TTYNAM(UNIT,NAME)
 341    INTEGER,SCALAR,INTENT(IN) :: UNIT
 342    CHARACTER,SCALAR,INTENT(OUT) :: NAME */
 343
 344 extern void ttynam_sub (int *, char *, gfc_charlen_type);
 345 export_proto(ttynam_sub);
 346
 347 void
 348 ttynam_sub (int *unit, char * name, gfc_charlen_type name_len)
 349 {
 350   gfc_unit *u;
 351   char * n;
 352   int i;
 353
 354   memset (name, ' ', name_len);
 355   u = find_unit (*unit);
 356   if (u != NULL)
 357     {
 358       n = stream_ttyname (u->s);
 359       if (n != NULL)
 360         {
 361           i = 0;
 362           while (*n && i < name_len)
 363             name[i++] = *(n++);
 364         }
 365       unlock_unit (u);
 366     }
 367 }
 368
 369
 370 extern void ttynam (char **, gfc_charlen_type *, int);
 371 export_proto(ttynam);
 372
 373 void
 374 ttynam (char ** name, gfc_charlen_type * name_len, int unit)
 375 {
 376   gfc_unit *u;
 377
 378   u = find_unit (unit);
 379   if (u != NULL)
 380     {
 381       *name = stream_ttyname (u->s);
 382       if (*name != NULL)
 383         {
 384           *name_len = strlen (*name);
 385           *name = strdup (*name);
 386           unlock_unit (u);
 387           return;
 388         }
 389       unlock_unit (u);
 390     }
 391
 392   *name_len = 0;
 393   *name = NULL;
 394 }