]>
Commit | Line | Data |
---|---|---|
0dce3ca1 FXC |
1 | /* Implementation of the FGET, FGETC, FPUT, FPUTC, FLUSH |
2 | FTELL, TTYNAM and ISATTY intrinsics. | |
6a0f6e77 JB |
3 | Copyright (C) 2005, 2007, 2009, 2010, 2011 Free Software |
4 | Foundation, Inc. | |
5d723e54 | 5 | |
e76a3fde | 6 | This file is part of the GNU Fortran runtime library (libgfortran). |
5d723e54 FXC |
7 | |
8 | Libgfortran is free software; you can redistribute it and/or | |
9 | modify it under the terms of the GNU General Public | |
10 | License as published by the Free Software Foundation; either | |
748086b7 | 11 | version 3 of the License, or (at your option) any later version. |
5d723e54 FXC |
12 | |
13 | Libgfortran is distributed in the hope that it will be useful, | |
14 | but WITHOUT ANY WARRANTY; without even the implied warranty of | |
15 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
16 | GNU General Public License for more details. | |
17 | ||
748086b7 JJ |
18 | Under Section 7 of GPL version 3, you are granted additional |
19 | permissions described in the GCC Runtime Library Exception, version | |
20 | 3.1, as published by the Free Software Foundation. | |
21 | ||
22 | You should have received a copy of the GNU General Public License and | |
23 | a copy of the GCC Runtime Library Exception along with this program; | |
24 | see the files COPYING3 and COPYING.RUNTIME respectively. If not, see | |
25 | <http://www.gnu.org/licenses/>. */ | |
5d723e54 | 26 | |
36ae8a61 | 27 | #include "io.h" |
92cbdb68 JB |
28 | #include "fbuf.h" |
29 | #include "unix.h" | |
5d723e54 | 30 | |
0dce3ca1 FXC |
31 | #ifdef HAVE_STDLIB_H |
32 | #include <stdlib.h> | |
33 | #endif | |
34 | ||
5d723e54 FXC |
35 | #include <string.h> |
36 | ||
5d723e54 FXC |
37 | static const int five = 5; |
38 | static const int six = 6; | |
39 | ||
40 | extern int PREFIX(fgetc) (const int *, char *, gfc_charlen_type); | |
41 | export_proto_np(PREFIX(fgetc)); | |
42 | ||
43 | int | |
44 | PREFIX(fgetc) (const int * unit, char * c, gfc_charlen_type c_len) | |
45 | { | |
46 | int ret; | |
5d723e54 FXC |
47 | gfc_unit * u = find_unit (*unit); |
48 | ||
49 | if (u == NULL) | |
50 | return -1; | |
51 | ||
ee56ac9d JB |
52 | fbuf_reset (u); |
53 | if (u->mode == WRITING) | |
54 | { | |
55 | sflush (u->s); | |
56 | u->mode = READING; | |
57 | } | |
58 | ||
5d723e54 | 59 | memset (c, ' ', c_len); |
f9bfed22 | 60 | ret = sread (u->s, c, 1); |
401cd90a | 61 | unlock_unit (u); |
5d723e54 | 62 | |
7812c78c | 63 | if (ret < 0) |
5d723e54 FXC |
64 | return ret; |
65 | ||
7812c78c | 66 | if (ret != 1) |
5d723e54 FXC |
67 | return -1; |
68 | else | |
69 | return 0; | |
70 | } | |
71 | ||
72 | ||
73 | #define FGETC_SUB(kind) \ | |
74 | extern void fgetc_i ## kind ## _sub \ | |
75 | (const int *, char *, GFC_INTEGER_ ## kind *, gfc_charlen_type); \ | |
76 | export_proto(fgetc_i ## kind ## _sub); \ | |
77 | void fgetc_i ## kind ## _sub \ | |
78 | (const int * unit, char * c, GFC_INTEGER_ ## kind * st, gfc_charlen_type c_len) \ | |
79 | { if (st != NULL) \ | |
80 | *st = PREFIX(fgetc) (unit, c, c_len); \ | |
81 | else \ | |
82 | PREFIX(fgetc) (unit, c, c_len); } | |
83 | ||
84 | FGETC_SUB(1) | |
85 | FGETC_SUB(2) | |
86 | FGETC_SUB(4) | |
87 | FGETC_SUB(8) | |
88 | ||
89 | ||
90 | extern int PREFIX(fget) (char *, gfc_charlen_type); | |
91 | export_proto_np(PREFIX(fget)); | |
92 | ||
93 | int | |
94 | PREFIX(fget) (char * c, gfc_charlen_type c_len) | |
95 | { | |
96 | return PREFIX(fgetc) (&five, c, c_len); | |
97 | } | |
98 | ||
99 | ||
100 | #define FGET_SUB(kind) \ | |
101 | extern void fget_i ## kind ## _sub \ | |
102 | (char *, GFC_INTEGER_ ## kind *, gfc_charlen_type); \ | |
103 | export_proto(fget_i ## kind ## _sub); \ | |
104 | void fget_i ## kind ## _sub \ | |
105 | (char * c, GFC_INTEGER_ ## kind * st, gfc_charlen_type c_len) \ | |
106 | { if (st != NULL) \ | |
107 | *st = PREFIX(fgetc) (&five, c, c_len); \ | |
108 | else \ | |
109 | PREFIX(fgetc) (&five, c, c_len); } | |
110 | ||
111 | FGET_SUB(1) | |
112 | FGET_SUB(2) | |
113 | FGET_SUB(4) | |
114 | FGET_SUB(8) | |
115 | ||
116 | ||
117 | ||
118 | extern int PREFIX(fputc) (const int *, char *, gfc_charlen_type); | |
119 | export_proto_np(PREFIX(fputc)); | |
120 | ||
121 | int | |
122 | PREFIX(fputc) (const int * unit, char * c, | |
123 | gfc_charlen_type c_len __attribute__((unused))) | |
124 | { | |
7812c78c | 125 | ssize_t s; |
5d723e54 FXC |
126 | gfc_unit * u = find_unit (*unit); |
127 | ||
128 | if (u == NULL) | |
129 | return -1; | |
130 | ||
ee56ac9d JB |
131 | fbuf_reset (u); |
132 | if (u->mode == READING) | |
133 | { | |
134 | sflush (u->s); | |
135 | u->mode = WRITING; | |
136 | } | |
137 | ||
7812c78c | 138 | s = swrite (u->s, c, 1); |
401cd90a | 139 | unlock_unit (u); |
7812c78c JD |
140 | if (s < 0) |
141 | return -1; | |
142 | return 0; | |
5d723e54 FXC |
143 | } |
144 | ||
145 | ||
146 | #define FPUTC_SUB(kind) \ | |
147 | extern void fputc_i ## kind ## _sub \ | |
148 | (const int *, char *, GFC_INTEGER_ ## kind *, gfc_charlen_type); \ | |
149 | export_proto(fputc_i ## kind ## _sub); \ | |
150 | void fputc_i ## kind ## _sub \ | |
151 | (const int * unit, char * c, GFC_INTEGER_ ## kind * st, gfc_charlen_type c_len) \ | |
152 | { if (st != NULL) \ | |
153 | *st = PREFIX(fputc) (unit, c, c_len); \ | |
154 | else \ | |
155 | PREFIX(fputc) (unit, c, c_len); } | |
156 | ||
157 | FPUTC_SUB(1) | |
158 | FPUTC_SUB(2) | |
159 | FPUTC_SUB(4) | |
160 | FPUTC_SUB(8) | |
161 | ||
162 | ||
163 | extern int PREFIX(fput) (char *, gfc_charlen_type); | |
164 | export_proto_np(PREFIX(fput)); | |
165 | ||
166 | int | |
167 | PREFIX(fput) (char * c, gfc_charlen_type c_len) | |
168 | { | |
169 | return PREFIX(fputc) (&six, c, c_len); | |
170 | } | |
171 | ||
172 | ||
173 | #define FPUT_SUB(kind) \ | |
174 | extern void fput_i ## kind ## _sub \ | |
175 | (char *, GFC_INTEGER_ ## kind *, gfc_charlen_type); \ | |
176 | export_proto(fput_i ## kind ## _sub); \ | |
177 | void fput_i ## kind ## _sub \ | |
178 | (char * c, GFC_INTEGER_ ## kind * st, gfc_charlen_type c_len) \ | |
179 | { if (st != NULL) \ | |
180 | *st = PREFIX(fputc) (&six, c, c_len); \ | |
181 | else \ | |
182 | PREFIX(fputc) (&six, c, c_len); } | |
183 | ||
184 | FPUT_SUB(1) | |
185 | FPUT_SUB(2) | |
186 | FPUT_SUB(4) | |
187 | FPUT_SUB(8) | |
188 | ||
0dce3ca1 FXC |
189 | |
190 | /* SUBROUTINE FLUSH(UNIT) | |
191 | INTEGER, INTENT(IN), OPTIONAL :: UNIT */ | |
192 | ||
193 | extern void flush_i4 (GFC_INTEGER_4 *); | |
194 | export_proto(flush_i4); | |
195 | ||
196 | void | |
197 | flush_i4 (GFC_INTEGER_4 *unit) | |
198 | { | |
199 | gfc_unit *us; | |
200 | ||
201 | /* flush all streams */ | |
202 | if (unit == NULL) | |
203 | flush_all_units (); | |
204 | else | |
205 | { | |
206 | us = find_unit (*unit); | |
207 | if (us != NULL) | |
208 | { | |
7812c78c | 209 | sflush (us->s); |
0dce3ca1 FXC |
210 | unlock_unit (us); |
211 | } | |
212 | } | |
213 | } | |
214 | ||
215 | ||
216 | extern void flush_i8 (GFC_INTEGER_8 *); | |
217 | export_proto(flush_i8); | |
218 | ||
219 | void | |
220 | flush_i8 (GFC_INTEGER_8 *unit) | |
221 | { | |
222 | gfc_unit *us; | |
223 | ||
224 | /* flush all streams */ | |
225 | if (unit == NULL) | |
226 | flush_all_units (); | |
227 | else | |
228 | { | |
229 | us = find_unit (*unit); | |
230 | if (us != NULL) | |
231 | { | |
7812c78c | 232 | sflush (us->s); |
0dce3ca1 FXC |
233 | unlock_unit (us); |
234 | } | |
235 | } | |
236 | } | |
237 | ||
dcdc26df DF |
238 | /* FSEEK intrinsic */ |
239 | ||
240 | extern void fseek_sub (int *, GFC_IO_INT *, int *, int *); | |
241 | export_proto(fseek_sub); | |
242 | ||
243 | void | |
244 | fseek_sub (int * unit, GFC_IO_INT * offset, int * whence, int * status) | |
245 | { | |
246 | gfc_unit * u = find_unit (*unit); | |
7812c78c | 247 | ssize_t result = -1; |
dcdc26df | 248 | |
7d5ee219 | 249 | if (u != NULL) |
dcdc26df | 250 | { |
7812c78c | 251 | result = sseek(u->s, *offset, *whence); |
dcdc26df DF |
252 | |
253 | unlock_unit (u); | |
254 | } | |
255 | ||
256 | if (status) | |
7812c78c | 257 | *status = (result < 0 ? -1 : 0); |
dcdc26df DF |
258 | } |
259 | ||
260 | ||
0dce3ca1 FXC |
261 | |
262 | /* FTELL intrinsic */ | |
263 | ||
b879c108 JB |
264 | static gfc_offset |
265 | gf_ftell (int unit) | |
266 | { | |
267 | gfc_unit * u = find_unit (unit); | |
268 | if (u == NULL) | |
269 | return -1; | |
270 | int pos = fbuf_reset (u); | |
271 | if (pos != 0) | |
272 | sseek (u->s, pos, SEEK_CUR); | |
273 | gfc_offset ret = stell (u->s); | |
274 | unlock_unit (u); | |
275 | return ret; | |
276 | } | |
277 | ||
0dce3ca1 FXC |
278 | extern size_t PREFIX(ftell) (int *); |
279 | export_proto_np(PREFIX(ftell)); | |
280 | ||
281 | size_t | |
282 | PREFIX(ftell) (int * unit) | |
283 | { | |
b879c108 | 284 | return gf_ftell (*unit); |
0dce3ca1 FXC |
285 | } |
286 | ||
287 | #define FTELL_SUB(kind) \ | |
288 | extern void ftell_i ## kind ## _sub (int *, GFC_INTEGER_ ## kind *); \ | |
289 | export_proto(ftell_i ## kind ## _sub); \ | |
290 | void \ | |
291 | ftell_i ## kind ## _sub (int * unit, GFC_INTEGER_ ## kind * offset) \ | |
292 | { \ | |
b879c108 | 293 | *offset = gf_ftell (*unit); \ |
0dce3ca1 FXC |
294 | } |
295 | ||
296 | FTELL_SUB(1) | |
297 | FTELL_SUB(2) | |
298 | FTELL_SUB(4) | |
299 | FTELL_SUB(8) | |
300 | ||
301 | ||
302 | ||
303 | /* LOGICAL FUNCTION ISATTY(UNIT) | |
304 | INTEGER, INTENT(IN) :: UNIT */ | |
305 | ||
306 | extern GFC_LOGICAL_4 isatty_l4 (int *); | |
307 | export_proto(isatty_l4); | |
308 | ||
309 | GFC_LOGICAL_4 | |
310 | isatty_l4 (int *unit) | |
311 | { | |
312 | gfc_unit *u; | |
313 | GFC_LOGICAL_4 ret = 0; | |
314 | ||
315 | u = find_unit (*unit); | |
316 | if (u != NULL) | |
317 | { | |
318 | ret = (GFC_LOGICAL_4) stream_isatty (u->s); | |
319 | unlock_unit (u); | |
320 | } | |
321 | return ret; | |
322 | } | |
323 | ||
324 | ||
325 | extern GFC_LOGICAL_8 isatty_l8 (int *); | |
326 | export_proto(isatty_l8); | |
327 | ||
328 | GFC_LOGICAL_8 | |
329 | isatty_l8 (int *unit) | |
330 | { | |
331 | gfc_unit *u; | |
332 | GFC_LOGICAL_8 ret = 0; | |
333 | ||
334 | u = find_unit (*unit); | |
335 | if (u != NULL) | |
336 | { | |
337 | ret = (GFC_LOGICAL_8) stream_isatty (u->s); | |
338 | unlock_unit (u); | |
339 | } | |
340 | return ret; | |
341 | } | |
342 | ||
343 | ||
344 | /* SUBROUTINE TTYNAM(UNIT,NAME) | |
345 | INTEGER,SCALAR,INTENT(IN) :: UNIT | |
346 | CHARACTER,SCALAR,INTENT(OUT) :: NAME */ | |
347 | ||
348 | extern void ttynam_sub (int *, char *, gfc_charlen_type); | |
349 | export_proto(ttynam_sub); | |
350 | ||
351 | void | |
352 | ttynam_sub (int *unit, char * name, gfc_charlen_type name_len) | |
353 | { | |
354 | gfc_unit *u; | |
6a0f6e77 JB |
355 | int nlen; |
356 | int err = 1; | |
0dce3ca1 | 357 | |
0dce3ca1 FXC |
358 | u = find_unit (*unit); |
359 | if (u != NULL) | |
360 | { | |
6a0f6e77 JB |
361 | err = stream_ttyname (u->s, name, name_len); |
362 | if (err == 0) | |
0dce3ca1 | 363 | { |
6a0f6e77 JB |
364 | nlen = strlen (name); |
365 | memset (&name[nlen], ' ', name_len - nlen); | |
0dce3ca1 | 366 | } |
6a0f6e77 | 367 | |
0dce3ca1 FXC |
368 | unlock_unit (u); |
369 | } | |
6a0f6e77 JB |
370 | if (err != 0) |
371 | memset (name, ' ', name_len); | |
0dce3ca1 FXC |
372 | } |
373 | ||
374 | ||
375 | extern void ttynam (char **, gfc_charlen_type *, int); | |
376 | export_proto(ttynam); | |
377 | ||
378 | void | |
379 | ttynam (char ** name, gfc_charlen_type * name_len, int unit) | |
380 | { | |
381 | gfc_unit *u; | |
382 | ||
383 | u = find_unit (unit); | |
384 | if (u != NULL) | |
385 | { | |
6a0f6e77 JB |
386 | *name = get_mem (TTY_NAME_MAX); |
387 | int err = stream_ttyname (u->s, *name, TTY_NAME_MAX); | |
388 | if (err == 0) | |
0dce3ca1 FXC |
389 | { |
390 | *name_len = strlen (*name); | |
0dce3ca1 FXC |
391 | unlock_unit (u); |
392 | return; | |
393 | } | |
6a0f6e77 | 394 | free (*name); |
0dce3ca1 FXC |
395 | unlock_unit (u); |
396 | } | |
397 | ||
398 | *name_len = 0; | |
399 | *name = NULL; | |
400 | } |