1/* Implementation of the FGET, FGETC, FPUT, FPUTC, FLUSH 2 FTELL, TTYNAM and ISATTY intrinsics. 3 Copyright (C) 2005-2020 Free Software Foundation, Inc. 4 5This file is part of the GNU Fortran runtime library (libgfortran). 6 7Libgfortran is free software; you can redistribute it and/or 8modify it under the terms of the GNU General Public 9License as published by the Free Software Foundation; either 10version 3 of the License, or (at your option) any later version. 11 12Libgfortran is distributed in the hope that it will be useful, 13but WITHOUT ANY WARRANTY; without even the implied warranty of 14MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 15GNU General Public License for more details. 16 17Under Section 7 of GPL version 3, you are granted additional 18permissions described in the GCC Runtime Library Exception, version 193.1, as published by the Free Software Foundation. 20 21You should have received a copy of the GNU General Public License and 22a copy of the GCC Runtime Library Exception along with this program; 23see the files COPYING3 and COPYING.RUNTIME respectively. If not, see 24<http://www.gnu.org/licenses/>. */ 25 26#include "io.h" 27#include "fbuf.h" 28#include "unix.h" 29#include <string.h> 30 31 32static const int five = 5; 33static const int six = 6; 34 35extern int PREFIX(fgetc) (const int *, char *, gfc_charlen_type); 36export_proto_np(PREFIX(fgetc)); 37 38int 39PREFIX(fgetc) (const int *unit, char *c, gfc_charlen_type c_len) 40{ 41 int ret; 42 gfc_unit *u = find_unit (*unit); 43 44 if (u == NULL) 45 return -1; 46 47 fbuf_reset (u); 48 if (u->mode == WRITING) 49 { 50 sflush (u->s); 51 u->mode = READING; 52 } 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 79FGETC_SUB(1) 80FGETC_SUB(2) 81FGETC_SUB(4) 82FGETC_SUB(8) 83 84 85extern int PREFIX(fget) (char *, gfc_charlen_type); 86export_proto_np(PREFIX(fget)); 87 88int 89PREFIX(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 106FGET_SUB(1) 107FGET_SUB(2) 108FGET_SUB(4) 109FGET_SUB(8) 110 111 112 113extern int PREFIX(fputc) (const int *, char *, gfc_charlen_type); 114export_proto_np(PREFIX(fputc)); 115 116int 117PREFIX(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 fbuf_reset (u); 127 if (u->mode == READING) 128 { 129 sflush (u->s); 130 u->mode = WRITING; 131 } 132 133 s = swrite (u->s, c, 1); 134 unlock_unit (u); 135 if (s < 0) 136 return -1; 137 return 0; 138} 139 140 141#define FPUTC_SUB(kind) \ 142 extern void fputc_i ## kind ## _sub \ 143 (const int *, char *, GFC_INTEGER_ ## kind *, gfc_charlen_type); \ 144 export_proto(fputc_i ## kind ## _sub); \ 145 void fputc_i ## kind ## _sub \ 146 (const int *unit, char *c, GFC_INTEGER_ ## kind *st, gfc_charlen_type c_len) \ 147 { if (st != NULL) \ 148 *st = PREFIX(fputc) (unit, c, c_len); \ 149 else \ 150 PREFIX(fputc) (unit, c, c_len); } 151 152FPUTC_SUB(1) 153FPUTC_SUB(2) 154FPUTC_SUB(4) 155FPUTC_SUB(8) 156 157 158extern int PREFIX(fput) (char *, gfc_charlen_type); 159export_proto_np(PREFIX(fput)); 160 161int 162PREFIX(fput) (char *c, gfc_charlen_type c_len) 163{ 164 return PREFIX(fputc) (&six, c, c_len); 165} 166 167 168#define FPUT_SUB(kind) \ 169 extern void fput_i ## kind ## _sub \ 170 (char *, GFC_INTEGER_ ## kind *, gfc_charlen_type); \ 171 export_proto(fput_i ## kind ## _sub); \ 172 void fput_i ## kind ## _sub \ 173 (char *c, GFC_INTEGER_ ## kind *st, gfc_charlen_type c_len) \ 174 { if (st != NULL) \ 175 *st = PREFIX(fputc) (&six, c, c_len); \ 176 else \ 177 PREFIX(fputc) (&six, c, c_len); } 178 179FPUT_SUB(1) 180FPUT_SUB(2) 181FPUT_SUB(4) 182FPUT_SUB(8) 183 184 185/* SUBROUTINE FLUSH(UNIT) 186 INTEGER, INTENT(IN), OPTIONAL :: UNIT */ 187 188extern void flush_i4 (GFC_INTEGER_4 *); 189export_proto(flush_i4); 190 191void 192flush_i4 (GFC_INTEGER_4 *unit) 193{ 194 gfc_unit *us; 195 196 /* flush all streams */ 197 if (unit == NULL) 198 flush_all_units (); 199 else 200 { 201 us = find_unit (*unit); 202 if (us != NULL) 203 { 204 sflush (us->s); 205 unlock_unit (us); 206 } 207 } 208} 209 210 211extern void flush_i8 (GFC_INTEGER_8 *); 212export_proto(flush_i8); 213 214void 215flush_i8 (GFC_INTEGER_8 *unit) 216{ 217 gfc_unit *us; 218 219 /* flush all streams */ 220 if (unit == NULL) 221 flush_all_units (); 222 else 223 { 224 us = find_unit (*unit); 225 if (us != NULL) 226 { 227 sflush (us->s); 228 unlock_unit (us); 229 } 230 } 231} 232 233/* FSEEK intrinsic */ 234 235extern void fseek_sub (int *, GFC_IO_INT *, int *, int *); 236export_proto(fseek_sub); 237 238void 239fseek_sub (int *unit, GFC_IO_INT *offset, int *whence, int *status) 240{ 241 gfc_unit *u = find_unit (*unit); 242 ssize_t result = -1; 243 244 if (u != NULL) 245 { 246 result = sseek(u->s, *offset, *whence); 247 248 unlock_unit (u); 249 } 250 251 if (status) 252 *status = (result < 0 ? -1 : 0); 253} 254 255 256 257/* FTELL intrinsic */ 258 259static gfc_offset 260gf_ftell (int unit) 261{ 262 gfc_unit *u = find_unit (unit); 263 if (u == NULL) 264 return -1; 265 int pos = fbuf_reset (u); 266 if (pos != 0) 267 sseek (u->s, pos, SEEK_CUR); 268 gfc_offset ret = stell (u->s); 269 unlock_unit (u); 270 return ret; 271} 272 273 274extern GFC_IO_INT PREFIX(ftell) (int *); 275export_proto_np(PREFIX(ftell)); 276 277GFC_IO_INT 278PREFIX(ftell) (int *unit) 279{ 280 return gf_ftell (*unit); 281} 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 293FTELL_SUB(1) 294FTELL_SUB(2) 295FTELL_SUB(4) 296FTELL_SUB(8) 297 298 299 300/* LOGICAL FUNCTION ISATTY(UNIT) 301 INTEGER, INTENT(IN) :: UNIT */ 302 303extern GFC_LOGICAL_4 isatty_l4 (int *); 304export_proto(isatty_l4); 305 306GFC_LOGICAL_4 307isatty_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 322extern GFC_LOGICAL_8 isatty_l8 (int *); 323export_proto(isatty_l8); 324 325GFC_LOGICAL_8 326isatty_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 345extern void ttynam_sub (int *, char *, gfc_charlen_type); 346export_proto(ttynam_sub); 347 348void 349ttynam_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 372extern void ttynam (char **, gfc_charlen_type *, int); 373export_proto(ttynam); 374 375void 376ttynam (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 = xmalloc (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} 398