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