1 /* Implementation of the FGET, FGETC, FPUT, FPUTC, FLUSH
2 FTELL, TTYNAM and ISATTY intrinsics.
3 Copyright (C) 2005-2023 Free Software Foundation, Inc.
4
5 This file is part of the GNU Fortran 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 3 of the License, or (at your option) any later version.
11
12 Libgfortran is distributed in the hope that it will be useful,
13 but WITHOUT ANY WARRANTY; without even the implied warranty of
14 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 GNU General Public License for more details.
16
17 Under Section 7 of GPL version 3, you are granted additional
18 permissions described in the GCC Runtime Library Exception, version
19 3.1, as published by the Free Software Foundation.
20
21 You should have received a copy of the GNU General Public License and
22 a copy of the GCC Runtime Library Exception along with this program;
23 see 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
32 static const int five = 5;
33 static const int six = 6;
34
35 extern int PREFIX(fgetc) (const int *, char *, gfc_charlen_type);
36 export_proto_np(PREFIX(fgetc));
37
38 int
39 PREFIX(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
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 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
152 FPUTC_SUB(1)
153 FPUTC_SUB(2)
154 FPUTC_SUB(4)
155 FPUTC_SUB(8)
156
157
158 extern int PREFIX(fput) (char *, gfc_charlen_type);
159 export_proto_np(PREFIX(fput));
160
161 int
162 PREFIX(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
179 FPUT_SUB(1)
180 FPUT_SUB(2)
181 FPUT_SUB(4)
182 FPUT_SUB(8)
183
184
185 /* SUBROUTINE FLUSH(UNIT)
186 INTEGER, INTENT(IN), OPTIONAL :: UNIT */
187
188 extern void flush_i4 (GFC_INTEGER_4 *);
189 export_proto(flush_i4);
190
191 void
192 flush_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
211 extern void flush_i8 (GFC_INTEGER_8 *);
212 export_proto(flush_i8);
213
214 void
215 flush_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
235 extern void fseek_sub (int *, GFC_IO_INT *, int *, int *);
236 export_proto(fseek_sub);
237
238 void
239 fseek_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
259 static gfc_offset
260 gf_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
274 extern GFC_IO_INT PREFIX(ftell) (int *);
275 export_proto_np(PREFIX(ftell));
276
277 GFC_IO_INT
278 PREFIX(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
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 = 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 }