1 /* Implementation of the FGET, FGETC, FPUT, FPUTC, FLUSH
2 FTELL, TTYNAM and ISATTY intrinsics.
3 Copyright (C) 2005, 2007, 2009, 2010, 2011, 2012 Free Software
6 This file is part of the GNU Fortran runtime library (libgfortran).
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
11 version 3 of the License, or (at your option) any later version.
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.
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.
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/>. */
34 static const int five
= 5;
35 static const int six
= 6;
37 extern int PREFIX(fgetc
) (const int *, char *, gfc_charlen_type
);
38 export_proto_np(PREFIX(fgetc
));
41 PREFIX(fgetc
) (const int * unit
, char * c
, gfc_charlen_type c_len
)
44 gfc_unit
* u
= find_unit (*unit
);
50 if (u
->mode
== WRITING
)
56 memset (c
, ' ', c_len
);
57 ret
= sread (u
->s
, c
, 1);
70 #define FGETC_SUB(kind) \
71 extern void fgetc_i ## kind ## _sub \
72 (const int *, char *, GFC_INTEGER_ ## kind *, gfc_charlen_type); \
73 export_proto(fgetc_i ## kind ## _sub); \
74 void fgetc_i ## kind ## _sub \
75 (const int * unit, char * c, GFC_INTEGER_ ## kind * st, gfc_charlen_type c_len) \
77 *st = PREFIX(fgetc) (unit, c, c_len); \
79 PREFIX(fgetc) (unit, c, c_len); }
87 extern int PREFIX(fget
) (char *, gfc_charlen_type
);
88 export_proto_np(PREFIX(fget
));
91 PREFIX(fget
) (char * c
, gfc_charlen_type c_len
)
93 return PREFIX(fgetc
) (&five
, c
, c_len
);
97 #define FGET_SUB(kind) \
98 extern void fget_i ## kind ## _sub \
99 (char *, GFC_INTEGER_ ## kind *, gfc_charlen_type); \
100 export_proto(fget_i ## kind ## _sub); \
101 void fget_i ## kind ## _sub \
102 (char * c, GFC_INTEGER_ ## kind * st, gfc_charlen_type c_len) \
104 *st = PREFIX(fgetc) (&five, c, c_len); \
106 PREFIX(fgetc) (&five, c, c_len); }
115 extern int PREFIX(fputc
) (const int *, char *, gfc_charlen_type
);
116 export_proto_np(PREFIX(fputc
));
119 PREFIX(fputc
) (const int * unit
, char * c
,
120 gfc_charlen_type c_len
__attribute__((unused
)))
123 gfc_unit
* u
= find_unit (*unit
);
129 if (u
->mode
== READING
)
135 s
= swrite (u
->s
, c
, 1);
143 #define FPUTC_SUB(kind) \
144 extern void fputc_i ## kind ## _sub \
145 (const int *, char *, GFC_INTEGER_ ## kind *, gfc_charlen_type); \
146 export_proto(fputc_i ## kind ## _sub); \
147 void fputc_i ## kind ## _sub \
148 (const int * unit, char * c, GFC_INTEGER_ ## kind * st, gfc_charlen_type c_len) \
150 *st = PREFIX(fputc) (unit, c, c_len); \
152 PREFIX(fputc) (unit, c, c_len); }
160 extern int PREFIX(fput
) (char *, gfc_charlen_type
);
161 export_proto_np(PREFIX(fput
));
164 PREFIX(fput
) (char * c
, gfc_charlen_type c_len
)
166 return PREFIX(fputc
) (&six
, c
, c_len
);
170 #define FPUT_SUB(kind) \
171 extern void fput_i ## kind ## _sub \
172 (char *, GFC_INTEGER_ ## kind *, gfc_charlen_type); \
173 export_proto(fput_i ## kind ## _sub); \
174 void fput_i ## kind ## _sub \
175 (char * c, GFC_INTEGER_ ## kind * st, gfc_charlen_type c_len) \
177 *st = PREFIX(fputc) (&six, c, c_len); \
179 PREFIX(fputc) (&six, c, c_len); }
187 /* SUBROUTINE FLUSH(UNIT)
188 INTEGER, INTENT(IN), OPTIONAL :: UNIT */
190 extern void flush_i4 (GFC_INTEGER_4
*);
191 export_proto(flush_i4
);
194 flush_i4 (GFC_INTEGER_4
*unit
)
198 /* flush all streams */
203 us
= find_unit (*unit
);
213 extern void flush_i8 (GFC_INTEGER_8
*);
214 export_proto(flush_i8
);
217 flush_i8 (GFC_INTEGER_8
*unit
)
221 /* flush all streams */
226 us
= find_unit (*unit
);
235 /* FSEEK intrinsic */
237 extern void fseek_sub (int *, GFC_IO_INT
*, int *, int *);
238 export_proto(fseek_sub
);
241 fseek_sub (int * unit
, GFC_IO_INT
* offset
, int * whence
, int * status
)
243 gfc_unit
* u
= find_unit (*unit
);
248 result
= sseek(u
->s
, *offset
, *whence
);
254 *status
= (result
< 0 ? -1 : 0);
259 /* FTELL intrinsic */
264 gfc_unit
* u
= find_unit (unit
);
267 int pos
= fbuf_reset (u
);
269 sseek (u
->s
, pos
, SEEK_CUR
);
270 gfc_offset ret
= stell (u
->s
);
276 /* Here is the ftell function with an incorrect return type; retained
277 due to ABI compatibility. */
279 extern size_t PREFIX(ftell
) (int *);
280 export_proto_np(PREFIX(ftell
));
283 PREFIX(ftell
) (int * unit
)
285 return gf_ftell (*unit
);
289 /* Here is the ftell function with the correct return type, ensuring
290 that large files can be supported as long as the target supports
291 large integers; as of 4.8 the FTELL intrinsic function will call
292 this one instead of the old ftell above. */
294 extern GFC_IO_INT
PREFIX(ftell2
) (int *);
295 export_proto_np(PREFIX(ftell2
));
298 PREFIX(ftell2
) (int * unit
)
300 return gf_ftell (*unit
);
304 #define FTELL_SUB(kind) \
305 extern void ftell_i ## kind ## _sub (int *, GFC_INTEGER_ ## kind *); \
306 export_proto(ftell_i ## kind ## _sub); \
308 ftell_i ## kind ## _sub (int * unit, GFC_INTEGER_ ## kind * offset) \
310 *offset = gf_ftell (*unit); \
320 /* LOGICAL FUNCTION ISATTY(UNIT)
321 INTEGER, INTENT(IN) :: UNIT */
323 extern GFC_LOGICAL_4
isatty_l4 (int *);
324 export_proto(isatty_l4
);
327 isatty_l4 (int *unit
)
330 GFC_LOGICAL_4 ret
= 0;
332 u
= find_unit (*unit
);
335 ret
= (GFC_LOGICAL_4
) stream_isatty (u
->s
);
342 extern GFC_LOGICAL_8
isatty_l8 (int *);
343 export_proto(isatty_l8
);
346 isatty_l8 (int *unit
)
349 GFC_LOGICAL_8 ret
= 0;
351 u
= find_unit (*unit
);
354 ret
= (GFC_LOGICAL_8
) stream_isatty (u
->s
);
361 /* SUBROUTINE TTYNAM(UNIT,NAME)
362 INTEGER,SCALAR,INTENT(IN) :: UNIT
363 CHARACTER,SCALAR,INTENT(OUT) :: NAME */
365 extern void ttynam_sub (int *, char *, gfc_charlen_type
);
366 export_proto(ttynam_sub
);
369 ttynam_sub (int *unit
, char * name
, gfc_charlen_type name_len
)
375 u
= find_unit (*unit
);
378 err
= stream_ttyname (u
->s
, name
, name_len
);
381 nlen
= strlen (name
);
382 memset (&name
[nlen
], ' ', name_len
- nlen
);
388 memset (name
, ' ', name_len
);
392 extern void ttynam (char **, gfc_charlen_type
*, int);
393 export_proto(ttynam
);
396 ttynam (char ** name
, gfc_charlen_type
* name_len
, int unit
)
400 u
= find_unit (unit
);
403 *name
= xmalloc (TTY_NAME_MAX
);
404 int err
= stream_ttyname (u
->s
, *name
, TTY_NAME_MAX
);
407 *name_len
= strlen (*name
);