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