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 (sarray
->dim
[0].ubound
+ 1 - sarray
->dim
[0].lbound
< 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
);
92 sarray
->data
[0 * sarray
->dim
[0].stride
] = sb
.st_dev
;
95 sarray
->data
[1 * sarray
->dim
[0].stride
] = sb
.st_ino
;
98 sarray
->data
[2 * sarray
->dim
[0].stride
] = sb
.st_mode
;
100 /* Number of (hard) links */
101 sarray
->data
[3 * sarray
->dim
[0].stride
] = sb
.st_nlink
;
104 sarray
->data
[4 * sarray
->dim
[0].stride
] = sb
.st_uid
;
107 sarray
->data
[5 * sarray
->dim
[0].stride
] = sb
.st_gid
;
109 /* ID of device containing directory entry for file (0 if not available) */
110 #if HAVE_STRUCT_STAT_ST_RDEV
111 sarray
->data
[6 * sarray
->dim
[0].stride
] = sb
.st_rdev
;
113 sarray
->data
[6 * sarray
->dim
[0].stride
] = 0;
116 /* File size (bytes) */
117 sarray
->data
[7 * sarray
->dim
[0].stride
] = sb
.st_size
;
119 /* Last access time */
120 sarray
->data
[8 * sarray
->dim
[0].stride
] = sb
.st_atime
;
122 /* Last modification time */
123 sarray
->data
[9 * sarray
->dim
[0].stride
] = sb
.st_mtime
;
125 /* Last file status change time */
126 sarray
->data
[10 * sarray
->dim
[0].stride
] = sb
.st_ctime
;
128 /* Preferred I/O block size (-1 if not available) */
129 #if HAVE_STRUCT_STAT_ST_BLKSIZE
130 sarray
->data
[11 * sarray
->dim
[0].stride
] = sb
.st_blksize
;
132 sarray
->data
[11 * sarray
->dim
[0].stride
] = -1;
135 /* Number of blocks allocated (-1 if not available) */
136 #if HAVE_STRUCT_STAT_ST_BLOCKS
137 sarray
->data
[12 * sarray
->dim
[0].stride
] = sb
.st_blocks
;
139 sarray
->data
[12 * sarray
->dim
[0].stride
] = -1;
144 *status
= (val
== 0) ? 0 : errno
;
148 extern void stat_i4_sub (char *, gfc_array_i4
*, GFC_INTEGER_4
*,
150 iexport_proto(stat_i4_sub
);
153 stat_i4_sub (char *name
, gfc_array_i4
*sarray
, GFC_INTEGER_4
*status
,
154 gfc_charlen_type name_len
)
156 stat_i4_sub_0 (name
, sarray
, status
, name_len
, 0);
158 iexport(stat_i4_sub
);
161 extern void lstat_i4_sub (char *, gfc_array_i4
*, GFC_INTEGER_4
*,
163 iexport_proto(lstat_i4_sub
);
166 lstat_i4_sub (char *name
, gfc_array_i4
*sarray
, GFC_INTEGER_4
*status
,
167 gfc_charlen_type name_len
)
169 stat_i4_sub_0 (name
, sarray
, status
, name_len
, 1);
171 iexport(lstat_i4_sub
);
176 stat_i8_sub_0 (char *name
, gfc_array_i8
*sarray
, GFC_INTEGER_8
*status
,
177 gfc_charlen_type name_len
, int is_lstat
__attribute__ ((unused
)))
183 /* If the rank of the array is not 1, abort. */
184 if (GFC_DESCRIPTOR_RANK (sarray
) != 1)
185 runtime_error ("Array rank of SARRAY is not 1.");
187 /* If the array is too small, abort. */
188 if (sarray
->dim
[0].ubound
+ 1 - sarray
->dim
[0].lbound
< 13)
189 runtime_error ("Array size of SARRAY is too small.");
191 /* Trim trailing spaces from name. */
192 while (name_len
> 0 && name
[name_len
- 1] == ' ')
195 /* Make a null terminated copy of the string. */
196 str
= gfc_alloca (name_len
+ 1);
197 memcpy (str
, name
, name_len
);
198 str
[name_len
] = '\0';
200 /* On platforms that don't provide lstat(), we use stat() instead. */
203 val
= lstat(str
, &sb
);
206 val
= stat(str
, &sb
);
211 sarray
->data
[0] = sb
.st_dev
;
214 sarray
->data
[sarray
->dim
[0].stride
] = sb
.st_ino
;
217 sarray
->data
[2 * sarray
->dim
[0].stride
] = sb
.st_mode
;
219 /* Number of (hard) links */
220 sarray
->data
[3 * sarray
->dim
[0].stride
] = sb
.st_nlink
;
223 sarray
->data
[4 * sarray
->dim
[0].stride
] = sb
.st_uid
;
226 sarray
->data
[5 * sarray
->dim
[0].stride
] = sb
.st_gid
;
228 /* ID of device containing directory entry for file (0 if not available) */
229 #if HAVE_STRUCT_STAT_ST_RDEV
230 sarray
->data
[6 * sarray
->dim
[0].stride
] = sb
.st_rdev
;
232 sarray
->data
[6 * sarray
->dim
[0].stride
] = 0;
235 /* File size (bytes) */
236 sarray
->data
[7 * sarray
->dim
[0].stride
] = sb
.st_size
;
238 /* Last access time */
239 sarray
->data
[8 * sarray
->dim
[0].stride
] = sb
.st_atime
;
241 /* Last modification time */
242 sarray
->data
[9 * sarray
->dim
[0].stride
] = sb
.st_mtime
;
244 /* Last file status change time */
245 sarray
->data
[10 * sarray
->dim
[0].stride
] = sb
.st_ctime
;
247 /* Preferred I/O block size (-1 if not available) */
248 #if HAVE_STRUCT_STAT_ST_BLKSIZE
249 sarray
->data
[11 * sarray
->dim
[0].stride
] = sb
.st_blksize
;
251 sarray
->data
[11 * sarray
->dim
[0].stride
] = -1;
254 /* Number of blocks allocated (-1 if not available) */
255 #if HAVE_STRUCT_STAT_ST_BLOCKS
256 sarray
->data
[12 * sarray
->dim
[0].stride
] = sb
.st_blocks
;
258 sarray
->data
[12 * sarray
->dim
[0].stride
] = -1;
263 *status
= (val
== 0) ? 0 : errno
;
267 extern void stat_i8_sub (char *, gfc_array_i8
*, GFC_INTEGER_8
*,
269 iexport_proto(stat_i8_sub
);
272 stat_i8_sub (char *name
, gfc_array_i8
*sarray
, GFC_INTEGER_8
*status
,
273 gfc_charlen_type name_len
)
275 stat_i8_sub_0 (name
, sarray
, status
, name_len
, 0);
278 iexport(stat_i8_sub
);
281 extern void lstat_i8_sub (char *, gfc_array_i8
*, GFC_INTEGER_8
*,
283 iexport_proto(lstat_i8_sub
);
286 lstat_i8_sub (char *name
, gfc_array_i8
*sarray
, GFC_INTEGER_8
*status
,
287 gfc_charlen_type name_len
)
289 stat_i8_sub_0 (name
, sarray
, status
, name_len
, 1);
292 iexport(lstat_i8_sub
);
295 extern GFC_INTEGER_4
stat_i4 (char *, gfc_array_i4
*, gfc_charlen_type
);
296 export_proto(stat_i4
);
299 stat_i4 (char *name
, gfc_array_i4
*sarray
, gfc_charlen_type name_len
)
302 stat_i4_sub (name
, sarray
, &val
, name_len
);
306 extern GFC_INTEGER_8
stat_i8 (char *, gfc_array_i8
*, gfc_charlen_type
);
307 export_proto(stat_i8
);
310 stat_i8 (char *name
, gfc_array_i8
*sarray
, gfc_charlen_type name_len
)
313 stat_i8_sub (name
, sarray
, &val
, name_len
);
318 /* SUBROUTINE LSTAT(FILE, SARRAY, STATUS)
319 CHARACTER(len=*), INTENT(IN) :: FILE
320 INTEGER, INTENT(OUT), :: SARRAY(13)
321 INTEGER, INTENT(OUT), OPTIONAL :: STATUS
323 FUNCTION LSTAT(FILE, SARRAY)
325 CHARACTER(len=*), INTENT(IN) :: FILE
326 INTEGER, INTENT(OUT), :: SARRAY(13) */
328 extern GFC_INTEGER_4
lstat_i4 (char *, gfc_array_i4
*, gfc_charlen_type
);
329 export_proto(lstat_i4
);
332 lstat_i4 (char *name
, gfc_array_i4
*sarray
, gfc_charlen_type name_len
)
335 lstat_i4_sub (name
, sarray
, &val
, name_len
);
339 extern GFC_INTEGER_8
lstat_i8 (char *, gfc_array_i8
*, gfc_charlen_type
);
340 export_proto(lstat_i8
);
343 lstat_i8 (char *name
, gfc_array_i8
*sarray
, gfc_charlen_type name_len
)
346 lstat_i8_sub (name
, sarray
, &val
, name_len
);
355 /* SUBROUTINE FSTAT(UNIT, SARRAY, STATUS)
356 INTEGER, INTENT(IN) :: UNIT
357 INTEGER, INTENT(OUT) :: SARRAY(13)
358 INTEGER, INTENT(OUT), OPTIONAL :: STATUS
360 FUNCTION FSTAT(UNIT, SARRAY)
362 INTEGER, INTENT(IN) :: UNIT
363 INTEGER, INTENT(OUT) :: SARRAY(13) */
365 extern void fstat_i4_sub (GFC_INTEGER_4
*, gfc_array_i4
*, GFC_INTEGER_4
*);
366 iexport_proto(fstat_i4_sub
);
369 fstat_i4_sub (GFC_INTEGER_4
*unit
, gfc_array_i4
*sarray
, GFC_INTEGER_4
*status
)
374 /* If the rank of the array is not 1, abort. */
375 if (GFC_DESCRIPTOR_RANK (sarray
) != 1)
376 runtime_error ("Array rank of SARRAY is not 1.");
378 /* If the array is too small, abort. */
379 if (sarray
->dim
[0].ubound
+ 1 - sarray
->dim
[0].lbound
< 13)
380 runtime_error ("Array size of SARRAY is too small.");
382 /* Convert Fortran unit number to C file descriptor. */
383 val
= unit_to_fd (*unit
);
385 val
= fstat(val
, &sb
);
390 sarray
->data
[0 * sarray
->dim
[0].stride
] = sb
.st_dev
;
393 sarray
->data
[1 * sarray
->dim
[0].stride
] = sb
.st_ino
;
396 sarray
->data
[2 * sarray
->dim
[0].stride
] = sb
.st_mode
;
398 /* Number of (hard) links */
399 sarray
->data
[3 * sarray
->dim
[0].stride
] = sb
.st_nlink
;
402 sarray
->data
[4 * sarray
->dim
[0].stride
] = sb
.st_uid
;
405 sarray
->data
[5 * sarray
->dim
[0].stride
] = sb
.st_gid
;
407 /* ID of device containing directory entry for file (0 if not available) */
408 #if HAVE_STRUCT_STAT_ST_RDEV
409 sarray
->data
[6 * sarray
->dim
[0].stride
] = sb
.st_rdev
;
411 sarray
->data
[6 * sarray
->dim
[0].stride
] = 0;
414 /* File size (bytes) */
415 sarray
->data
[7 * sarray
->dim
[0].stride
] = sb
.st_size
;
417 /* Last access time */
418 sarray
->data
[8 * sarray
->dim
[0].stride
] = sb
.st_atime
;
420 /* Last modification time */
421 sarray
->data
[9 * sarray
->dim
[0].stride
] = sb
.st_mtime
;
423 /* Last file status change time */
424 sarray
->data
[10 * sarray
->dim
[0].stride
] = sb
.st_ctime
;
426 /* Preferred I/O block size (-1 if not available) */
427 #if HAVE_STRUCT_STAT_ST_BLKSIZE
428 sarray
->data
[11 * sarray
->dim
[0].stride
] = sb
.st_blksize
;
430 sarray
->data
[11 * sarray
->dim
[0].stride
] = -1;
433 /* Number of blocks allocated (-1 if not available) */
434 #if HAVE_STRUCT_STAT_ST_BLOCKS
435 sarray
->data
[12 * sarray
->dim
[0].stride
] = sb
.st_blocks
;
437 sarray
->data
[12 * sarray
->dim
[0].stride
] = -1;
442 *status
= (val
== 0) ? 0 : errno
;
444 iexport(fstat_i4_sub
);
446 extern void fstat_i8_sub (GFC_INTEGER_8
*, gfc_array_i8
*, GFC_INTEGER_8
*);
447 iexport_proto(fstat_i8_sub
);
450 fstat_i8_sub (GFC_INTEGER_8
*unit
, gfc_array_i8
*sarray
, GFC_INTEGER_8
*status
)
455 /* If the rank of the array is not 1, abort. */
456 if (GFC_DESCRIPTOR_RANK (sarray
) != 1)
457 runtime_error ("Array rank of SARRAY is not 1.");
459 /* If the array is too small, abort. */
460 if (sarray
->dim
[0].ubound
+ 1 - sarray
->dim
[0].lbound
< 13)
461 runtime_error ("Array size of SARRAY is too small.");
463 /* Convert Fortran unit number to C file descriptor. */
464 val
= unit_to_fd ((int) *unit
);
466 val
= fstat(val
, &sb
);
471 sarray
->data
[0] = sb
.st_dev
;
474 sarray
->data
[sarray
->dim
[0].stride
] = sb
.st_ino
;
477 sarray
->data
[2 * sarray
->dim
[0].stride
] = sb
.st_mode
;
479 /* Number of (hard) links */
480 sarray
->data
[3 * sarray
->dim
[0].stride
] = sb
.st_nlink
;
483 sarray
->data
[4 * sarray
->dim
[0].stride
] = sb
.st_uid
;
486 sarray
->data
[5 * sarray
->dim
[0].stride
] = sb
.st_gid
;
488 /* ID of device containing directory entry for file (0 if not available) */
489 #if HAVE_STRUCT_STAT_ST_RDEV
490 sarray
->data
[6 * sarray
->dim
[0].stride
] = sb
.st_rdev
;
492 sarray
->data
[6 * sarray
->dim
[0].stride
] = 0;
495 /* File size (bytes) */
496 sarray
->data
[7 * sarray
->dim
[0].stride
] = sb
.st_size
;
498 /* Last access time */
499 sarray
->data
[8 * sarray
->dim
[0].stride
] = sb
.st_atime
;
501 /* Last modification time */
502 sarray
->data
[9 * sarray
->dim
[0].stride
] = sb
.st_mtime
;
504 /* Last file status change time */
505 sarray
->data
[10 * sarray
->dim
[0].stride
] = sb
.st_ctime
;
507 /* Preferred I/O block size (-1 if not available) */
508 #if HAVE_STRUCT_STAT_ST_BLKSIZE
509 sarray
->data
[11 * sarray
->dim
[0].stride
] = sb
.st_blksize
;
511 sarray
->data
[11 * sarray
->dim
[0].stride
] = -1;
514 /* Number of blocks allocated (-1 if not available) */
515 #if HAVE_STRUCT_STAT_ST_BLOCKS
516 sarray
->data
[12 * sarray
->dim
[0].stride
] = sb
.st_blocks
;
518 sarray
->data
[12 * sarray
->dim
[0].stride
] = -1;
523 *status
= (val
== 0) ? 0 : errno
;
525 iexport(fstat_i8_sub
);
527 extern GFC_INTEGER_4
fstat_i4 (GFC_INTEGER_4
*, gfc_array_i4
*);
528 export_proto(fstat_i4
);
531 fstat_i4 (GFC_INTEGER_4
*unit
, gfc_array_i4
*sarray
)
534 fstat_i4_sub (unit
, sarray
, &val
);
538 extern GFC_INTEGER_8
fstat_i8 (GFC_INTEGER_8
*, gfc_array_i8
*);
539 export_proto(fstat_i8
);
542 fstat_i8 (GFC_INTEGER_8
*unit
, gfc_array_i8
*sarray
)
545 fstat_i8_sub (unit
, sarray
, &val
);