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 /* FSEEK intrinsic */
 232
 233 extern void fseek_sub (int *, GFC_IO_INT *, int *, int *);
 234 export_proto(fseek_sub);
 235
 236 void
 237 fseek_sub (int * unit, GFC_IO_INT * offset, int * whence, int * status)
 238 {
 239   gfc_unit * u = find_unit (*unit);
 240   try result = FAILURE;
 241
 242   if (u != NULL && is_seekable(u->s))
 243     {
 244       if (*whence == 0)
 245         result = sseek(u->s, *offset);                       /* SEEK_SET */
 246       else if (*whence == 1)
 247         result = sseek(u->s, file_position(u->s) + *offset); /* SEEK_CUR */
 248       else if (*whence == 2)
 249         result = sseek(u->s, file_length(u->s) + *offset);   /* SEEK_END */
 250
 251       unlock_unit (u);
 252     }
 253
 254   if (status)
 255     *status = (result == FAILURE ? -1 : 0);
 256 }
 257
 258
 259
 260 /* FTELL intrinsic */
 261
 262 extern size_t PREFIX(ftell) (int *);
 263 export_proto_np(PREFIX(ftell));
 264
 265 size_t
 266 PREFIX(ftell) (int * unit)
 267 {
 268   gfc_unit * u = find_unit (*unit);
 269   size_t ret;
 270   if (u == NULL)
 271     return ((size_t) -1);
 272   ret = (size_t) stream_offset (u->s);
 273   unlock_unit (u);
 274   return ret;
 275 }
 276
 277 #define FTELL_SUB(kind) \
 278   extern void ftell_i ## kind ## _sub (int *, GFC_INTEGER_ ## kind *); \
 279   export_proto(ftell_i ## kind ## _sub); \
 280   void \
 281   ftell_i ## kind ## _sub (int * unit, GFC_INTEGER_ ## kind * offset) \
 282   { \
 283     gfc_unit * u = find_unit (*unit); \
 284     if (u == NULL) \
 285       *offset = -1; \
 286     else \
 287       { \
 288         *offset = stream_offset (u->s); \
 289         unlock_unit (u); \
 290       } \
 291   }
 292
 293 FTELL_SUB(1)
 294 FTELL_SUB(2)
 295 FTELL_SUB(4)
 296 FTELL_SUB(8)
 297
 298
 299
 300 /* LOGICAL FUNCTION ISATTY(UNIT)
 301    INTEGER, INTENT(IN) :: UNIT */
 302
 303 extern GFC_LOGICAL_4 isatty_l4 (int *);
 304 export_proto(isatty_l4);
 305
 306 GFC_LOGICAL_4
 307 isatty_l4 (int *unit)
 308 {
 309   gfc_unit *u;
 310   GFC_LOGICAL_4 ret = 0;
 311
 312   u = find_unit (*unit);
 313   if (u != NULL)
 314     {
 315       ret = (GFC_LOGICAL_4) stream_isatty (u->s);
 316       unlock_unit (u);
 317     }
 318   return ret;
 319 }
 320
 321
 322 extern GFC_LOGICAL_8 isatty_l8 (int *);
 323 export_proto(isatty_l8);
 324
 325 GFC_LOGICAL_8
 326 isatty_l8 (int *unit)
 327 {
 328   gfc_unit *u;
 329   GFC_LOGICAL_8 ret = 0;
 330
 331   u = find_unit (*unit);
 332   if (u != NULL)
 333     {
 334       ret = (GFC_LOGICAL_8) stream_isatty (u->s);
 335       unlock_unit (u);
 336     }
 337   return ret;
 338 }
 339
 340
 341 /* SUBROUTINE TTYNAM(UNIT,NAME)
 342    INTEGER,SCALAR,INTENT(IN) :: UNIT
 343    CHARACTER,SCALAR,INTENT(OUT) :: NAME */
 344
 345 extern void ttynam_sub (int *, char *, gfc_charlen_type);
 346 export_proto(ttynam_sub);
 347
 348 void
 349 ttynam_sub (int *unit, char * name, gfc_charlen_type name_len)
 350 {
 351   gfc_unit *u;
 352   char * n;
 353   int i;
 354
 355   memset (name, ' ', name_len);
 356   u = find_unit (*unit);
 357   if (u != NULL)
 358     {
 359       n = stream_ttyname (u->s);
 360       if (n != NULL)
 361         {
 362           i = 0;
 363           while (*n && i < name_len)
 364             name[i++] = *(n++);
 365         }
 366       unlock_unit (u);
 367     }
 368 }
 369
 370
 371 extern void ttynam (char **, gfc_charlen_type *, int);
 372 export_proto(ttynam);
 373
 374 void
 375 ttynam (char ** name, gfc_charlen_type * name_len, int unit)
 376 {
 377   gfc_unit *u;
 378
 379   u = find_unit (unit);
 380   if (u != NULL)
 381     {
 382       *name = stream_ttyname (u->s);
 383       if (*name != NULL)
 384         {
 385           *name_len = strlen (*name);
 386           *name = strdup (*name);
 387           unlock_unit (u);
 388           return;
 389         }
 390       unlock_unit (u);
 391     }
 392
 393   *name_len = 0;
 394   *name = NULL;
 395 }