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