OSDN Git Service

PR 43839
[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, 2009, 2010 Free Software Foundation, Inc.
4
5 This file is part of the GNU Fortran 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 3 of the License, or (at your option) any later version.
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
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/>.  */
25
26 #include "io.h"
27 #include "fbuf.h"
28 #include "unix.h"
29
30 #ifdef HAVE_STDLIB_H
31 #include <stdlib.h>
32 #endif
33
34 #include <string.h>
35
36 static const int five = 5;
37 static const int six = 6;
38
39 extern int PREFIX(fgetc) (const int *, char *, gfc_charlen_type);
40 export_proto_np(PREFIX(fgetc));
41
42 int
43 PREFIX(fgetc) (const int * unit, char * c, gfc_charlen_type c_len)
44 {
45   int ret;
46   gfc_unit * u = find_unit (*unit);
47
48   if (u == NULL)
49     return -1;
50
51   fbuf_reset (u);
52   if (u->mode == WRITING)
53     {
54       sflush (u->s);
55       u->mode = READING;
56     }
57
58   memset (c, ' ', c_len);
59   ret = sread (u->s, c, 1);
60   unlock_unit (u);
61
62   if (ret < 0)
63     return ret;
64
65   if (ret != 1)
66     return -1;
67   else
68     return 0;
69 }
70
71
72 #define FGETC_SUB(kind) \
73   extern void fgetc_i ## kind ## _sub \
74     (const int *, char *, GFC_INTEGER_ ## kind *, gfc_charlen_type); \
75   export_proto(fgetc_i ## kind ## _sub); \
76   void fgetc_i ## kind ## _sub \
77   (const int * unit, char * c, GFC_INTEGER_ ## kind * st, gfc_charlen_type c_len) \
78     { if (st != NULL) \
79         *st = PREFIX(fgetc) (unit, c, c_len); \
80       else \
81         PREFIX(fgetc) (unit, c, c_len); }
82
83 FGETC_SUB(1)
84 FGETC_SUB(2)
85 FGETC_SUB(4)
86 FGETC_SUB(8)
87
88
89 extern int PREFIX(fget) (char *, gfc_charlen_type);
90 export_proto_np(PREFIX(fget));
91
92 int
93 PREFIX(fget) (char * c, gfc_charlen_type c_len)
94 {
95   return PREFIX(fgetc) (&five, c, c_len);
96 }
97
98
99 #define FGET_SUB(kind) \
100   extern void fget_i ## kind ## _sub \
101     (char *, GFC_INTEGER_ ## kind *, gfc_charlen_type); \
102   export_proto(fget_i ## kind ## _sub); \
103   void fget_i ## kind ## _sub \
104   (char * c, GFC_INTEGER_ ## kind * st, gfc_charlen_type c_len) \
105     { if (st != NULL) \
106         *st = PREFIX(fgetc) (&five, c, c_len); \
107       else \
108         PREFIX(fgetc) (&five, c, c_len); }
109
110 FGET_SUB(1)
111 FGET_SUB(2)
112 FGET_SUB(4)
113 FGET_SUB(8)
114
115
116
117 extern int PREFIX(fputc) (const int *, char *, gfc_charlen_type);
118 export_proto_np(PREFIX(fputc));
119
120 int
121 PREFIX(fputc) (const int * unit, char * c,
122                gfc_charlen_type c_len __attribute__((unused)))
123 {
124   ssize_t s;
125   gfc_unit * u = find_unit (*unit);
126
127   if (u == NULL)
128     return -1;
129
130   fbuf_reset (u);
131   if (u->mode == READING)
132     {
133       sflush (u->s);
134       u->mode = WRITING;
135     }
136
137   s = swrite (u->s, c, 1);
138   unlock_unit (u);
139   if (s < 0)
140     return -1;
141   return 0;
142 }
143
144
145 #define FPUTC_SUB(kind) \
146   extern void fputc_i ## kind ## _sub \
147     (const int *, char *, GFC_INTEGER_ ## kind *, gfc_charlen_type); \
148   export_proto(fputc_i ## kind ## _sub); \
149   void fputc_i ## kind ## _sub \
150   (const int * unit, char * c, GFC_INTEGER_ ## kind * st, gfc_charlen_type c_len) \
151     { if (st != NULL) \
152         *st = PREFIX(fputc) (unit, c, c_len); \
153       else \
154         PREFIX(fputc) (unit, c, c_len); }
155
156 FPUTC_SUB(1)
157 FPUTC_SUB(2)
158 FPUTC_SUB(4)
159 FPUTC_SUB(8)
160
161
162 extern int PREFIX(fput) (char *, gfc_charlen_type);
163 export_proto_np(PREFIX(fput));
164
165 int
166 PREFIX(fput) (char * c, gfc_charlen_type c_len)
167 {
168   return PREFIX(fputc) (&six, c, c_len);
169 }
170
171
172 #define FPUT_SUB(kind) \
173   extern void fput_i ## kind ## _sub \
174     (char *, GFC_INTEGER_ ## kind *, gfc_charlen_type); \
175   export_proto(fput_i ## kind ## _sub); \
176   void fput_i ## kind ## _sub \
177   (char * c, GFC_INTEGER_ ## kind * st, gfc_charlen_type c_len) \
178     { if (st != NULL) \
179         *st = PREFIX(fputc) (&six, c, c_len); \
180       else \
181         PREFIX(fputc) (&six, c, c_len); }
182
183 FPUT_SUB(1)
184 FPUT_SUB(2)
185 FPUT_SUB(4)
186 FPUT_SUB(8)
187
188
189 /* SUBROUTINE FLUSH(UNIT)
190    INTEGER, INTENT(IN), OPTIONAL :: UNIT  */
191
192 extern void flush_i4 (GFC_INTEGER_4 *);
193 export_proto(flush_i4);
194
195 void
196 flush_i4 (GFC_INTEGER_4 *unit)
197 {
198   gfc_unit *us;
199
200   /* flush all streams */
201   if (unit == NULL)
202     flush_all_units ();
203   else
204     {
205       us = find_unit (*unit);
206       if (us != NULL)
207         {
208           sflush (us->s);
209           unlock_unit (us);
210         }
211     }
212 }
213
214
215 extern void flush_i8 (GFC_INTEGER_8 *);
216 export_proto(flush_i8);
217
218 void
219 flush_i8 (GFC_INTEGER_8 *unit)
220 {
221   gfc_unit *us;
222
223   /* flush all streams */
224   if (unit == NULL)
225     flush_all_units ();
226   else
227     {
228       us = find_unit (*unit);
229       if (us != NULL)
230         {
231           sflush (us->s);
232           unlock_unit (us);
233         }
234     }
235 }
236
237 /* FSEEK intrinsic */
238
239 extern void fseek_sub (int *, GFC_IO_INT *, int *, int *);
240 export_proto(fseek_sub);
241
242 void
243 fseek_sub (int * unit, GFC_IO_INT * offset, int * whence, int * status)
244 {
245   gfc_unit * u = find_unit (*unit);
246   ssize_t result = -1;
247
248   if (u != NULL && is_seekable(u->s))
249     {
250       result = sseek(u->s, *offset, *whence);
251
252       unlock_unit (u);
253     }
254
255   if (status)
256     *status = (result < 0 ? -1 : 0);
257 }
258
259
260
261 /* FTELL intrinsic */
262
263 static gfc_offset
264 gf_ftell (int unit)
265 {
266   gfc_unit * u = find_unit (unit);
267   if (u == NULL)
268     return -1;
269   int pos = fbuf_reset (u);
270   if (pos != 0)
271     sseek (u->s, pos, SEEK_CUR);
272   gfc_offset ret = stell (u->s);
273   unlock_unit (u);
274   return ret;
275 }
276
277 extern size_t PREFIX(ftell) (int *);
278 export_proto_np(PREFIX(ftell));
279
280 size_t
281 PREFIX(ftell) (int * unit)
282 {
283   return gf_ftell (*unit);
284 }
285
286 #define FTELL_SUB(kind) \
287   extern void ftell_i ## kind ## _sub (int *, GFC_INTEGER_ ## kind *); \
288   export_proto(ftell_i ## kind ## _sub); \
289   void \
290   ftell_i ## kind ## _sub (int * unit, GFC_INTEGER_ ## kind * offset) \
291   { \
292     *offset = gf_ftell (*unit);                 \
293   }
294
295 FTELL_SUB(1)
296 FTELL_SUB(2)
297 FTELL_SUB(4)
298 FTELL_SUB(8)
299
300
301
302 /* LOGICAL FUNCTION ISATTY(UNIT)
303    INTEGER, INTENT(IN) :: UNIT */
304
305 extern GFC_LOGICAL_4 isatty_l4 (int *);
306 export_proto(isatty_l4);
307
308 GFC_LOGICAL_4
309 isatty_l4 (int *unit)
310 {
311   gfc_unit *u;
312   GFC_LOGICAL_4 ret = 0;
313
314   u = find_unit (*unit);
315   if (u != NULL)
316     {
317       ret = (GFC_LOGICAL_4) stream_isatty (u->s);
318       unlock_unit (u);
319     }
320   return ret;
321 }
322
323
324 extern GFC_LOGICAL_8 isatty_l8 (int *);
325 export_proto(isatty_l8);
326
327 GFC_LOGICAL_8
328 isatty_l8 (int *unit)
329 {
330   gfc_unit *u;
331   GFC_LOGICAL_8 ret = 0;
332
333   u = find_unit (*unit);
334   if (u != NULL)
335     {
336       ret = (GFC_LOGICAL_8) stream_isatty (u->s);
337       unlock_unit (u);
338     }
339   return ret;
340 }
341
342
343 /* SUBROUTINE TTYNAM(UNIT,NAME)
344    INTEGER,SCALAR,INTENT(IN) :: UNIT
345    CHARACTER,SCALAR,INTENT(OUT) :: NAME */
346
347 extern void ttynam_sub (int *, char *, gfc_charlen_type);
348 export_proto(ttynam_sub);
349
350 void
351 ttynam_sub (int *unit, char * name, gfc_charlen_type name_len)
352 {
353   gfc_unit *u;
354   char * n;
355   int i;
356
357   memset (name, ' ', name_len);
358   u = find_unit (*unit);
359   if (u != NULL)
360     {
361       n = stream_ttyname (u->s);
362       if (n != NULL)
363         {
364           i = 0;
365           while (*n && i < name_len)
366             name[i++] = *(n++);
367         }
368       unlock_unit (u);
369     }
370 }
371
372
373 extern void ttynam (char **, gfc_charlen_type *, int);
374 export_proto(ttynam);
375
376 void
377 ttynam (char ** name, gfc_charlen_type * name_len, int unit)
378 {
379   gfc_unit *u;
380
381   u = find_unit (unit);
382   if (u != NULL)
383     {
384       *name = stream_ttyname (u->s);
385       if (*name != NULL)
386         {
387           *name_len = strlen (*name);
388           *name = strdup (*name);
389           unlock_unit (u);
390           return;
391         }
392       unlock_unit (u);
393     }
394
395   *name_len = 0;
396   *name = NULL;
397 }