1 /* Implementation of the STAT and FSTAT intrinsics.
2 Copyright (C) 2004, 2005, 2006, 2007, 2009 Free Software Foundation, Inc.
3 Contributed by Steven G. Kargl <kargls@comcast.net>.
5 This file is part of the GNU Fortran 95 runtime library (libgfortran).
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.
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.
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.
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/>. */
26 #include "libgfortran.h"
31 #ifdef HAVE_SYS_STAT_H
42 /* SUBROUTINE STAT(FILE, SARRAY, STATUS)
43 CHARACTER(len=*), INTENT(IN) :: FILE
44 INTEGER, INTENT(OUT), :: SARRAY(13)
45 INTEGER, INTENT(OUT), OPTIONAL :: STATUS
47 FUNCTION STAT(FILE, SARRAY)
49 CHARACTER(len=*), INTENT(IN) :: FILE
50 INTEGER, INTENT(OUT), :: SARRAY(13) */
52 /*extern void stat_i4_sub_0 (char *, gfc_array_i4 *, GFC_INTEGER_4 *,
53 gfc_charlen_type, int);
54 internal_proto(stat_i4_sub_0);*/
57 stat_i4_sub_0 (char *name
, gfc_array_i4
*sarray
, GFC_INTEGER_4
*status
,
58 gfc_charlen_type name_len
, int is_lstat
__attribute__ ((unused
)))
64 /* If the rank of the array is not 1, abort. */
65 if (GFC_DESCRIPTOR_RANK (sarray
) != 1)
66 runtime_error ("Array rank of SARRAY is not 1.");
68 /* If the array is too small, abort. */
69 if (GFC_DESCRIPTOR_EXTENT(sarray
,0) < 13)
70 runtime_error ("Array size of SARRAY is too small.");
72 /* Trim trailing spaces from name. */
73 while (name_len
> 0 && name
[name_len
- 1] == ' ')
76 /* Make a null terminated copy of the string. */
77 str
= gfc_alloca (name_len
+ 1);
78 memcpy (str
, name
, name_len
);
81 /* On platforms that don't provide lstat(), we use stat() instead. */
84 val
= lstat(str
, &sb
);
91 index_type stride
= GFC_DESCRIPTOR_STRIDE(sarray
,0);
94 sarray
->data
[0 * stride
] = sb
.st_dev
;
97 sarray
->data
[1 * stride
] = sb
.st_ino
;
100 sarray
->data
[2 * stride
] = sb
.st_mode
;
102 /* Number of (hard) links */
103 sarray
->data
[3 * stride
] = sb
.st_nlink
;
106 sarray
->data
[4 * stride
] = sb
.st_uid
;
109 sarray
->data
[5 * stride
] = sb
.st_gid
;
111 /* ID of device containing directory entry for file (0 if not available) */
112 #if HAVE_STRUCT_STAT_ST_RDEV
113 sarray
->data
[6 * stride
] = sb
.st_rdev
;
115 sarray
->data
[6 * stride
] = 0;
118 /* File size (bytes) */
119 sarray
->data
[7 * stride
] = sb
.st_size
;
121 /* Last access time */
122 sarray
->data
[8 * stride
] = sb
.st_atime
;
124 /* Last modification time */
125 sarray
->data
[9 * stride
] = sb
.st_mtime
;
127 /* Last file status change time */
128 sarray
->data
[10 * stride
] = sb
.st_ctime
;
130 /* Preferred I/O block size (-1 if not available) */
131 #if HAVE_STRUCT_STAT_ST_BLKSIZE
132 sarray
->data
[11 * stride
] = sb
.st_blksize
;
134 sarray
->data
[11 * stride
] = -1;
137 /* Number of blocks allocated (-1 if not available) */
138 #if HAVE_STRUCT_STAT_ST_BLOCKS
139 sarray
->data
[12 * stride
] = sb
.st_blocks
;
141 sarray
->data
[12 * stride
] = -1;
146 *status
= (val
== 0) ? 0 : errno
;
150 extern void stat_i4_sub (char *, gfc_array_i4
*, GFC_INTEGER_4
*,
152 iexport_proto(stat_i4_sub
);
155 stat_i4_sub (char *name
, gfc_array_i4
*sarray
, GFC_INTEGER_4
*status
,
156 gfc_charlen_type name_len
)
158 stat_i4_sub_0 (name
, sarray
, status
, name_len
, 0);
160 iexport(stat_i4_sub
);
163 extern void lstat_i4_sub (char *, gfc_array_i4
*, GFC_INTEGER_4
*,
165 iexport_proto(lstat_i4_sub
);
168 lstat_i4_sub (char *name
, gfc_array_i4
*sarray
, GFC_INTEGER_4
*status
,
169 gfc_charlen_type name_len
)
171 stat_i4_sub_0 (name
, sarray
, status
, name_len
, 1);
173 iexport(lstat_i4_sub
);
178 stat_i8_sub_0 (char *name
, gfc_array_i8
*sarray
, GFC_INTEGER_8
*status
,
179 gfc_charlen_type name_len
, int is_lstat
__attribute__ ((unused
)))
185 /* If the rank of the array is not 1, abort. */
186 if (GFC_DESCRIPTOR_RANK (sarray
) != 1)
187 runtime_error ("Array rank of SARRAY is not 1.");
189 /* If the array is too small, abort. */
190 if (GFC_DESCRIPTOR_EXTENT(sarray
,0) < 13)
191 runtime_error ("Array size of SARRAY is too small.");
193 /* Trim trailing spaces from name. */
194 while (name_len
> 0 && name
[name_len
- 1] == ' ')
197 /* Make a null terminated copy of the string. */
198 str
= gfc_alloca (name_len
+ 1);
199 memcpy (str
, name
, name_len
);
200 str
[name_len
] = '\0';
202 /* On platforms that don't provide lstat(), we use stat() instead. */
205 val
= lstat(str
, &sb
);
208 val
= stat(str
, &sb
);
212 index_type stride
= GFC_DESCRIPTOR_STRIDE(sarray
,0);
215 sarray
->data
[0] = sb
.st_dev
;
218 sarray
->data
[stride
] = sb
.st_ino
;
221 sarray
->data
[2 * stride
] = sb
.st_mode
;
223 /* Number of (hard) links */
224 sarray
->data
[3 * stride
] = sb
.st_nlink
;
227 sarray
->data
[4 * stride
] = sb
.st_uid
;
230 sarray
->data
[5 * stride
] = sb
.st_gid
;
232 /* ID of device containing directory entry for file (0 if not available) */
233 #if HAVE_STRUCT_STAT_ST_RDEV
234 sarray
->data
[6 * stride
] = sb
.st_rdev
;
236 sarray
->data
[6 * stride
] = 0;
239 /* File size (bytes) */
240 sarray
->data
[7 * stride
] = sb
.st_size
;
242 /* Last access time */
243 sarray
->data
[8 * stride
] = sb
.st_atime
;
245 /* Last modification time */
246 sarray
->data
[9 * stride
] = sb
.st_mtime
;
248 /* Last file status change time */
249 sarray
->data
[10 * stride
] = sb
.st_ctime
;
251 /* Preferred I/O block size (-1 if not available) */
252 #if HAVE_STRUCT_STAT_ST_BLKSIZE
253 sarray
->data
[11 * stride
] = sb
.st_blksize
;
255 sarray
->data
[11 * stride
] = -1;
258 /* Number of blocks allocated (-1 if not available) */
259 #if HAVE_STRUCT_STAT_ST_BLOCKS
260 sarray
->data
[12 * stride
] = sb
.st_blocks
;
262 sarray
->data
[12 * stride
] = -1;
267 *status
= (val
== 0) ? 0 : errno
;
271 extern void stat_i8_sub (char *, gfc_array_i8
*, GFC_INTEGER_8
*,
273 iexport_proto(stat_i8_sub
);
276 stat_i8_sub (char *name
, gfc_array_i8
*sarray
, GFC_INTEGER_8
*status
,
277 gfc_charlen_type name_len
)
279 stat_i8_sub_0 (name
, sarray
, status
, name_len
, 0);
282 iexport(stat_i8_sub
);
285 extern void lstat_i8_sub (char *, gfc_array_i8
*, GFC_INTEGER_8
*,
287 iexport_proto(lstat_i8_sub
);
290 lstat_i8_sub (char *name
, gfc_array_i8
*sarray
, GFC_INTEGER_8
*status
,
291 gfc_charlen_type name_len
)
293 stat_i8_sub_0 (name
, sarray
, status
, name_len
, 1);
296 iexport(lstat_i8_sub
);
299 extern GFC_INTEGER_4
stat_i4 (char *, gfc_array_i4
*, gfc_charlen_type
);
300 export_proto(stat_i4
);
303 stat_i4 (char *name
, gfc_array_i4
*sarray
, gfc_charlen_type name_len
)
306 stat_i4_sub (name
, sarray
, &val
, name_len
);
310 extern GFC_INTEGER_8
stat_i8 (char *, gfc_array_i8
*, gfc_charlen_type
);
311 export_proto(stat_i8
);
314 stat_i8 (char *name
, gfc_array_i8
*sarray
, gfc_charlen_type name_len
)
317 stat_i8_sub (name
, sarray
, &val
, name_len
);
322 /* SUBROUTINE LSTAT(FILE, SARRAY, STATUS)
323 CHARACTER(len=*), INTENT(IN) :: FILE
324 INTEGER, INTENT(OUT), :: SARRAY(13)
325 INTEGER, INTENT(OUT), OPTIONAL :: STATUS
327 FUNCTION LSTAT(FILE, SARRAY)
329 CHARACTER(len=*), INTENT(IN) :: FILE
330 INTEGER, INTENT(OUT), :: SARRAY(13) */
332 extern GFC_INTEGER_4
lstat_i4 (char *, gfc_array_i4
*, gfc_charlen_type
);
333 export_proto(lstat_i4
);
336 lstat_i4 (char *name
, gfc_array_i4
*sarray
, gfc_charlen_type name_len
)
339 lstat_i4_sub (name
, sarray
, &val
, name_len
);
343 extern GFC_INTEGER_8
lstat_i8 (char *, gfc_array_i8
*, gfc_charlen_type
);
344 export_proto(lstat_i8
);
347 lstat_i8 (char *name
, gfc_array_i8
*sarray
, gfc_charlen_type name_len
)
350 lstat_i8_sub (name
, sarray
, &val
, name_len
);
359 /* SUBROUTINE FSTAT(UNIT, SARRAY, STATUS)
360 INTEGER, INTENT(IN) :: UNIT
361 INTEGER, INTENT(OUT) :: SARRAY(13)
362 INTEGER, INTENT(OUT), OPTIONAL :: STATUS
364 FUNCTION FSTAT(UNIT, SARRAY)
366 INTEGER, INTENT(IN) :: UNIT
367 INTEGER, INTENT(OUT) :: SARRAY(13) */
369 extern void fstat_i4_sub (GFC_INTEGER_4
*, gfc_array_i4
*, GFC_INTEGER_4
*);
370 iexport_proto(fstat_i4_sub
);
373 fstat_i4_sub (GFC_INTEGER_4
*unit
, gfc_array_i4
*sarray
, GFC_INTEGER_4
*status
)
378 /* If the rank of the array is not 1, abort. */
379 if (GFC_DESCRIPTOR_RANK (sarray
) != 1)
380 runtime_error ("Array rank of SARRAY is not 1.");
382 /* If the array is too small, abort. */
383 if (GFC_DESCRIPTOR_EXTENT(sarray
,0) < 13)
384 runtime_error ("Array size of SARRAY is too small.");
386 /* Convert Fortran unit number to C file descriptor. */
387 val
= unit_to_fd (*unit
);
389 val
= fstat(val
, &sb
);
393 index_type stride
= GFC_DESCRIPTOR_STRIDE(sarray
,0);
396 sarray
->data
[0 * stride
] = sb
.st_dev
;
399 sarray
->data
[1 * stride
] = sb
.st_ino
;
402 sarray
->data
[2 * stride
] = sb
.st_mode
;
404 /* Number of (hard) links */
405 sarray
->data
[3 * stride
] = sb
.st_nlink
;
408 sarray
->data
[4 * stride
] = sb
.st_uid
;
411 sarray
->data
[5 * stride
] = sb
.st_gid
;
413 /* ID of device containing directory entry for file (0 if not available) */
414 #if HAVE_STRUCT_STAT_ST_RDEV
415 sarray
->data
[6 * stride
] = sb
.st_rdev
;
417 sarray
->data
[6 * stride
] = 0;
420 /* File size (bytes) */
421 sarray
->data
[7 * stride
] = sb
.st_size
;
423 /* Last access time */
424 sarray
->data
[8 * stride
] = sb
.st_atime
;
426 /* Last modification time */
427 sarray
->data
[9 * stride
] = sb
.st_mtime
;
429 /* Last file status change time */
430 sarray
->data
[10 * stride
] = sb
.st_ctime
;
432 /* Preferred I/O block size (-1 if not available) */
433 #if HAVE_STRUCT_STAT_ST_BLKSIZE
434 sarray
->data
[11 * stride
] = sb
.st_blksize
;
436 sarray
->data
[11 * stride
] = -1;
439 /* Number of blocks allocated (-1 if not available) */
440 #if HAVE_STRUCT_STAT_ST_BLOCKS
441 sarray
->data
[12 * stride
] = sb
.st_blocks
;
443 sarray
->data
[12 * stride
] = -1;
448 *status
= (val
== 0) ? 0 : errno
;
450 iexport(fstat_i4_sub
);
452 extern void fstat_i8_sub (GFC_INTEGER_8
*, gfc_array_i8
*, GFC_INTEGER_8
*);
453 iexport_proto(fstat_i8_sub
);
456 fstat_i8_sub (GFC_INTEGER_8
*unit
, gfc_array_i8
*sarray
, GFC_INTEGER_8
*status
)
461 /* If the rank of the array is not 1, abort. */
462 if (GFC_DESCRIPTOR_RANK (sarray
) != 1)
463 runtime_error ("Array rank of SARRAY is not 1.");
465 /* If the array is too small, abort. */
466 if (GFC_DESCRIPTOR_EXTENT(sarray
,0) < 13)
467 runtime_error ("Array size of SARRAY is too small.");
469 /* Convert Fortran unit number to C file descriptor. */
470 val
= unit_to_fd ((int) *unit
);
472 val
= fstat(val
, &sb
);
476 index_type stride
= GFC_DESCRIPTOR_STRIDE(sarray
,0);
479 sarray
->data
[0] = sb
.st_dev
;
482 sarray
->data
[stride
] = sb
.st_ino
;
485 sarray
->data
[2 * stride
] = sb
.st_mode
;
487 /* Number of (hard) links */
488 sarray
->data
[3 * stride
] = sb
.st_nlink
;
491 sarray
->data
[4 * stride
] = sb
.st_uid
;
494 sarray
->data
[5 * stride
] = sb
.st_gid
;
496 /* ID of device containing directory entry for file (0 if not available) */
497 #if HAVE_STRUCT_STAT_ST_RDEV
498 sarray
->data
[6 * stride
] = sb
.st_rdev
;
500 sarray
->data
[6 * stride
] = 0;
503 /* File size (bytes) */
504 sarray
->data
[7 * stride
] = sb
.st_size
;
506 /* Last access time */
507 sarray
->data
[8 * stride
] = sb
.st_atime
;
509 /* Last modification time */
510 sarray
->data
[9 * stride
] = sb
.st_mtime
;
512 /* Last file status change time */
513 sarray
->data
[10 * stride
] = sb
.st_ctime
;
515 /* Preferred I/O block size (-1 if not available) */
516 #if HAVE_STRUCT_STAT_ST_BLKSIZE
517 sarray
->data
[11 * stride
] = sb
.st_blksize
;
519 sarray
->data
[11 * stride
] = -1;
522 /* Number of blocks allocated (-1 if not available) */
523 #if HAVE_STRUCT_STAT_ST_BLOCKS
524 sarray
->data
[12 * stride
] = sb
.st_blocks
;
526 sarray
->data
[12 * stride
] = -1;
531 *status
= (val
== 0) ? 0 : errno
;
533 iexport(fstat_i8_sub
);
535 extern GFC_INTEGER_4
fstat_i4 (GFC_INTEGER_4
*, gfc_array_i4
*);
536 export_proto(fstat_i4
);
539 fstat_i4 (GFC_INTEGER_4
*unit
, gfc_array_i4
*sarray
)
542 fstat_i4_sub (unit
, sarray
, &val
);
546 extern GFC_INTEGER_8
fstat_i8 (GFC_INTEGER_8
*, gfc_array_i8
*);
547 export_proto(fstat_i8
);
550 fstat_i8 (GFC_INTEGER_8
*unit
, gfc_array_i8
*sarray
)
553 fstat_i8_sub (unit
, sarray
, &val
);