1 /* Implementation of the FGET, FGETC, FPUT, FPUTC, FLUSH
2 FTELL, TTYNAM and ISATTY intrinsics.
3 Copyright (C) 2005-2016 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 <stdlib.h>
30 #include <string.h>
31
32
33 static const int five = 5;
34 static const int six = 6;
35
36 extern int PREFIX(fgetc) (const int *, char *, gfc_charlen_type);
37 export_proto_np(PREFIX(fgetc));
38
39 int
PREFIX(fgetc)40 PREFIX(fgetc) (const int * unit, char * c, gfc_charlen_type c_len)
41 {
42 int ret;
43 gfc_unit * u = find_unit (*unit);
44
45 if (u == NULL)
46 return -1;
47
48 fbuf_reset (u);
49 if (u->mode == WRITING)
50 {
51 sflush (u->s);
52 u->mode = READING;
53 }
54
55 memset (c, ' ', c_len);
56 ret = sread (u->s, c, 1);
57 unlock_unit (u);
58
59 if (ret < 0)
60 return ret;
61
62 if (ret != 1)
63 return -1;
64 else
65 return 0;
66 }
67
68
69 #define FGETC_SUB(kind) \
70 extern void fgetc_i ## kind ## _sub \
71 (const int *, char *, GFC_INTEGER_ ## kind *, gfc_charlen_type); \
72 export_proto(fgetc_i ## kind ## _sub); \
73 void fgetc_i ## kind ## _sub \
74 (const int * unit, char * c, GFC_INTEGER_ ## kind * st, gfc_charlen_type c_len) \
75 { if (st != NULL) \
76 *st = PREFIX(fgetc) (unit, c, c_len); \
77 else \
78 PREFIX(fgetc) (unit, c, c_len); }
79
80 FGETC_SUB(1)
81 FGETC_SUB(2)
82 FGETC_SUB(4)
83 FGETC_SUB(8)
84
85
86 extern int PREFIX(fget) (char *, gfc_charlen_type);
87 export_proto_np(PREFIX(fget));
88
89 int
PREFIX(fget)90 PREFIX(fget) (char * c, gfc_charlen_type c_len)
91 {
92 return PREFIX(fgetc) (&five, c, c_len);
93 }
94
95
96 #define FGET_SUB(kind) \
97 extern void fget_i ## kind ## _sub \
98 (char *, GFC_INTEGER_ ## kind *, gfc_charlen_type); \
99 export_proto(fget_i ## kind ## _sub); \
100 void fget_i ## kind ## _sub \
101 (char * c, GFC_INTEGER_ ## kind * st, gfc_charlen_type c_len) \
102 { if (st != NULL) \
103 *st = PREFIX(fgetc) (&five, c, c_len); \
104 else \
105 PREFIX(fgetc) (&five, c, c_len); }
106
107 FGET_SUB(1)
108 FGET_SUB(2)
109 FGET_SUB(4)
110 FGET_SUB(8)
111
112
113
114 extern int PREFIX(fputc) (const int *, char *, gfc_charlen_type);
115 export_proto_np(PREFIX(fputc));
116
117 int
PREFIX(fputc)118 PREFIX(fputc) (const int * unit, char * c,
119 gfc_charlen_type c_len __attribute__((unused)))
120 {
121 ssize_t s;
122 gfc_unit * u = find_unit (*unit);
123
124 if (u == NULL)
125 return -1;
126
127 fbuf_reset (u);
128 if (u->mode == READING)
129 {
130 sflush (u->s);
131 u->mode = WRITING;
132 }
133
134 s = swrite (u->s, c, 1);
135 unlock_unit (u);
136 if (s < 0)
137 return -1;
138 return 0;
139 }
140
141
142 #define FPUTC_SUB(kind) \
143 extern void fputc_i ## kind ## _sub \
144 (const int *, char *, GFC_INTEGER_ ## kind *, gfc_charlen_type); \
145 export_proto(fputc_i ## kind ## _sub); \
146 void fputc_i ## kind ## _sub \
147 (const int * unit, char * c, GFC_INTEGER_ ## kind * st, gfc_charlen_type c_len) \
148 { if (st != NULL) \
149 *st = PREFIX(fputc) (unit, c, c_len); \
150 else \
151 PREFIX(fputc) (unit, c, c_len); }
152
153 FPUTC_SUB(1)
154 FPUTC_SUB(2)
155 FPUTC_SUB(4)
156 FPUTC_SUB(8)
157
158
159 extern int PREFIX(fput) (char *, gfc_charlen_type);
160 export_proto_np(PREFIX(fput));
161
162 int
PREFIX(fput)163 PREFIX(fput) (char * c, gfc_charlen_type c_len)
164 {
165 return PREFIX(fputc) (&six, c, c_len);
166 }
167
168
169 #define FPUT_SUB(kind) \
170 extern void fput_i ## kind ## _sub \
171 (char *, GFC_INTEGER_ ## kind *, gfc_charlen_type); \
172 export_proto(fput_i ## kind ## _sub); \
173 void fput_i ## kind ## _sub \
174 (char * c, GFC_INTEGER_ ## kind * st, gfc_charlen_type c_len) \
175 { if (st != NULL) \
176 *st = PREFIX(fputc) (&six, c, c_len); \
177 else \
178 PREFIX(fputc) (&six, c, c_len); }
179
180 FPUT_SUB(1)
181 FPUT_SUB(2)
182 FPUT_SUB(4)
183 FPUT_SUB(8)
184
185
186 /* SUBROUTINE FLUSH(UNIT)
187 INTEGER, INTENT(IN), OPTIONAL :: UNIT */
188
189 extern void flush_i4 (GFC_INTEGER_4 *);
190 export_proto(flush_i4);
191
192 void
flush_i4(GFC_INTEGER_4 * unit)193 flush_i4 (GFC_INTEGER_4 *unit)
194 {
195 gfc_unit *us;
196
197 /* flush all streams */
198 if (unit == NULL)
199 flush_all_units ();
200 else
201 {
202 us = find_unit (*unit);
203 if (us != NULL)
204 {
205 sflush (us->s);
206 unlock_unit (us);
207 }
208 }
209 }
210
211
212 extern void flush_i8 (GFC_INTEGER_8 *);
213 export_proto(flush_i8);
214
215 void
flush_i8(GFC_INTEGER_8 * unit)216 flush_i8 (GFC_INTEGER_8 *unit)
217 {
218 gfc_unit *us;
219
220 /* flush all streams */
221 if (unit == NULL)
222 flush_all_units ();
223 else
224 {
225 us = find_unit (*unit);
226 if (us != NULL)
227 {
228 sflush (us->s);
229 unlock_unit (us);
230 }
231 }
232 }
233
234 /* FSEEK intrinsic */
235
236 extern void fseek_sub (int *, GFC_IO_INT *, int *, int *);
237 export_proto(fseek_sub);
238
239 void
fseek_sub(int * unit,GFC_IO_INT * offset,int * whence,int * status)240 fseek_sub (int * unit, GFC_IO_INT * offset, int * whence, int * status)
241 {
242 gfc_unit * u = find_unit (*unit);
243 ssize_t result = -1;
244
245 if (u != NULL)
246 {
247 result = sseek(u->s, *offset, *whence);
248
249 unlock_unit (u);
250 }
251
252 if (status)
253 *status = (result < 0 ? -1 : 0);
254 }
255
256
257
258 /* FTELL intrinsic */
259
260 static gfc_offset
gf_ftell(int unit)261 gf_ftell (int unit)
262 {
263 gfc_unit * u = find_unit (unit);
264 if (u == NULL)
265 return -1;
266 int pos = fbuf_reset (u);
267 if (pos != 0)
268 sseek (u->s, pos, SEEK_CUR);
269 gfc_offset ret = stell (u->s);
270 unlock_unit (u);
271 return ret;
272 }
273
274
275 /* Here is the ftell function with an incorrect return type; retained
276 due to ABI compatibility. */
277
278 extern size_t PREFIX(ftell) (int *);
279 export_proto_np(PREFIX(ftell));
280
281 size_t
PREFIX(ftell)282 PREFIX(ftell) (int * unit)
283 {
284 return gf_ftell (*unit);
285 }
286
287
288 /* Here is the ftell function with the correct return type, ensuring
289 that large files can be supported as long as the target supports
290 large integers; as of 4.8 the FTELL intrinsic function will call
291 this one instead of the old ftell above. */
292
293 extern GFC_IO_INT PREFIX(ftell2) (int *);
294 export_proto_np(PREFIX(ftell2));
295
296 GFC_IO_INT
PREFIX(ftell2)297 PREFIX(ftell2) (int * unit)
298 {
299 return gf_ftell (*unit);
300 }
301
302
303 #define FTELL_SUB(kind) \
304 extern void ftell_i ## kind ## _sub (int *, GFC_INTEGER_ ## kind *); \
305 export_proto(ftell_i ## kind ## _sub); \
306 void \
307 ftell_i ## kind ## _sub (int * unit, GFC_INTEGER_ ## kind * offset) \
308 { \
309 *offset = gf_ftell (*unit); \
310 }
311
312 FTELL_SUB(1)
313 FTELL_SUB(2)
314 FTELL_SUB(4)
315 FTELL_SUB(8)
316
317
318
319 /* LOGICAL FUNCTION ISATTY(UNIT)
320 INTEGER, INTENT(IN) :: UNIT */
321
322 extern GFC_LOGICAL_4 isatty_l4 (int *);
323 export_proto(isatty_l4);
324
325 GFC_LOGICAL_4
isatty_l4(int * unit)326 isatty_l4 (int *unit)
327 {
328 gfc_unit *u;
329 GFC_LOGICAL_4 ret = 0;
330
331 u = find_unit (*unit);
332 if (u != NULL)
333 {
334 ret = (GFC_LOGICAL_4) stream_isatty (u->s);
335 unlock_unit (u);
336 }
337 return ret;
338 }
339
340
341 extern GFC_LOGICAL_8 isatty_l8 (int *);
342 export_proto(isatty_l8);
343
344 GFC_LOGICAL_8
isatty_l8(int * unit)345 isatty_l8 (int *unit)
346 {
347 gfc_unit *u;
348 GFC_LOGICAL_8 ret = 0;
349
350 u = find_unit (*unit);
351 if (u != NULL)
352 {
353 ret = (GFC_LOGICAL_8) stream_isatty (u->s);
354 unlock_unit (u);
355 }
356 return ret;
357 }
358
359
360 /* SUBROUTINE TTYNAM(UNIT,NAME)
361 INTEGER,SCALAR,INTENT(IN) :: UNIT
362 CHARACTER,SCALAR,INTENT(OUT) :: NAME */
363
364 extern void ttynam_sub (int *, char *, gfc_charlen_type);
365 export_proto(ttynam_sub);
366
367 void
ttynam_sub(int * unit,char * name,gfc_charlen_type name_len)368 ttynam_sub (int *unit, char * name, gfc_charlen_type name_len)
369 {
370 gfc_unit *u;
371 int nlen;
372 int err = 1;
373
374 u = find_unit (*unit);
375 if (u != NULL)
376 {
377 err = stream_ttyname (u->s, name, name_len);
378 if (err == 0)
379 {
380 nlen = strlen (name);
381 memset (&name[nlen], ' ', name_len - nlen);
382 }
383
384 unlock_unit (u);
385 }
386 if (err != 0)
387 memset (name, ' ', name_len);
388 }
389
390
391 extern void ttynam (char **, gfc_charlen_type *, int);
392 export_proto(ttynam);
393
394 void
ttynam(char ** name,gfc_charlen_type * name_len,int unit)395 ttynam (char ** name, gfc_charlen_type * name_len, int unit)
396 {
397 gfc_unit *u;
398
399 u = find_unit (unit);
400 if (u != NULL)
401 {
402 *name = xmalloc (TTY_NAME_MAX);
403 int err = stream_ttyname (u->s, *name, TTY_NAME_MAX);
404 if (err == 0)
405 {
406 *name_len = strlen (*name);
407 unlock_unit (u);
408 return;
409 }
410 free (*name);
411 unlock_unit (u);
412 }
413
414 *name_len = 0;
415 *name = NULL;
416 }
417