OSDN Git Service

PR libfortran/27107
[pf3gnuchains/gcc-fork.git] / libgfortran / io / intrinsics.c
1 /* Implementation of the FGET, FGETC, FPUT, FPUTC, FLUSH 
2    FTELL, TTYNAM and ISATTY intrinsics.
3    Copyright (C) 2005, 2007 Free Software Foundation, Inc.
4
5 This file is part of the GNU Fortran 95 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 2 of the License, or (at your option) any later version.
11
12 In addition to the permissions in the GNU General Public License, the
13 Free Software Foundation gives you unlimited permission to link the
14 compiled version of this file into combinations with other programs,
15 and to distribute those combinations without any restriction coming
16 from the use of this file.  (The General Public License restrictions
17 do apply in other respects; for example, they cover modification of
18 the file, and distribution when not linked into a combine
19 executable.)
20
21 Libgfortran is distributed in the hope that it will be useful,
22 but WITHOUT ANY WARRANTY; without even the implied warranty of
23 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
24 GNU General Public License for more details.
25
26 You should have received a copy of the GNU General Public
27 License along with libgfortran; see the file COPYING.  If not,
28 write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
29 Boston, MA 02110-1301, USA.  */
30
31 #include "config.h"
32 #include "libgfortran.h"
33
34 #ifdef HAVE_STDLIB_H
35 #include <stdlib.h>
36 #endif
37
38 #include <string.h>
39
40 #include "io.h"
41
42 static const int five = 5;
43 static const int six = 6;
44
45 extern int PREFIX(fgetc) (const int *, char *, gfc_charlen_type);
46 export_proto_np(PREFIX(fgetc));
47
48 int
49 PREFIX(fgetc) (const int * unit, char * c, gfc_charlen_type c_len)
50 {
51   int ret;
52   size_t s;
53   gfc_unit * u = find_unit (*unit);
54
55   if (u == NULL)
56     return -1;
57
58   s = 1;
59   memset (c, ' ', c_len);
60   ret = sread (u->s, c, &s);
61   unlock_unit (u);
62
63   if (ret != 0)
64     return ret;
65
66   if (s != 1)
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 {
125   size_t s;
126   int ret;
127   gfc_unit * u = find_unit (*unit);
128
129   if (u == NULL)
130     return -1;
131
132   s = 1;
133   ret = swrite (u->s, c, &s);
134   unlock_unit (u);
135   return ret;
136 }
137
138
139 #define FPUTC_SUB(kind) \
140   extern void fputc_i ## kind ## _sub \
141     (const int *, char *, GFC_INTEGER_ ## kind *, gfc_charlen_type); \
142   export_proto(fputc_i ## kind ## _sub); \
143   void fputc_i ## kind ## _sub \
144   (const int * unit, char * c, GFC_INTEGER_ ## kind * st, gfc_charlen_type c_len) \
145     { if (st != NULL) \
146         *st = PREFIX(fputc) (unit, c, c_len); \
147       else \
148         PREFIX(fputc) (unit, c, c_len); }
149
150 FPUTC_SUB(1)
151 FPUTC_SUB(2)
152 FPUTC_SUB(4)
153 FPUTC_SUB(8)
154
155
156 extern int PREFIX(fput) (char *, gfc_charlen_type);
157 export_proto_np(PREFIX(fput));
158
159 int
160 PREFIX(fput) (char * c, gfc_charlen_type c_len)
161 {
162   return PREFIX(fputc) (&six, c, c_len);
163 }
164
165
166 #define FPUT_SUB(kind) \
167   extern void fput_i ## kind ## _sub \
168     (char *, GFC_INTEGER_ ## kind *, gfc_charlen_type); \
169   export_proto(fput_i ## kind ## _sub); \
170   void fput_i ## kind ## _sub \
171   (char * c, GFC_INTEGER_ ## kind * st, gfc_charlen_type c_len) \
172     { if (st != NULL) \
173         *st = PREFIX(fputc) (&six, c, c_len); \
174       else \
175         PREFIX(fputc) (&six, c, c_len); }
176
177 FPUT_SUB(1)
178 FPUT_SUB(2)
179 FPUT_SUB(4)
180 FPUT_SUB(8)
181
182
183 /* SUBROUTINE FLUSH(UNIT)
184    INTEGER, INTENT(IN), OPTIONAL :: UNIT  */
185
186 extern void flush_i4 (GFC_INTEGER_4 *);
187 export_proto(flush_i4);
188
189 void
190 flush_i4 (GFC_INTEGER_4 *unit)
191 {
192   gfc_unit *us;
193
194   /* flush all streams */
195   if (unit == NULL)
196     flush_all_units ();
197   else
198     {
199       us = find_unit (*unit);
200       if (us != NULL)
201         {
202           flush (us->s);
203           unlock_unit (us);
204         }
205     }
206 }
207
208
209 extern void flush_i8 (GFC_INTEGER_8 *);
210 export_proto(flush_i8);
211
212 void
213 flush_i8 (GFC_INTEGER_8 *unit)
214 {
215   gfc_unit *us;
216
217   /* flush all streams */
218   if (unit == NULL)
219     flush_all_units ();
220   else
221     {
222       us = find_unit (*unit);
223       if (us != NULL)
224         {
225           flush (us->s);
226           unlock_unit (us);
227         }
228     }
229 }
230
231
232 /* FTELL intrinsic */
233
234 extern size_t PREFIX(ftell) (int *);
235 export_proto_np(PREFIX(ftell));
236
237 size_t
238 PREFIX(ftell) (int * unit)
239 {
240   gfc_unit * u = find_unit (*unit);
241   size_t ret;
242   if (u == NULL)
243     return ((size_t) -1);
244   ret = (size_t) stream_offset (u->s);
245   unlock_unit (u);
246   return ret;
247 }
248
249 #define FTELL_SUB(kind) \
250   extern void ftell_i ## kind ## _sub (int *, GFC_INTEGER_ ## kind *); \
251   export_proto(ftell_i ## kind ## _sub); \
252   void \
253   ftell_i ## kind ## _sub (int * unit, GFC_INTEGER_ ## kind * offset) \
254   { \
255     gfc_unit * u = find_unit (*unit); \
256     if (u == NULL) \
257       *offset = -1; \
258     else \
259       { \
260         *offset = stream_offset (u->s); \
261         unlock_unit (u); \
262       } \
263   }
264
265 FTELL_SUB(1)
266 FTELL_SUB(2)
267 FTELL_SUB(4)
268 FTELL_SUB(8)
269
270
271
272 /* LOGICAL FUNCTION ISATTY(UNIT)
273    INTEGER, INTENT(IN) :: UNIT */
274
275 extern GFC_LOGICAL_4 isatty_l4 (int *);
276 export_proto(isatty_l4);
277
278 GFC_LOGICAL_4
279 isatty_l4 (int *unit)
280 {
281   gfc_unit *u;
282   GFC_LOGICAL_4 ret = 0;
283
284   u = find_unit (*unit);
285   if (u != NULL)
286     {
287       ret = (GFC_LOGICAL_4) stream_isatty (u->s);
288       unlock_unit (u);
289     }
290   return ret;
291 }
292
293
294 extern GFC_LOGICAL_8 isatty_l8 (int *);
295 export_proto(isatty_l8);
296
297 GFC_LOGICAL_8
298 isatty_l8 (int *unit)
299 {
300   gfc_unit *u;
301   GFC_LOGICAL_8 ret = 0;
302
303   u = find_unit (*unit);
304   if (u != NULL)
305     {
306       ret = (GFC_LOGICAL_8) stream_isatty (u->s);
307       unlock_unit (u);
308     }
309   return ret;
310 }
311
312
313 /* SUBROUTINE TTYNAM(UNIT,NAME)
314    INTEGER,SCALAR,INTENT(IN) :: UNIT
315    CHARACTER,SCALAR,INTENT(OUT) :: NAME */
316
317 extern void ttynam_sub (int *, char *, gfc_charlen_type);
318 export_proto(ttynam_sub);
319
320 void
321 ttynam_sub (int *unit, char * name, gfc_charlen_type name_len)
322 {
323   gfc_unit *u;
324   char * n;
325   int i;
326
327   memset (name, ' ', name_len);
328   u = find_unit (*unit);
329   if (u != NULL)
330     {
331       n = stream_ttyname (u->s);
332       if (n != NULL)
333         {
334           i = 0;
335           while (*n && i < name_len)
336             name[i++] = *(n++);
337         }
338       unlock_unit (u);
339     }
340 }
341
342
343 extern void ttynam (char **, gfc_charlen_type *, int);
344 export_proto(ttynam);
345
346 void
347 ttynam (char ** name, gfc_charlen_type * name_len, int unit)
348 {
349   gfc_unit *u;
350
351   u = find_unit (unit);
352   if (u != NULL)
353     {
354       *name = stream_ttyname (u->s);
355       if (*name != NULL)
356         {
357           *name_len = strlen (*name);
358           *name = strdup (*name);
359           unlock_unit (u);
360           return;
361         }
362       unlock_unit (u);
363     }
364
365   *name_len = 0;
366   *name = NULL;
367 }