]>
Commit | Line | Data |
---|---|---|
0dce3ca1 FXC |
1 | /* Implementation of the FGET, FGETC, FPUT, FPUTC, FLUSH |
2 | FTELL, TTYNAM and ISATTY intrinsics. | |
8d9254fc | 3 | Copyright (C) 2005-2020 Free Software Foundation, Inc. |
5d723e54 | 4 | |
e76a3fde | 5 | This file is part of the GNU Fortran runtime library (libgfortran). |
5d723e54 FXC |
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 | |
748086b7 | 10 | version 3 of the License, or (at your option) any later version. |
5d723e54 FXC |
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 | ||
748086b7 JJ |
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/>. */ | |
5d723e54 | 25 | |
36ae8a61 | 26 | #include "io.h" |
92cbdb68 JB |
27 | #include "fbuf.h" |
28 | #include "unix.h" | |
5d723e54 FXC |
29 | #include <string.h> |
30 | ||
74544378 | 31 | |
5d723e54 FXC |
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 | |
f29876bb | 39 | PREFIX(fgetc) (const int *unit, char *c, gfc_charlen_type c_len) |
5d723e54 FXC |
40 | { |
41 | int ret; | |
f29876bb | 42 | gfc_unit *u = find_unit (*unit); |
5d723e54 FXC |
43 | |
44 | if (u == NULL) | |
45 | return -1; | |
46 | ||
ee56ac9d JB |
47 | fbuf_reset (u); |
48 | if (u->mode == WRITING) | |
49 | { | |
50 | sflush (u->s); | |
51 | u->mode = READING; | |
52 | } | |
53 | ||
5d723e54 | 54 | memset (c, ' ', c_len); |
f9bfed22 | 55 | ret = sread (u->s, c, 1); |
401cd90a | 56 | unlock_unit (u); |
5d723e54 | 57 | |
7812c78c | 58 | if (ret < 0) |
5d723e54 FXC |
59 | return ret; |
60 | ||
7812c78c | 61 | if (ret != 1) |
5d723e54 FXC |
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 \ | |
f29876bb | 73 | (const int *unit, char *c, GFC_INTEGER_ ## kind *st, gfc_charlen_type c_len) \ |
5d723e54 FXC |
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 | |
f29876bb | 89 | PREFIX(fget) (char *c, gfc_charlen_type c_len) |
5d723e54 FXC |
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 \ | |
f29876bb | 100 | (char *c, GFC_INTEGER_ ## kind *st, gfc_charlen_type c_len) \ |
5d723e54 FXC |
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 | |
f29876bb | 117 | PREFIX(fputc) (const int *unit, char *c, |
5d723e54 FXC |
118 | gfc_charlen_type c_len __attribute__((unused))) |
119 | { | |
7812c78c | 120 | ssize_t s; |
f29876bb | 121 | gfc_unit *u = find_unit (*unit); |
5d723e54 FXC |
122 | |
123 | if (u == NULL) | |
124 | return -1; | |
125 | ||
ee56ac9d JB |
126 | fbuf_reset (u); |
127 | if (u->mode == READING) | |
128 | { | |
129 | sflush (u->s); | |
130 | u->mode = WRITING; | |
131 | } | |
132 | ||
7812c78c | 133 | s = swrite (u->s, c, 1); |
401cd90a | 134 | unlock_unit (u); |
7812c78c JD |
135 | if (s < 0) |
136 | return -1; | |
137 | return 0; | |
5d723e54 FXC |
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 \ | |
f29876bb | 146 | (const int *unit, char *c, GFC_INTEGER_ ## kind *st, gfc_charlen_type c_len) \ |
5d723e54 FXC |
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 | |
f29876bb | 162 | PREFIX(fput) (char *c, gfc_charlen_type c_len) |
5d723e54 FXC |
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 \ | |
f29876bb | 173 | (char *c, GFC_INTEGER_ ## kind *st, gfc_charlen_type c_len) \ |
5d723e54 FXC |
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 | ||
0dce3ca1 FXC |
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 | { | |
7812c78c | 204 | sflush (us->s); |
0dce3ca1 FXC |
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 | { | |
7812c78c | 227 | sflush (us->s); |
0dce3ca1 FXC |
228 | unlock_unit (us); |
229 | } | |
230 | } | |
231 | } | |
232 | ||
dcdc26df DF |
233 | /* FSEEK intrinsic */ |
234 | ||
235 | extern void fseek_sub (int *, GFC_IO_INT *, int *, int *); | |
236 | export_proto(fseek_sub); | |
237 | ||
238 | void | |
f29876bb | 239 | fseek_sub (int *unit, GFC_IO_INT *offset, int *whence, int *status) |
dcdc26df | 240 | { |
f29876bb | 241 | gfc_unit *u = find_unit (*unit); |
7812c78c | 242 | ssize_t result = -1; |
dcdc26df | 243 | |
7d5ee219 | 244 | if (u != NULL) |
dcdc26df | 245 | { |
7812c78c | 246 | result = sseek(u->s, *offset, *whence); |
dcdc26df DF |
247 | |
248 | unlock_unit (u); | |
249 | } | |
250 | ||
251 | if (status) | |
7812c78c | 252 | *status = (result < 0 ? -1 : 0); |
dcdc26df DF |
253 | } |
254 | ||
255 | ||
0dce3ca1 FXC |
256 | |
257 | /* FTELL intrinsic */ | |
258 | ||
b879c108 JB |
259 | static gfc_offset |
260 | gf_ftell (int unit) | |
261 | { | |
f29876bb | 262 | gfc_unit *u = find_unit (unit); |
b879c108 JB |
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 | ||
67eb28c8 | 273 | |
f7db9ebf | 274 | extern GFC_IO_INT PREFIX(ftell) (int *); |
0dce3ca1 FXC |
275 | export_proto_np(PREFIX(ftell)); |
276 | ||
67eb28c8 | 277 | GFC_IO_INT |
f29876bb | 278 | PREFIX(ftell) (int *unit) |
67eb28c8 JB |
279 | { |
280 | return gf_ftell (*unit); | |
281 | } | |
282 | ||
283 | ||
0dce3ca1 FXC |
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 \ | |
f29876bb | 288 | ftell_i ## kind ## _sub (int *unit, GFC_INTEGER_ ## kind *offset) \ |
0dce3ca1 | 289 | { \ |
b879c108 | 290 | *offset = gf_ftell (*unit); \ |
0dce3ca1 FXC |
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 | |
f29876bb | 349 | ttynam_sub (int *unit, char *name, gfc_charlen_type name_len) |
0dce3ca1 FXC |
350 | { |
351 | gfc_unit *u; | |
6a0f6e77 JB |
352 | int nlen; |
353 | int err = 1; | |
0dce3ca1 | 354 | |
0dce3ca1 FXC |
355 | u = find_unit (*unit); |
356 | if (u != NULL) | |
357 | { | |
6a0f6e77 JB |
358 | err = stream_ttyname (u->s, name, name_len); |
359 | if (err == 0) | |
0dce3ca1 | 360 | { |
6a0f6e77 JB |
361 | nlen = strlen (name); |
362 | memset (&name[nlen], ' ', name_len - nlen); | |
0dce3ca1 | 363 | } |
6a0f6e77 | 364 | |
0dce3ca1 FXC |
365 | unlock_unit (u); |
366 | } | |
6a0f6e77 JB |
367 | if (err != 0) |
368 | memset (name, ' ', name_len); | |
0dce3ca1 FXC |
369 | } |
370 | ||
371 | ||
372 | extern void ttynam (char **, gfc_charlen_type *, int); | |
373 | export_proto(ttynam); | |
374 | ||
375 | void | |
f29876bb | 376 | ttynam (char **name, gfc_charlen_type *name_len, int unit) |
0dce3ca1 FXC |
377 | { |
378 | gfc_unit *u; | |
379 | ||
380 | u = find_unit (unit); | |
381 | if (u != NULL) | |
382 | { | |
1a0fd3d3 | 383 | *name = xmalloc (TTY_NAME_MAX); |
6a0f6e77 JB |
384 | int err = stream_ttyname (u->s, *name, TTY_NAME_MAX); |
385 | if (err == 0) | |
0dce3ca1 FXC |
386 | { |
387 | *name_len = strlen (*name); | |
0dce3ca1 FXC |
388 | unlock_unit (u); |
389 | return; | |
390 | } | |
6a0f6e77 | 391 | free (*name); |
0dce3ca1 FXC |
392 | unlock_unit (u); |
393 | } | |
394 | ||
395 | *name_len = 0; | |
396 | *name = NULL; | |
397 | } |