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 #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 extern size_t PREFIX(ftell) (int *);
 264 export_proto_np(PREFIX(ftell));
 265
 266 size_t
 267 PREFIX(ftell) (int * unit)
 268 {
 269   gfc_unit * u = find_unit (*unit);
 270   size_t ret;
 271   if (u == NULL)
 272     return ((size_t) -1);
 273   ret = (size_t) stell (u->s);
 274   unlock_unit (u);
 275   return ret;
 276 }
 277
 278 #define FTELL_SUB(kind) \
 279   extern void ftell_i ## kind ## _sub (int *, GFC_INTEGER_ ## kind *); \
 280   export_proto(ftell_i ## kind ## _sub); \
 281   void \
 282   ftell_i ## kind ## _sub (int * unit, GFC_INTEGER_ ## kind * offset) \
 283   { \
 284     gfc_unit * u = find_unit (*unit); \
 285     if (u == NULL) \
 286       *offset = -1; \
 287     else \
 288       { \
 289         *offset = stell (u->s); \
 290         unlock_unit (u); \
 291       } \
 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   char * n;
 354   int i;
 355
 356   memset (name, ' ', name_len);
 357   u = find_unit (*unit);
 358   if (u != NULL)
 359     {
 360       n = stream_ttyname (u->s);
 361       if (n != NULL)
 362         {
 363           i = 0;
 364           while (*n && i < name_len)
 365             name[i++] = *(n++);
 366         }
 367       unlock_unit (u);
 368     }
 369 }
 370
 371
 372 extern void ttynam (char **, gfc_charlen_type *, int);
 373 export_proto(ttynam);
 374
 375 void
 376 ttynam (char ** name, gfc_charlen_type * name_len, int unit)
 377 {
 378   gfc_unit *u;
 379
 380   u = find_unit (unit);
 381   if (u != NULL)
 382     {
 383       *name = stream_ttyname (u->s);
 384       if (*name != NULL)
 385         {
 386           *name_len = strlen (*name);
 387           *name = strdup (*name);
 388           unlock_unit (u);
 389           return;
 390         }
 391       unlock_unit (u);
 392     }
 393
 394   *name_len = 0;
 395   *name = NULL;
 396 }