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