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