1 /* Implementation of the STAT and FSTAT intrinsics.
2 Copyright (C) 2004-2014 Free Software Foundation, Inc.
3 Contributed by Steven G. Kargl <kargls@comcast.net>.
5 This file is part of the GNU Fortran 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
40 /* SUBROUTINE STAT(FILE, SARRAY, STATUS)
41 CHARACTER(len=*), INTENT(IN) :: FILE
42 INTEGER, INTENT(OUT), :: SARRAY(13)
43 INTEGER, INTENT(OUT), OPTIONAL :: STATUS
45 FUNCTION STAT(FILE, SARRAY)
47 CHARACTER(len=*), INTENT(IN) :: FILE
48 INTEGER, INTENT(OUT), :: SARRAY(13) */
50 /*extern void stat_i4_sub_0 (char *, gfc_array_i4 *, GFC_INTEGER_4 *,
51 gfc_charlen_type, int);
52 internal_proto(stat_i4_sub_0);*/
55 stat_i4_sub_0 (char *name
, gfc_array_i4
*sarray
, GFC_INTEGER_4
*status
,
56 gfc_charlen_type name_len
, int is_lstat
__attribute__ ((unused
)))
62 /* If the rank of the array is not 1, abort. */
63 if (GFC_DESCRIPTOR_RANK (sarray
) != 1)
64 runtime_error ("Array rank of SARRAY is not 1.");
66 /* If the array is too small, abort. */
67 if (GFC_DESCRIPTOR_EXTENT(sarray
,0) < 13)
68 runtime_error ("Array size of SARRAY is too small.");
70 /* Trim trailing spaces from name. */
71 while (name_len
> 0 && name
[name_len
- 1] == ' ')
74 /* Make a null terminated copy of the string. */
75 str
= gfc_alloca (name_len
+ 1);
76 memcpy (str
, name
, name_len
);
79 /* On platforms that don't provide lstat(), we use stat() instead. */
82 val
= lstat(str
, &sb
);
89 index_type stride
= GFC_DESCRIPTOR_STRIDE(sarray
,0);
92 sarray
->base_addr
[0 * stride
] = sb
.st_dev
;
95 sarray
->base_addr
[1 * stride
] = sb
.st_ino
;
98 sarray
->base_addr
[2 * stride
] = sb
.st_mode
;
100 /* Number of (hard) links */
101 sarray
->base_addr
[3 * stride
] = sb
.st_nlink
;
104 sarray
->base_addr
[4 * stride
] = sb
.st_uid
;
107 sarray
->base_addr
[5 * 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
->base_addr
[6 * stride
] = sb
.st_rdev
;
113 sarray
->base_addr
[6 * stride
] = 0;
116 /* File size (bytes) */
117 sarray
->base_addr
[7 * stride
] = sb
.st_size
;
119 /* Last access time */
120 sarray
->base_addr
[8 * stride
] = sb
.st_atime
;
122 /* Last modification time */
123 sarray
->base_addr
[9 * stride
] = sb
.st_mtime
;
125 /* Last file status change time */
126 sarray
->base_addr
[10 * stride
] = sb
.st_ctime
;
128 /* Preferred I/O block size (-1 if not available) */
129 #if HAVE_STRUCT_STAT_ST_BLKSIZE
130 sarray
->base_addr
[11 * stride
] = sb
.st_blksize
;
132 sarray
->base_addr
[11 * stride
] = -1;
135 /* Number of blocks allocated (-1 if not available) */
136 #if HAVE_STRUCT_STAT_ST_BLOCKS
137 sarray
->base_addr
[12 * stride
] = sb
.st_blocks
;
139 sarray
->base_addr
[12 * 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 (GFC_DESCRIPTOR_EXTENT(sarray
,0) < 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
);
210 index_type stride
= GFC_DESCRIPTOR_STRIDE(sarray
,0);
213 sarray
->base_addr
[0] = sb
.st_dev
;
216 sarray
->base_addr
[stride
] = sb
.st_ino
;
219 sarray
->base_addr
[2 * stride
] = sb
.st_mode
;
221 /* Number of (hard) links */
222 sarray
->base_addr
[3 * stride
] = sb
.st_nlink
;
225 sarray
->base_addr
[4 * stride
] = sb
.st_uid
;
228 sarray
->base_addr
[5 * stride
] = sb
.st_gid
;
230 /* ID of device containing directory entry for file (0 if not available) */
231 #if HAVE_STRUCT_STAT_ST_RDEV
232 sarray
->base_addr
[6 * stride
] = sb
.st_rdev
;
234 sarray
->base_addr
[6 * stride
] = 0;
237 /* File size (bytes) */
238 sarray
->base_addr
[7 * stride
] = sb
.st_size
;
240 /* Last access time */
241 sarray
->base_addr
[8 * stride
] = sb
.st_atime
;
243 /* Last modification time */
244 sarray
->base_addr
[9 * stride
] = sb
.st_mtime
;
246 /* Last file status change time */
247 sarray
->base_addr
[10 * stride
] = sb
.st_ctime
;
249 /* Preferred I/O block size (-1 if not available) */
250 #if HAVE_STRUCT_STAT_ST_BLKSIZE
251 sarray
->base_addr
[11 * stride
] = sb
.st_blksize
;
253 sarray
->base_addr
[11 * stride
] = -1;
256 /* Number of blocks allocated (-1 if not available) */
257 #if HAVE_STRUCT_STAT_ST_BLOCKS
258 sarray
->base_addr
[12 * stride
] = sb
.st_blocks
;
260 sarray
->base_addr
[12 * stride
] = -1;
265 *status
= (val
== 0) ? 0 : errno
;
269 extern void stat_i8_sub (char *, gfc_array_i8
*, GFC_INTEGER_8
*,
271 iexport_proto(stat_i8_sub
);
274 stat_i8_sub (char *name
, gfc_array_i8
*sarray
, GFC_INTEGER_8
*status
,
275 gfc_charlen_type name_len
)
277 stat_i8_sub_0 (name
, sarray
, status
, name_len
, 0);
280 iexport(stat_i8_sub
);
283 extern void lstat_i8_sub (char *, gfc_array_i8
*, GFC_INTEGER_8
*,
285 iexport_proto(lstat_i8_sub
);
288 lstat_i8_sub (char *name
, gfc_array_i8
*sarray
, GFC_INTEGER_8
*status
,
289 gfc_charlen_type name_len
)
291 stat_i8_sub_0 (name
, sarray
, status
, name_len
, 1);
294 iexport(lstat_i8_sub
);
297 extern GFC_INTEGER_4
stat_i4 (char *, gfc_array_i4
*, gfc_charlen_type
);
298 export_proto(stat_i4
);
301 stat_i4 (char *name
, gfc_array_i4
*sarray
, gfc_charlen_type name_len
)
304 stat_i4_sub (name
, sarray
, &val
, name_len
);
308 extern GFC_INTEGER_8
stat_i8 (char *, gfc_array_i8
*, gfc_charlen_type
);
309 export_proto(stat_i8
);
312 stat_i8 (char *name
, gfc_array_i8
*sarray
, gfc_charlen_type name_len
)
315 stat_i8_sub (name
, sarray
, &val
, name_len
);
320 /* SUBROUTINE LSTAT(FILE, SARRAY, STATUS)
321 CHARACTER(len=*), INTENT(IN) :: FILE
322 INTEGER, INTENT(OUT), :: SARRAY(13)
323 INTEGER, INTENT(OUT), OPTIONAL :: STATUS
325 FUNCTION LSTAT(FILE, SARRAY)
327 CHARACTER(len=*), INTENT(IN) :: FILE
328 INTEGER, INTENT(OUT), :: SARRAY(13) */
330 extern GFC_INTEGER_4
lstat_i4 (char *, gfc_array_i4
*, gfc_charlen_type
);
331 export_proto(lstat_i4
);
334 lstat_i4 (char *name
, gfc_array_i4
*sarray
, gfc_charlen_type name_len
)
337 lstat_i4_sub (name
, sarray
, &val
, name_len
);
341 extern GFC_INTEGER_8
lstat_i8 (char *, gfc_array_i8
*, gfc_charlen_type
);
342 export_proto(lstat_i8
);
345 lstat_i8 (char *name
, gfc_array_i8
*sarray
, gfc_charlen_type name_len
)
348 lstat_i8_sub (name
, sarray
, &val
, name_len
);
357 /* SUBROUTINE FSTAT(UNIT, SARRAY, STATUS)
358 INTEGER, INTENT(IN) :: UNIT
359 INTEGER, INTENT(OUT) :: SARRAY(13)
360 INTEGER, INTENT(OUT), OPTIONAL :: STATUS
362 FUNCTION FSTAT(UNIT, SARRAY)
364 INTEGER, INTENT(IN) :: UNIT
365 INTEGER, INTENT(OUT) :: SARRAY(13) */
367 extern void fstat_i4_sub (GFC_INTEGER_4
*, gfc_array_i4
*, GFC_INTEGER_4
*);
368 iexport_proto(fstat_i4_sub
);
371 fstat_i4_sub (GFC_INTEGER_4
*unit
, gfc_array_i4
*sarray
, GFC_INTEGER_4
*status
)
376 /* If the rank of the array is not 1, abort. */
377 if (GFC_DESCRIPTOR_RANK (sarray
) != 1)
378 runtime_error ("Array rank of SARRAY is not 1.");
380 /* If the array is too small, abort. */
381 if (GFC_DESCRIPTOR_EXTENT(sarray
,0) < 13)
382 runtime_error ("Array size of SARRAY is too small.");
384 /* Convert Fortran unit number to C file descriptor. */
385 val
= unit_to_fd (*unit
);
387 val
= fstat(val
, &sb
);
391 index_type stride
= GFC_DESCRIPTOR_STRIDE(sarray
,0);
394 sarray
->base_addr
[0 * stride
] = sb
.st_dev
;
397 sarray
->base_addr
[1 * stride
] = sb
.st_ino
;
400 sarray
->base_addr
[2 * stride
] = sb
.st_mode
;
402 /* Number of (hard) links */
403 sarray
->base_addr
[3 * stride
] = sb
.st_nlink
;
406 sarray
->base_addr
[4 * stride
] = sb
.st_uid
;
409 sarray
->base_addr
[5 * stride
] = sb
.st_gid
;
411 /* ID of device containing directory entry for file (0 if not available) */
412 #if HAVE_STRUCT_STAT_ST_RDEV
413 sarray
->base_addr
[6 * stride
] = sb
.st_rdev
;
415 sarray
->base_addr
[6 * stride
] = 0;
418 /* File size (bytes) */
419 sarray
->base_addr
[7 * stride
] = sb
.st_size
;
421 /* Last access time */
422 sarray
->base_addr
[8 * stride
] = sb
.st_atime
;
424 /* Last modification time */
425 sarray
->base_addr
[9 * stride
] = sb
.st_mtime
;
427 /* Last file status change time */
428 sarray
->base_addr
[10 * stride
] = sb
.st_ctime
;
430 /* Preferred I/O block size (-1 if not available) */
431 #if HAVE_STRUCT_STAT_ST_BLKSIZE
432 sarray
->base_addr
[11 * stride
] = sb
.st_blksize
;
434 sarray
->base_addr
[11 * stride
] = -1;
437 /* Number of blocks allocated (-1 if not available) */
438 #if HAVE_STRUCT_STAT_ST_BLOCKS
439 sarray
->base_addr
[12 * stride
] = sb
.st_blocks
;
441 sarray
->base_addr
[12 * stride
] = -1;
446 *status
= (val
== 0) ? 0 : errno
;
448 iexport(fstat_i4_sub
);
450 extern void fstat_i8_sub (GFC_INTEGER_8
*, gfc_array_i8
*, GFC_INTEGER_8
*);
451 iexport_proto(fstat_i8_sub
);
454 fstat_i8_sub (GFC_INTEGER_8
*unit
, gfc_array_i8
*sarray
, GFC_INTEGER_8
*status
)
459 /* If the rank of the array is not 1, abort. */
460 if (GFC_DESCRIPTOR_RANK (sarray
) != 1)
461 runtime_error ("Array rank of SARRAY is not 1.");
463 /* If the array is too small, abort. */
464 if (GFC_DESCRIPTOR_EXTENT(sarray
,0) < 13)
465 runtime_error ("Array size of SARRAY is too small.");
467 /* Convert Fortran unit number to C file descriptor. */
468 val
= unit_to_fd ((int) *unit
);
470 val
= fstat(val
, &sb
);
474 index_type stride
= GFC_DESCRIPTOR_STRIDE(sarray
,0);
477 sarray
->base_addr
[0] = sb
.st_dev
;
480 sarray
->base_addr
[stride
] = sb
.st_ino
;
483 sarray
->base_addr
[2 * stride
] = sb
.st_mode
;
485 /* Number of (hard) links */
486 sarray
->base_addr
[3 * stride
] = sb
.st_nlink
;
489 sarray
->base_addr
[4 * stride
] = sb
.st_uid
;
492 sarray
->base_addr
[5 * stride
] = sb
.st_gid
;
494 /* ID of device containing directory entry for file (0 if not available) */
495 #if HAVE_STRUCT_STAT_ST_RDEV
496 sarray
->base_addr
[6 * stride
] = sb
.st_rdev
;
498 sarray
->base_addr
[6 * stride
] = 0;
501 /* File size (bytes) */
502 sarray
->base_addr
[7 * stride
] = sb
.st_size
;
504 /* Last access time */
505 sarray
->base_addr
[8 * stride
] = sb
.st_atime
;
507 /* Last modification time */
508 sarray
->base_addr
[9 * stride
] = sb
.st_mtime
;
510 /* Last file status change time */
511 sarray
->base_addr
[10 * stride
] = sb
.st_ctime
;
513 /* Preferred I/O block size (-1 if not available) */
514 #if HAVE_STRUCT_STAT_ST_BLKSIZE
515 sarray
->base_addr
[11 * stride
] = sb
.st_blksize
;
517 sarray
->base_addr
[11 * stride
] = -1;
520 /* Number of blocks allocated (-1 if not available) */
521 #if HAVE_STRUCT_STAT_ST_BLOCKS
522 sarray
->base_addr
[12 * stride
] = sb
.st_blocks
;
524 sarray
->base_addr
[12 * stride
] = -1;
529 *status
= (val
== 0) ? 0 : errno
;
531 iexport(fstat_i8_sub
);
533 extern GFC_INTEGER_4
fstat_i4 (GFC_INTEGER_4
*, gfc_array_i4
*);
534 export_proto(fstat_i4
);
537 fstat_i4 (GFC_INTEGER_4
*unit
, gfc_array_i4
*sarray
)
540 fstat_i4_sub (unit
, sarray
, &val
);
544 extern GFC_INTEGER_8
fstat_i8 (GFC_INTEGER_8
*, gfc_array_i8
*);
545 export_proto(fstat_i8
);
548 fstat_i8 (GFC_INTEGER_8
*unit
, gfc_array_i8
*sarray
)
551 fstat_i8_sub (unit
, sarray
, &val
);