libgfortran/io/intrinsics.c

   1 /* Implementation of the FGET, FGETC, FPUT, FPUTC, FLUSH
   2    FTELL, TTYNAM and ISATTY intrinsics.
   3    Copyright (C) 2005, 2007 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 2 of the License, or (at your option) any later version.
  11
  12 In addition to the permissions in the GNU General Public License, the
  13 Free Software Foundation gives you unlimited permission to link the
  14 compiled version of this file into combinations with other programs,
  15 and to distribute those combinations without any restriction coming
  16 from the use of this file.  (The General Public License restrictions
  17 do apply in other respects; for example, they cover modification of
  18 the file, and distribution when not linked into a combine
  19 executable.)
  20
  21 Libgfortran is distributed in the hope that it will be useful,
  22 but WITHOUT ANY WARRANTY; without even the implied warranty of
  23 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  24 GNU General Public License for more details.
  25
  26 You should have received a copy of the GNU General Public
  27 License along with libgfortran; see the file COPYING.  If not,
  28 write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
  29 Boston, MA 02110-1301, USA.  */
  30
  31 #include "config.h"
  32 #include "libgfortran.h"
  33
  34 #ifdef HAVE_STDLIB_H
  35 #include <stdlib.h>
  36 #endif
  37
  38 #include <string.h>
  39
  40 #include "io.h"
  41
  42 static const int five = 5;
  43 static const int six = 6;
  44
  45 extern int PREFIX(fgetc) (const int *, char *, gfc_charlen_type);
  46 export_proto_np(PREFIX(fgetc));
  47
  48 int
  49 PREFIX(fgetc) (const int * unit, char * c, gfc_charlen_type c_len)
  50 {
  51   int ret;
  52   size_t s;
  53   gfc_unit * u = find_unit (*unit);
  54
  55   if (u == NULL)
  56     return -1;
  57
  58   s = 1;
  59   memset (c, ' ', c_len);
  60   ret = sread (u->s, c, &s);
  61   unlock_unit (u);
  62
  63   if (ret != 0)
  64     return ret;
  65
  66   if (s != 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   size_t s;
 126   int ret;
 127   gfc_unit * u = find_unit (*unit);
 128
 129   if (u == NULL)
 130     return -1;
 131
 132   s = 1;
 133   ret = swrite (u->s, c, &s);
 134   unlock_unit (u);
 135   return ret;
 136 }
 137
 138
 139 #define FPUTC_SUB(kind) \
 140   extern void fputc_i ## kind ## _sub \
 141     (const int *, char *, GFC_INTEGER_ ## kind *, gfc_charlen_type); \
 142   export_proto(fputc_i ## kind ## _sub); \
 143   void fputc_i ## kind ## _sub \
 144   (const int * unit, char * c, GFC_INTEGER_ ## kind * st, gfc_charlen_type c_len) \
 145     { if (st != NULL) \
 146         *st = PREFIX(fputc) (unit, c, c_len); \
 147       else \
 148         PREFIX(fputc) (unit, c, c_len); }
 149
 150 FPUTC_SUB(1)
 151 FPUTC_SUB(2)
 152 FPUTC_SUB(4)
 153 FPUTC_SUB(8)
 154
 155
 156 extern int PREFIX(fput) (char *, gfc_charlen_type);
 157 export_proto_np(PREFIX(fput));
 158
 159 int
 160 PREFIX(fput) (char * c, gfc_charlen_type c_len)
 161 {
 162   return PREFIX(fputc) (&six, c, c_len);
 163 }
 164
 165
 166 #define FPUT_SUB(kind) \
 167   extern void fput_i ## kind ## _sub \
 168     (char *, GFC_INTEGER_ ## kind *, gfc_charlen_type); \
 169   export_proto(fput_i ## kind ## _sub); \
 170   void fput_i ## kind ## _sub \
 171   (char * c, GFC_INTEGER_ ## kind * st, gfc_charlen_type c_len) \
 172     { if (st != NULL) \
 173         *st = PREFIX(fputc) (&six, c, c_len); \
 174       else \
 175         PREFIX(fputc) (&six, c, c_len); }
 176
 177 FPUT_SUB(1)
 178 FPUT_SUB(2)
 179 FPUT_SUB(4)
 180 FPUT_SUB(8)
 181
 182
 183 /* SUBROUTINE FLUSH(UNIT)
 184    INTEGER, INTENT(IN), OPTIONAL :: UNIT  */
 185
 186 extern void flush_i4 (GFC_INTEGER_4 *);
 187 export_proto(flush_i4);
 188
 189 void
 190 flush_i4 (GFC_INTEGER_4 *unit)
 191 {
 192   gfc_unit *us;
 193
 194   /* flush all streams */
 195   if (unit == NULL)
 196     flush_all_units ();
 197   else
 198     {
 199       us = find_unit (*unit);
 200       if (us != NULL)
 201         {
 202           flush (us->s);
 203           unlock_unit (us);
 204         }
 205     }
 206 }
 207
 208
 209 extern void flush_i8 (GFC_INTEGER_8 *);
 210 export_proto(flush_i8);
 211
 212 void
 213 flush_i8 (GFC_INTEGER_8 *unit)
 214 {
 215   gfc_unit *us;
 216
 217   /* flush all streams */
 218   if (unit == NULL)
 219     flush_all_units ();
 220   else
 221     {
 222       us = find_unit (*unit);
 223       if (us != NULL)
 224         {
 225           flush (us->s);
 226           unlock_unit (us);
 227         }
 228     }
 229 }
 230
 231
 232 /* FTELL intrinsic */
 233
 234 extern size_t PREFIX(ftell) (int *);
 235 export_proto_np(PREFIX(ftell));
 236
 237 size_t
 238 PREFIX(ftell) (int * unit)
 239 {
 240   gfc_unit * u = find_unit (*unit);
 241   size_t ret;
 242   if (u == NULL)
 243     return ((size_t) -1);
 244   ret = (size_t) stream_offset (u->s);
 245   unlock_unit (u);
 246   return ret;
 247 }
 248
 249 #define FTELL_SUB(kind) \
 250   extern void ftell_i ## kind ## _sub (int *, GFC_INTEGER_ ## kind *); \
 251   export_proto(ftell_i ## kind ## _sub); \
 252   void \
 253   ftell_i ## kind ## _sub (int * unit, GFC_INTEGER_ ## kind * offset) \
 254   { \
 255     gfc_unit * u = find_unit (*unit); \
 256     if (u == NULL) \
 257       *offset = -1; \
 258     else \
 259       { \
 260         *offset = stream_offset (u->s); \
 261         unlock_unit (u); \
 262       } \
 263   }
 264
 265 FTELL_SUB(1)
 266 FTELL_SUB(2)
 267 FTELL_SUB(4)
 268 FTELL_SUB(8)
 269
 270
 271
 272 /* LOGICAL FUNCTION ISATTY(UNIT)
 273    INTEGER, INTENT(IN) :: UNIT */
 274
 275 extern GFC_LOGICAL_4 isatty_l4 (int *);
 276 export_proto(isatty_l4);
 277
 278 GFC_LOGICAL_4
 279 isatty_l4 (int *unit)
 280 {
 281   gfc_unit *u;
 282   GFC_LOGICAL_4 ret = 0;
 283
 284   u = find_unit (*unit);
 285   if (u != NULL)
 286     {
 287       ret = (GFC_LOGICAL_4) stream_isatty (u->s);
 288       unlock_unit (u);
 289     }
 290   return ret;
 291 }
 292
 293
 294 extern GFC_LOGICAL_8 isatty_l8 (int *);
 295 export_proto(isatty_l8);
 296
 297 GFC_LOGICAL_8
 298 isatty_l8 (int *unit)
 299 {
 300   gfc_unit *u;
 301   GFC_LOGICAL_8 ret = 0;
 302
 303   u = find_unit (*unit);
 304   if (u != NULL)
 305     {
 306       ret = (GFC_LOGICAL_8) stream_isatty (u->s);
 307       unlock_unit (u);
 308     }
 309   return ret;
 310 }
 311
 312
 313 /* SUBROUTINE TTYNAM(UNIT,NAME)
 314    INTEGER,SCALAR,INTENT(IN) :: UNIT
 315    CHARACTER,SCALAR,INTENT(OUT) :: NAME */
 316
 317 extern void ttynam_sub (int *, char *, gfc_charlen_type);
 318 export_proto(ttynam_sub);
 319
 320 void
 321 ttynam_sub (int *unit, char * name, gfc_charlen_type name_len)
 322 {
 323   gfc_unit *u;
 324   char * n;
 325   int i;
 326
 327   memset (name, ' ', name_len);
 328   u = find_unit (*unit);
 329   if (u != NULL)
 330     {
 331       n = stream_ttyname (u->s);
 332       if (n != NULL)
 333         {
 334           i = 0;
 335           while (*n && i < name_len)
 336             name[i++] = *(n++);
 337         }
 338       unlock_unit (u);
 339     }
 340 }
 341
 342
 343 extern void ttynam (char **, gfc_charlen_type *, int);
 344 export_proto(ttynam);
 345
 346 void
 347 ttynam (char ** name, gfc_charlen_type * name_len, int unit)
 348 {
 349   gfc_unit *u;
 350
 351   u = find_unit (unit);
 352   if (u != NULL)
 353     {
 354       *name = stream_ttyname (u->s);
 355       if (*name != NULL)
 356         {
 357           *name_len = strlen (*name);
 358           *name = strdup (*name);
 359           unlock_unit (u);
 360           return;
 361         }
 362       unlock_unit (u);
 363     }
 364
 365   *name_len = 0;
 366   *name = NULL;
 367 }