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, 2010, 2011 Free Software
   4    Foundation, Inc.
   5
   6 This file is part of the GNU Fortran runtime library (libgfortran).
   7
   8 Libgfortran is free software; you can redistribute it and/or
   9 modify it under the terms of the GNU General Public
  10 License as published by the Free Software Foundation; either
  11 version 3 of the License, or (at your option) any later version.
  12
  13 Libgfortran is distributed in the hope that it will be useful,
  14 but WITHOUT ANY WARRANTY; without even the implied warranty of
  15 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  16 GNU General Public License for more details.
  17
  18 Under Section 7 of GPL version 3, you are granted additional
  19 permissions described in the GCC Runtime Library Exception, version
  20 3.1, as published by the Free Software Foundation.
  21
  22 You should have received a copy of the GNU General Public License and
  23 a copy of the GCC Runtime Library Exception along with this program;
  24 see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see
  25 <http://www.gnu.org/licenses/>.  */
  26
  27 #include "io.h"
  28 #include "fbuf.h"
  29 #include "unix.h"
  30 #include <stdlib.h>
  31 #include <string.h>
  32
  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   fbuf_reset (u);
  50   if (u->mode == WRITING)
  51     {
  52       sflush (u->s);
  53       u->mode = READING;
  54     }
  55
  56   memset (c, ' ', c_len);
  57   ret = sread (u->s, c, 1);
  58   unlock_unit (u);
  59
  60   if (ret < 0)
  61     return ret;
  62
  63   if (ret != 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   ssize_t s;
 123   gfc_unit * u = find_unit (*unit);
 124
 125   if (u == NULL)
 126     return -1;
 127
 128   fbuf_reset (u);
 129   if (u->mode == READING)
 130     {
 131       sflush (u->s);
 132       u->mode = WRITING;
 133     }
 134
 135   s = swrite (u->s, c, 1);
 136   unlock_unit (u);
 137   if (s < 0)
 138     return -1;
 139   return 0;
 140 }
 141
 142
 143 #define FPUTC_SUB(kind) \
 144   extern void fputc_i ## kind ## _sub \
 145     (const int *, char *, GFC_INTEGER_ ## kind *, gfc_charlen_type); \
 146   export_proto(fputc_i ## kind ## _sub); \
 147   void fputc_i ## kind ## _sub \
 148   (const int * unit, char * c, GFC_INTEGER_ ## kind * st, gfc_charlen_type c_len) \
 149     { if (st != NULL) \
 150         *st = PREFIX(fputc) (unit, c, c_len); \
 151       else \
 152         PREFIX(fputc) (unit, c, c_len); }
 153
 154 FPUTC_SUB(1)
 155 FPUTC_SUB(2)
 156 FPUTC_SUB(4)
 157 FPUTC_SUB(8)
 158
 159
 160 extern int PREFIX(fput) (char *, gfc_charlen_type);
 161 export_proto_np(PREFIX(fput));
 162
 163 int
 164 PREFIX(fput) (char * c, gfc_charlen_type c_len)
 165 {
 166   return PREFIX(fputc) (&six, c, c_len);
 167 }
 168
 169
 170 #define FPUT_SUB(kind) \
 171   extern void fput_i ## kind ## _sub \
 172     (char *, GFC_INTEGER_ ## kind *, gfc_charlen_type); \
 173   export_proto(fput_i ## kind ## _sub); \
 174   void fput_i ## kind ## _sub \
 175   (char * c, GFC_INTEGER_ ## kind * st, gfc_charlen_type c_len) \
 176     { if (st != NULL) \
 177         *st = PREFIX(fputc) (&six, c, c_len); \
 178       else \
 179         PREFIX(fputc) (&six, c, c_len); }
 180
 181 FPUT_SUB(1)
 182 FPUT_SUB(2)
 183 FPUT_SUB(4)
 184 FPUT_SUB(8)
 185
 186
 187 /* SUBROUTINE FLUSH(UNIT)
 188    INTEGER, INTENT(IN), OPTIONAL :: UNIT  */
 189
 190 extern void flush_i4 (GFC_INTEGER_4 *);
 191 export_proto(flush_i4);
 192
 193 void
 194 flush_i4 (GFC_INTEGER_4 *unit)
 195 {
 196   gfc_unit *us;
 197
 198   /* flush all streams */
 199   if (unit == NULL)
 200     flush_all_units ();
 201   else
 202     {
 203       us = find_unit (*unit);
 204       if (us != NULL)
 205         {
 206           sflush (us->s);
 207           unlock_unit (us);
 208         }
 209     }
 210 }
 211
 212
 213 extern void flush_i8 (GFC_INTEGER_8 *);
 214 export_proto(flush_i8);
 215
 216 void
 217 flush_i8 (GFC_INTEGER_8 *unit)
 218 {
 219   gfc_unit *us;
 220
 221   /* flush all streams */
 222   if (unit == NULL)
 223     flush_all_units ();
 224   else
 225     {
 226       us = find_unit (*unit);
 227       if (us != NULL)
 228         {
 229           sflush (us->s);
 230           unlock_unit (us);
 231         }
 232     }
 233 }
 234
 235 /* FSEEK intrinsic */
 236
 237 extern void fseek_sub (int *, GFC_IO_INT *, int *, int *);
 238 export_proto(fseek_sub);
 239
 240 void
 241 fseek_sub (int * unit, GFC_IO_INT * offset, int * whence, int * status)
 242 {
 243   gfc_unit * u = find_unit (*unit);
 244   ssize_t result = -1;
 245
 246   if (u != NULL)
 247     {
 248       result = sseek(u->s, *offset, *whence);
 249
 250       unlock_unit (u);
 251     }
 252
 253   if (status)
 254     *status = (result < 0 ? -1 : 0);
 255 }
 256
 257
 258
 259 /* FTELL intrinsic */
 260
 261 static gfc_offset
 262 gf_ftell (int unit)
 263 {
 264   gfc_unit * u = find_unit (unit);
 265   if (u == NULL)
 266     return -1;
 267   int pos = fbuf_reset (u);
 268   if (pos != 0)
 269     sseek (u->s, pos, SEEK_CUR);
 270   gfc_offset ret = stell (u->s);
 271   unlock_unit (u);
 272   return ret;
 273 }
 274
 275 extern size_t PREFIX(ftell) (int *);
 276 export_proto_np(PREFIX(ftell));
 277
 278 size_t
 279 PREFIX(ftell) (int * unit)
 280 {
 281   return gf_ftell (*unit);
 282 }
 283
 284 #define FTELL_SUB(kind) \
 285   extern void ftell_i ## kind ## _sub (int *, GFC_INTEGER_ ## kind *); \
 286   export_proto(ftell_i ## kind ## _sub); \
 287   void \
 288   ftell_i ## kind ## _sub (int * unit, GFC_INTEGER_ ## kind * offset) \
 289   { \
 290     *offset = gf_ftell (*unit);                 \
 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   int nlen;
 353   int err = 1;
 354
 355   u = find_unit (*unit);
 356   if (u != NULL)
 357     {
 358       err = stream_ttyname (u->s, name, name_len);
 359       if (err == 0)
 360         {
 361           nlen = strlen (name);
 362           memset (&name[nlen], ' ', name_len - nlen);
 363         }
 364
 365       unlock_unit (u);
 366     }
 367   if (err != 0)
 368     memset (name, ' ', name_len);
 369 }
 370
 371
 372 extern void ttynam (char **, gfc_charlen_type *, int);
 373 export_proto(ttynam);
 374
 375 void
 376 ttynam (char ** name, gfc_charlen_type * name_len, int unit)
 377 {
 378   gfc_unit *u;
 379
 380   u = find_unit (unit);
 381   if (u != NULL)
 382     {
 383       *name = get_mem (TTY_NAME_MAX);
 384       int err = stream_ttyname (u->s, *name, TTY_NAME_MAX);
 385       if (err == 0)
 386         {
 387           *name_len = strlen (*name);
 388           unlock_unit (u);
 389           return;
 390         }
 391       free (*name);
 392       unlock_unit (u);
 393     }
 394
 395   *name_len = 0;
 396   *name = NULL;
 397 }