1 /* Implementation of the FGET, FGETC, FPUT, FPUTC, FLUSH
2 FTELL, TTYNAM and ISATTY intrinsics.
3 Copyright (C) 2005, 2007, 2009, 2010, 2011 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
);
275 extern size_t PREFIX(ftell
) (int *);
276 export_proto_np(PREFIX(ftell
));
279 PREFIX(ftell
) (int * unit
)
281 return gf_ftell (*unit
);
284 #define FTELL_SUB(kind) \
285 extern void ftell_i ## kind ## _sub (int *, GFC_INTEGER_ ## kind *); \
286 export_proto(ftell_i ## kind ## _sub); \
288 ftell_i ## kind ## _sub (int * unit, GFC_INTEGER_ ## kind * offset) \
290 *offset = gf_ftell (*unit); \
300 /* LOGICAL FUNCTION ISATTY(UNIT)
301 INTEGER, INTENT(IN) :: UNIT */
303 extern GFC_LOGICAL_4
isatty_l4 (int *);
304 export_proto(isatty_l4
);
307 isatty_l4 (int *unit
)
310 GFC_LOGICAL_4 ret
= 0;
312 u
= find_unit (*unit
);
315 ret
= (GFC_LOGICAL_4
) stream_isatty (u
->s
);
322 extern GFC_LOGICAL_8
isatty_l8 (int *);
323 export_proto(isatty_l8
);
326 isatty_l8 (int *unit
)
329 GFC_LOGICAL_8 ret
= 0;
331 u
= find_unit (*unit
);
334 ret
= (GFC_LOGICAL_8
) stream_isatty (u
->s
);
341 /* SUBROUTINE TTYNAM(UNIT,NAME)
342 INTEGER,SCALAR,INTENT(IN) :: UNIT
343 CHARACTER,SCALAR,INTENT(OUT) :: NAME */
345 extern void ttynam_sub (int *, char *, gfc_charlen_type
);
346 export_proto(ttynam_sub
);
349 ttynam_sub (int *unit
, char * name
, gfc_charlen_type name_len
)
355 u
= find_unit (*unit
);
358 err
= stream_ttyname (u
->s
, name
, name_len
);
361 nlen
= strlen (name
);
362 memset (&name
[nlen
], ' ', name_len
- nlen
);
368 memset (name
, ' ', name_len
);
372 extern void ttynam (char **, gfc_charlen_type
*, int);
373 export_proto(ttynam
);
376 ttynam (char ** name
, gfc_charlen_type
* name_len
, int unit
)
380 u
= find_unit (unit
);
383 *name
= get_mem (TTY_NAME_MAX
);
384 int err
= stream_ttyname (u
->s
, *name
, TTY_NAME_MAX
);
387 *name_len
= strlen (*name
);