OSDN Git Service

9428b759d1518e5598f4cf3dc4dde39a83644e3e
[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 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 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 extern size_t PREFIX(ftell) (int *);
264 export_proto_np(PREFIX(ftell));
265
266 size_t
267 PREFIX(ftell) (int * unit)
268 {
269   gfc_unit * u = find_unit (*unit);
270   size_t ret;
271   if (u == NULL)
272     return ((size_t) -1);
273   ret = (size_t) stell (u->s);
274   unlock_unit (u);
275   return ret;
276 }
277
278 #define FTELL_SUB(kind) \
279   extern void ftell_i ## kind ## _sub (int *, GFC_INTEGER_ ## kind *); \
280   export_proto(ftell_i ## kind ## _sub); \
281   void \
282   ftell_i ## kind ## _sub (int * unit, GFC_INTEGER_ ## kind * offset) \
283   { \
284     gfc_unit * u = find_unit (*unit); \
285     if (u == NULL) \
286       *offset = -1; \
287     else \
288       { \
289         *offset = stell (u->s); \
290         unlock_unit (u); \
291       } \
292   }
293
294 FTELL_SUB(1)
295 FTELL_SUB(2)
296 FTELL_SUB(4)
297 FTELL_SUB(8)
298
299
300
301 /* LOGICAL FUNCTION ISATTY(UNIT)
302    INTEGER, INTENT(IN) :: UNIT */
303
304 extern GFC_LOGICAL_4 isatty_l4 (int *);
305 export_proto(isatty_l4);
306
307 GFC_LOGICAL_4
308 isatty_l4 (int *unit)
309 {
310   gfc_unit *u;
311   GFC_LOGICAL_4 ret = 0;
312
313   u = find_unit (*unit);
314   if (u != NULL)
315     {
316       ret = (GFC_LOGICAL_4) stream_isatty (u->s);
317       unlock_unit (u);
318     }
319   return ret;
320 }
321
322
323 extern GFC_LOGICAL_8 isatty_l8 (int *);
324 export_proto(isatty_l8);
325
326 GFC_LOGICAL_8
327 isatty_l8 (int *unit)
328 {
329   gfc_unit *u;
330   GFC_LOGICAL_8 ret = 0;
331
332   u = find_unit (*unit);
333   if (u != NULL)
334     {
335       ret = (GFC_LOGICAL_8) stream_isatty (u->s);
336       unlock_unit (u);
337     }
338   return ret;
339 }
340
341
342 /* SUBROUTINE TTYNAM(UNIT,NAME)
343    INTEGER,SCALAR,INTENT(IN) :: UNIT
344    CHARACTER,SCALAR,INTENT(OUT) :: NAME */
345
346 extern void ttynam_sub (int *, char *, gfc_charlen_type);
347 export_proto(ttynam_sub);
348
349 void
350 ttynam_sub (int *unit, char * name, gfc_charlen_type name_len)
351 {
352   gfc_unit *u;
353   char * n;
354   int i;
355
356   memset (name, ' ', name_len);
357   u = find_unit (*unit);
358   if (u != NULL)
359     {
360       n = stream_ttyname (u->s);
361       if (n != NULL)
362         {
363           i = 0;
364           while (*n && i < name_len)
365             name[i++] = *(n++);
366         }
367       unlock_unit (u);
368     }
369 }
370
371
372 extern void ttynam (char **, gfc_charlen_type *, int);
373 export_proto(ttynam);
374
375 void
376 ttynam (char ** name, gfc_charlen_type * name_len, int unit)
377 {
378   gfc_unit *u;
379
380   u = find_unit (unit);
381   if (u != NULL)
382     {
383       *name = stream_ttyname (u->s);
384       if (*name != NULL)
385         {
386           *name_len = strlen (*name);
387           *name = strdup (*name);
388           unlock_unit (u);
389           return;
390         }
391       unlock_unit (u);
392     }
393
394   *name_len = 0;
395   *name = NULL;
396 }