OSDN Git Service

2005-05-04 Thomas Koenig <Thomas.Koenig@online.de>
[pf3gnuchains/gcc-fork.git] / libgfortran / intrinsics / stat.c
1 /* Implementation of the STAT and FSTAT intrinsics.
2    Copyright (C) 2004 Free Software Foundation, Inc.
3    Contributed by Steven G. Kargl <kargls@comcast.net>.
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., 59 Temple Place - Suite 330,
29 Boston, MA 02111-1307, USA.  */
30
31 #include "config.h"
32 #include "libgfortran.h"
33
34 #ifdef HAVE_SYS_TYPES_H
35 #include <sys/types.h>
36 #endif
37
38 #ifdef HAVE_SYS_STAT_H
39 #include <sys/stat.h>
40 #endif
41
42 #ifdef HAVE_STDLIB_H
43 #include <stdlib.h>
44 #endif
45
46 #ifdef HAVE_STRING_H
47 #include <string.h>
48 #endif
49
50 #include <errno.h>
51
52 #include "../io/io.h"
53
54 /* SUBROUTINE STAT(FILE, SARRAY, STATUS)
55    CHARACTER(len=*), INTENT(IN) :: FILE
56    INTEGER, INTENT(OUT), :: SARRAY(13)
57    INTEGER, INTENT(OUT), OPTIONAL :: STATUS
58
59    FUNCTION STAT(FILE, SARRAY)
60    INTEGER STAT
61    CHARACTER(len=*), INTENT(IN) :: FILE
62    INTEGER, INTENT(OUT), :: SARRAY(13)  */
63
64 extern void stat_i4_sub (char *, gfc_array_i4 *, GFC_INTEGER_4 *,
65                          gfc_charlen_type);
66 iexport_proto(stat_i4_sub);
67
68 void
69 stat_i4_sub (char *name, gfc_array_i4 *sarray, GFC_INTEGER_4 *status,
70              gfc_charlen_type name_len)
71 {
72   int val;
73   char *str;
74   struct stat sb;
75
76   index_type stride[GFC_MAX_DIMENSIONS];
77       
78   /* If the rank of the array is not 1, abort.  */
79   if (GFC_DESCRIPTOR_RANK (sarray) != 1)
80     runtime_error ("Array rank of SARRAY is not 1.");
81
82   /* If the array is too small, abort.  */
83   if (sarray->dim[0].ubound + 1 - sarray->dim[0].lbound < 13)
84     runtime_error ("Array size of SARRAY is too small.");
85
86   if (sarray->dim[0].stride == 0)
87     sarray->dim[0].stride = 1;
88
89   /* Trim trailing spaces from name.  */
90   while (name_len > 0 && name[name_len - 1] == ' ')
91     name_len--;
92
93   /* Make a null terminated copy of the string.  */
94   str = gfc_alloca (name_len + 1);
95   memcpy (str, name, name_len);
96   str[name_len] = '\0'; 
97
98   val = stat(str, &sb);
99
100   if (val == 0) 
101     {
102       /* Device ID  */
103       sarray->data[0 * sarray->dim[0].stride] = sb.st_dev;
104
105       /* Inode number  */
106       sarray->data[1 * sarray->dim[0].stride] = sb.st_ino;
107
108       /* File mode  */
109       sarray->data[2 * sarray->dim[0].stride] = sb.st_mode;
110
111       /* Number of (hard) links  */
112       sarray->data[3 * sarray->dim[0].stride] = sb.st_nlink;
113
114       /* Owner's uid  */
115       sarray->data[4 * sarray->dim[0].stride] = sb.st_uid;
116
117       /* Owner's gid  */
118       sarray->data[5 * sarray->dim[0].stride] = sb.st_gid;
119   
120       /* ID of device containing directory entry for file (0 if not available) */
121 #if HAVE_STRUCT_STAT_ST_RDEV
122       sarray->data[6 * sarray->dim[0].stride] = sb.st_rdev;
123 #else
124       sarray->data[6 * sarray->dim[0].stride] = 0;
125 #endif
126
127       /* File size (bytes)  */
128       sarray->data[7 * sarray->dim[0].stride] = sb.st_size;
129
130       /* Last access time  */
131       sarray->data[8 * sarray->dim[0].stride] = sb.st_atime;
132
133       /* Last modification time  */
134       sarray->data[9 * sarray->dim[0].stride] = sb.st_mtime;
135
136       /* Last file status change time  */
137       sarray->data[10 * sarray->dim[0].stride] = sb.st_ctime;
138
139       /* Preferred I/O block size (-1 if not available)  */
140 #if HAVE_STRUCT_STAT_ST_BLKSIZE
141       sarray->data[11 * sarray->dim[0].stride] = sb.st_blksize;
142 #else
143       sarray->data[11 * sarray->dim[0].stride] = -1;
144 #endif
145
146       /* Number of blocks allocated (-1 if not available)  */
147 #if HAVE_STRUCT_STAT_ST_BLOCKS
148       sarray->data[12 * sarray->dim[0].stride] = sb.st_blocks;
149 #else
150       sarray->data[12 * sarray->dim[0].stride] = -1;
151 #endif
152     }
153
154   if (status != NULL) 
155     *status = (val == 0) ? 0 : errno;
156 }
157 iexport(stat_i4_sub);
158
159 extern void stat_i8_sub (char *, gfc_array_i8 *, GFC_INTEGER_8 *,
160                          gfc_charlen_type);
161 iexport_proto(stat_i8_sub);
162
163 void
164 stat_i8_sub (char *name, gfc_array_i8 *sarray, GFC_INTEGER_8 *status,
165              gfc_charlen_type name_len)
166 {
167   int val;
168   char *str;
169   struct stat sb;
170
171   index_type stride[GFC_MAX_DIMENSIONS];
172       
173   /* If the rank of the array is not 1, abort.  */
174   if (GFC_DESCRIPTOR_RANK (sarray) != 1)
175     runtime_error ("Array rank of SARRAY is not 1.");
176
177   /* If the array is too small, abort.  */
178   if (sarray->dim[0].ubound + 1 - sarray->dim[0].lbound < 13)
179     runtime_error ("Array size of SARRAY is too small.");
180
181   if (sarray->dim[0].stride == 0)
182     sarray->dim[0].stride = 1;
183
184   /* Trim trailing spaces from name.  */
185   while (name_len > 0 && name[name_len - 1] == ' ')
186     name_len--;
187
188   /* Make a null terminated copy of the string.  */
189   str = gfc_alloca (name_len + 1);
190   memcpy (str, name, name_len);
191   str[name_len] = '\0'; 
192
193   val = stat(str, &sb);
194
195   if (val == 0)
196     {
197       /* Device ID  */
198       sarray->data[0] = sb.st_dev;
199
200       /* Inode number  */
201       sarray->data[sarray->dim[0].stride] = sb.st_ino;
202
203       /* File mode  */
204       sarray->data[2 * sarray->dim[0].stride] = sb.st_mode;
205
206       /* Number of (hard) links  */
207       sarray->data[3 * sarray->dim[0].stride] = sb.st_nlink;
208   
209       /* Owner's uid  */
210       sarray->data[4 * sarray->dim[0].stride] = sb.st_uid;
211
212       /* Owner's gid  */
213       sarray->data[5 * sarray->dim[0].stride] = sb.st_gid;
214   
215       /* ID of device containing directory entry for file (0 if not available) */
216 #if HAVE_STRUCT_STAT_ST_RDEV
217       sarray->data[6 * sarray->dim[0].stride] = sb.st_rdev;
218 #else
219       sarray->data[6 * sarray->dim[0].stride] = 0;
220 #endif
221
222       /* File size (bytes)  */
223       sarray->data[7 * sarray->dim[0].stride] = sb.st_size;
224
225       /* Last access time  */
226       sarray->data[8 * sarray->dim[0].stride] = sb.st_atime;
227
228       /* Last modification time  */
229       sarray->data[9 * sarray->dim[0].stride] = sb.st_mtime;
230
231       /* Last file status change time  */
232       sarray->data[10 * sarray->dim[0].stride] = sb.st_ctime;
233
234       /* Preferred I/O block size (-1 if not available)  */
235 #if HAVE_STRUCT_STAT_ST_BLKSIZE
236       sarray->data[11 * sarray->dim[0].stride] = sb.st_blksize;
237 #else
238       sarray->data[11 * sarray->dim[0].stride] = -1;
239 #endif
240
241       /* Number of blocks allocated (-1 if not available)  */
242 #if HAVE_STRUCT_STAT_ST_BLOCKS
243       sarray->data[12 * sarray->dim[0].stride] = sb.st_blocks;
244 #else
245       sarray->data[12 * sarray->dim[0].stride] = -1;
246 #endif
247     }
248
249   if (status != NULL) 
250     *status = (val == 0) ? 0 : errno;
251 }
252 iexport(stat_i8_sub);
253
254 extern GFC_INTEGER_4 stat_i4 (char *, gfc_array_i4 *, gfc_charlen_type);
255 export_proto(stat_i4);
256
257 GFC_INTEGER_4
258 stat_i4 (char *name, gfc_array_i4 *sarray, gfc_charlen_type name_len)
259 {
260   GFC_INTEGER_4 val;
261   stat_i4_sub (name, sarray, &val, name_len);
262   return val;
263 }
264
265 extern GFC_INTEGER_8 stat_i8 (char *, gfc_array_i8 *, gfc_charlen_type);
266 export_proto(stat_i8);
267
268 GFC_INTEGER_8
269 stat_i8 (char *name, gfc_array_i8 *sarray, gfc_charlen_type name_len)
270 {
271   GFC_INTEGER_8 val;
272   stat_i8_sub (name, sarray, &val, name_len);
273   return val;
274 }
275
276
277 /* SUBROUTINE FSTAT(UNIT, SARRAY, STATUS)
278    INTEGER, INTENT(IN) :: UNIT 
279    INTEGER, INTENT(OUT) :: SARRAY(13)
280    INTEGER, INTENT(OUT), OPTIONAL :: STATUS 
281
282    FUNCTION FSTAT(UNIT, SARRAY)
283    INTEGER FSTAT
284    INTEGER, INTENT(IN) :: UNIT 
285    INTEGER, INTENT(OUT) :: SARRAY(13)  */
286
287 extern void fstat_i4_sub (GFC_INTEGER_4 *, gfc_array_i4 *, GFC_INTEGER_4 *);
288 iexport_proto(fstat_i4_sub);
289
290 void
291 fstat_i4_sub (GFC_INTEGER_4 *unit, gfc_array_i4 *sarray, GFC_INTEGER_4 *status)
292 {
293   int val;
294   struct stat sb;
295
296   index_type stride[GFC_MAX_DIMENSIONS];
297       
298   /* If the rank of the array is not 1, abort.  */
299   if (GFC_DESCRIPTOR_RANK (sarray) != 1)
300     runtime_error ("Array rank of SARRAY is not 1.");
301
302   /* If the array is too small, abort.  */
303   if (sarray->dim[0].ubound + 1 - sarray->dim[0].lbound < 13)
304     runtime_error ("Array size of SARRAY is too small.");
305
306   if (sarray->dim[0].stride == 0)
307     sarray->dim[0].stride = 1;
308
309   /* Convert Fortran unit number to C file descriptor.  */
310   val = unit_to_fd (*unit);
311   if (val >= 0)
312     val = fstat(val, &sb);
313
314   if (val == 0)
315     {
316       /* Device ID  */
317       sarray->data[0 * sarray->dim[0].stride] = sb.st_dev;
318
319       /* Inode number  */
320       sarray->data[1 * sarray->dim[0].stride] = sb.st_ino;
321   
322       /* File mode  */
323       sarray->data[2 * sarray->dim[0].stride] = sb.st_mode;
324
325       /* Number of (hard) links  */
326       sarray->data[3 * sarray->dim[0].stride] = sb.st_nlink;
327
328       /* Owner's uid  */
329       sarray->data[4 * sarray->dim[0].stride] = sb.st_uid;
330
331       /* Owner's gid  */
332       sarray->data[5 * sarray->dim[0].stride] = sb.st_gid;
333   
334       /* ID of device containing directory entry for file (0 if not available) */
335 #if HAVE_STRUCT_STAT_ST_RDEV
336       sarray->data[6 * sarray->dim[0].stride] = sb.st_rdev;
337 #else
338       sarray->data[6 * sarray->dim[0].stride] = 0;
339 #endif
340
341       /* File size (bytes)  */
342       sarray->data[7 * sarray->dim[0].stride] = sb.st_size;
343
344       /* Last access time  */
345       sarray->data[8 * sarray->dim[0].stride] = sb.st_atime;
346
347       /* Last modification time  */
348       sarray->data[9 * sarray->dim[0].stride] = sb.st_mtime;
349
350       /* Last file status change time  */
351       sarray->data[10 * sarray->dim[0].stride] = sb.st_ctime;
352
353       /* Preferred I/O block size (-1 if not available)  */
354 #if HAVE_STRUCT_STAT_ST_BLKSIZE
355       sarray->data[11 * sarray->dim[0].stride] = sb.st_blksize;
356 #else
357       sarray->data[11 * sarray->dim[0].stride] = -1;
358 #endif
359
360       /* Number of blocks allocated (-1 if not available)  */
361 #if HAVE_STRUCT_STAT_ST_BLOCKS
362       sarray->data[12 * sarray->dim[0].stride] = sb.st_blocks;
363 #else
364       sarray->data[12 * sarray->dim[0].stride] = -1;
365 #endif
366     }
367
368   if (status != NULL) 
369     *status = (val == 0) ? 0 : errno;
370 }
371 iexport(fstat_i4_sub);
372
373 extern void fstat_i8_sub (GFC_INTEGER_8 *, gfc_array_i8 *, GFC_INTEGER_8 *);
374 iexport_proto(fstat_i8_sub);
375
376 void
377 fstat_i8_sub (GFC_INTEGER_8 *unit, gfc_array_i8 *sarray, GFC_INTEGER_8 *status)
378 {
379   int val;
380   struct stat sb;
381
382   index_type stride[GFC_MAX_DIMENSIONS];
383       
384   /* If the rank of the array is not 1, abort.  */
385   if (GFC_DESCRIPTOR_RANK (sarray) != 1)
386     runtime_error ("Array rank of SARRAY is not 1.");
387
388   /* If the array is too small, abort.  */
389   if (sarray->dim[0].ubound + 1 - sarray->dim[0].lbound < 13)
390     runtime_error ("Array size of SARRAY is too small.");
391
392   if (sarray->dim[0].stride == 0)
393     sarray->dim[0].stride = 1;
394
395   /* Convert Fortran unit number to C file descriptor.  */
396   val = unit_to_fd ((int) *unit);
397   if (val >= 0)
398     val = fstat(val, &sb);
399
400   if (val == 0)
401     {
402       /* Device ID  */
403       sarray->data[0] = sb.st_dev;
404
405       /* Inode number  */
406       sarray->data[sarray->dim[0].stride] = sb.st_ino;
407
408       /* File mode  */
409       sarray->data[2 * sarray->dim[0].stride] = sb.st_mode;
410
411       /* Number of (hard) links  */
412       sarray->data[3 * sarray->dim[0].stride] = sb.st_nlink;
413
414       /* Owner's uid  */
415       sarray->data[4 * sarray->dim[0].stride] = sb.st_uid;
416
417       /* Owner's gid  */
418       sarray->data[5 * sarray->dim[0].stride] = sb.st_gid;
419   
420       /* ID of device containing directory entry for file (0 if not available) */
421 #if HAVE_STRUCT_STAT_ST_RDEV
422       sarray->data[6 * sarray->dim[0].stride] = sb.st_rdev;
423 #else
424       sarray->data[6 * sarray->dim[0].stride] = 0;
425 #endif
426
427       /* File size (bytes)  */
428       sarray->data[7 * sarray->dim[0].stride] = sb.st_size;
429
430       /* Last access time  */
431       sarray->data[8 * sarray->dim[0].stride] = sb.st_atime;
432
433       /* Last modification time  */
434       sarray->data[9 * sarray->dim[0].stride] = sb.st_mtime;
435
436       /* Last file status change time  */
437       sarray->data[10 * sarray->dim[0].stride] = sb.st_ctime;
438
439       /* Preferred I/O block size (-1 if not available)  */
440 #if HAVE_STRUCT_STAT_ST_BLKSIZE
441       sarray->data[11 * sarray->dim[0].stride] = sb.st_blksize;
442 #else
443       sarray->data[11 * sarray->dim[0].stride] = -1;
444 #endif
445
446       /* Number of blocks allocated (-1 if not available)  */
447 #if HAVE_STRUCT_STAT_ST_BLOCKS
448       sarray->data[12 * sarray->dim[0].stride] = sb.st_blocks;
449 #else
450       sarray->data[12 * sarray->dim[0].stride] = -1;
451 #endif
452     }
453
454   if (status != NULL) 
455     *status = (val == 0) ? 0 : errno;
456 }
457 iexport(fstat_i8_sub);
458
459 extern GFC_INTEGER_4 fstat_i4 (GFC_INTEGER_4 *, gfc_array_i4 *);
460 export_proto(fstat_i4);
461
462 GFC_INTEGER_4
463 fstat_i4 (GFC_INTEGER_4 *unit, gfc_array_i4 *sarray)
464 {
465   GFC_INTEGER_4 val;
466   fstat_i4_sub (unit, sarray, &val);
467   return val;
468 }
469
470 extern GFC_INTEGER_8 fstat_i8 (GFC_INTEGER_8 *, gfc_array_i8 *);
471 export_proto(fstat_i8);
472
473 GFC_INTEGER_8
474 fstat_i8 (GFC_INTEGER_8 *unit, gfc_array_i8 *sarray)
475 {
476   GFC_INTEGER_8 val;
477   fstat_i8_sub (unit, sarray, &val);
478   return val;
479 }