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>.
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 Lesser General Public
9 License as published by the Free Software Foundation; either
10 version 2.1 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 Lesser General Public License for more details.
17 You should have received a copy of the GNU Lesser General Public
18 License along with libgfor; see the file COPYING.LIB. If not,
19 write to the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
20 Boston, MA 02111-1307, USA. */
23 #include "libgfortran.h"
25 #ifdef HAVE_SYS_TYPES_H
26 #include <sys/types.h>
29 #ifdef HAVE_SYS_STAT_H
45 /* SUBROUTINE STAT(FILE, SARRAY, STATUS)
46 CHARACTER(len=*), INTENT(IN) :: FILE
47 INTEGER, INTENT(OUT), :: SARRAY(13)
48 INTEGER, INTENT(OUT), OPTIONAL :: STATUS
50 FUNCTION STAT(FILE, SARRAY)
52 CHARACTER(len=*), INTENT(IN) :: FILE
53 INTEGER, INTENT(OUT), :: SARRAY(13) */
56 prefix(stat_i4_sub
) (char * name
, gfc_array_i4
* sarray
,
57 GFC_INTEGER_4
* status
, gfc_charlen_type name_len
)
64 index_type stride
[GFC_MAX_DIMENSIONS
- 1];
66 /* If the rank of the array is not 1, abort. */
67 if (GFC_DESCRIPTOR_RANK (sarray
) != 1)
68 runtime_error ("Array rank of SARRAY is not 1.");
70 /* If the array is too small, abort. */
71 if (sarray
->dim
[0].ubound
+ 1 - sarray
->dim
[0].lbound
< 13)
72 runtime_error ("Array size of SARRAY is too small.");
74 if (sarray
->dim
[0].stride
== 0)
75 sarray
->dim
[0].stride
= 1;
77 /* Trim trailing spaces from name. */
78 while (name_len
> 0 && name
[name_len
- 1] == ' ')
81 /* Make a null terminated copy of the string. */
82 str
= gfc_alloca (name_len
+ 1);
83 memcpy (str
, name
, name_len
);
91 sarray
->data
[0 * sarray
->dim
[0].stride
] = sb
.st_dev
;
94 sarray
->data
[1 * sarray
->dim
[0].stride
] = sb
.st_ino
;
97 sarray
->data
[2 * sarray
->dim
[0].stride
] = sb
.st_mode
;
99 /* Number of (hard) links */
100 sarray
->data
[3 * sarray
->dim
[0].stride
] = sb
.st_nlink
;
103 sarray
->data
[4 * sarray
->dim
[0].stride
] = sb
.st_uid
;
106 sarray
->data
[5 * sarray
->dim
[0].stride
] = sb
.st_gid
;
108 /* ID of device containing directory entry for file (0 if not available) */
109 #if HAVE_STRUCT_STAT_ST_RDEV
110 sarray
->data
[6 * sarray
->dim
[0].stride
] = sb
.st_rdev
;
112 sarray
->data
[6 * sarray
->dim
[0].stride
] = 0;
115 /* File size (bytes) */
116 sarray
->data
[7 * sarray
->dim
[0].stride
] = sb
.st_size
;
118 /* Last access time */
119 sarray
->data
[8 * sarray
->dim
[0].stride
] = sb
.st_atime
;
121 /* Last modification time */
122 sarray
->data
[9 * sarray
->dim
[0].stride
] = sb
.st_mtime
;
124 /* Last file status change time */
125 sarray
->data
[10 * sarray
->dim
[0].stride
] = sb
.st_ctime
;
127 /* Preferred I/O block size (-1 if not available) */
128 #if HAVE_STRUCT_STAT_ST_BLKSIZE
129 sarray
->data
[11 * sarray
->dim
[0].stride
] = sb
.st_blksize
;
131 sarray
->data
[11 * sarray
->dim
[0].stride
] = -1;
134 /* Number of blocks allocated (-1 if not available) */
135 #if HAVE_STRUCT_STAT_ST_BLOCKS
136 sarray
->data
[12 * sarray
->dim
[0].stride
] = sb
.st_blocks
;
138 sarray
->data
[12 * sarray
->dim
[0].stride
] = -1;
143 *status
= (val
== 0) ? 0 : errno
;
147 prefix(stat_i8_sub
) (char * name
, gfc_array_i8
* sarray
,
148 GFC_INTEGER_8
* status
, gfc_charlen_type name_len
)
155 index_type stride
[GFC_MAX_DIMENSIONS
- 1];
157 /* If the rank of the array is not 1, abort. */
158 if (GFC_DESCRIPTOR_RANK (sarray
) != 1)
159 runtime_error ("Array rank of SARRAY is not 1.");
161 /* If the array is too small, abort. */
162 if (sarray
->dim
[0].ubound
+ 1 - sarray
->dim
[0].lbound
< 13)
163 runtime_error ("Array size of SARRAY is too small.");
165 if (sarray
->dim
[0].stride
== 0)
166 sarray
->dim
[0].stride
= 1;
168 /* Trim trailing spaces from name. */
169 while (name_len
> 0 && name
[name_len
- 1] == ' ')
172 /* Make a null terminated copy of the string. */
173 str
= gfc_alloca (name_len
+ 1);
174 memcpy (str
, name
, name_len
);
175 str
[name_len
] = '\0';
177 val
= stat(str
, &sb
);
182 sarray
->data
[0] = sb
.st_dev
;
185 sarray
->data
[sarray
->dim
[0].stride
] = sb
.st_ino
;
188 sarray
->data
[2 * sarray
->dim
[0].stride
] = sb
.st_mode
;
190 /* Number of (hard) links */
191 sarray
->data
[3 * sarray
->dim
[0].stride
] = sb
.st_nlink
;
194 sarray
->data
[4 * sarray
->dim
[0].stride
] = sb
.st_uid
;
197 sarray
->data
[5 * sarray
->dim
[0].stride
] = sb
.st_gid
;
199 /* ID of device containing directory entry for file (0 if not available) */
200 #if HAVE_STRUCT_STAT_ST_RDEV
201 sarray
->data
[6 * sarray
->dim
[0].stride
] = sb
.st_rdev
;
203 sarray
->data
[6 * sarray
->dim
[0].stride
] = 0;
206 /* File size (bytes) */
207 sarray
->data
[7 * sarray
->dim
[0].stride
] = sb
.st_size
;
209 /* Last access time */
210 sarray
->data
[8 * sarray
->dim
[0].stride
] = sb
.st_atime
;
212 /* Last modification time */
213 sarray
->data
[9 * sarray
->dim
[0].stride
] = sb
.st_mtime
;
215 /* Last file status change time */
216 sarray
->data
[10 * sarray
->dim
[0].stride
] = sb
.st_ctime
;
218 /* Preferred I/O block size (-1 if not available) */
219 #if HAVE_STRUCT_STAT_ST_BLKSIZE
220 sarray
->data
[11 * sarray
->dim
[0].stride
] = sb
.st_blksize
;
222 sarray
->data
[11 * sarray
->dim
[0].stride
] = -1;
225 /* Number of blocks allocated (-1 if not available) */
226 #if HAVE_STRUCT_STAT_ST_BLOCKS
227 sarray
->data
[12 * sarray
->dim
[0].stride
] = sb
.st_blocks
;
229 sarray
->data
[12 * sarray
->dim
[0].stride
] = -1;
234 *status
= (val
== 0) ? 0 : errno
;
239 prefix(stat_i4
) (char * name
, gfc_array_i4
* sarray
,
240 gfc_charlen_type name_len
)
244 prefix(stat_i4_sub
) (name
, sarray
, &val
, name_len
);
250 prefix(stat_i8
) (char * name
, gfc_array_i8
* sarray
,
251 gfc_charlen_type name_len
)
255 prefix(stat_i8_sub
) (name
, sarray
, &val
, name_len
);
260 /* SUBROUTINE FSTAT(UNIT, SARRAY, STATUS)
261 INTEGER, INTENT(IN) :: UNIT
262 INTEGER, INTENT(OUT) :: SARRAY(13)
263 INTEGER, INTENT(OUT), OPTIONAL :: STATUS
265 FUNCTION FSTAT(UNIT, SARRAY)
267 INTEGER, INTENT(IN) :: UNIT
268 INTEGER, INTENT(OUT) :: SARRAY(13) */
271 prefix(fstat_i4_sub
) (GFC_INTEGER_4
* unit
, gfc_array_i4
* sarray
,
272 GFC_INTEGER_4
* status
)
278 index_type stride
[GFC_MAX_DIMENSIONS
- 1];
280 /* If the rank of the array is not 1, abort. */
281 if (GFC_DESCRIPTOR_RANK (sarray
) != 1)
282 runtime_error ("Array rank of SARRAY is not 1.");
284 /* If the array is too small, abort. */
285 if (sarray
->dim
[0].ubound
+ 1 - sarray
->dim
[0].lbound
< 13)
286 runtime_error ("Array size of SARRAY is too small.");
288 if (sarray
->dim
[0].stride
== 0)
289 sarray
->dim
[0].stride
= 1;
291 /* Convert Fortran unit number to C file descriptor. */
292 val
= unit_to_fd (*unit
);
294 val
= fstat(val
, &sb
);
299 sarray
->data
[0 * sarray
->dim
[0].stride
] = sb
.st_dev
;
302 sarray
->data
[1 * sarray
->dim
[0].stride
] = sb
.st_ino
;
305 sarray
->data
[2 * sarray
->dim
[0].stride
] = sb
.st_mode
;
307 /* Number of (hard) links */
308 sarray
->data
[3 * sarray
->dim
[0].stride
] = sb
.st_nlink
;
311 sarray
->data
[4 * sarray
->dim
[0].stride
] = sb
.st_uid
;
314 sarray
->data
[5 * sarray
->dim
[0].stride
] = sb
.st_gid
;
316 /* ID of device containing directory entry for file (0 if not available) */
317 #if HAVE_STRUCT_STAT_ST_RDEV
318 sarray
->data
[6 * sarray
->dim
[0].stride
] = sb
.st_rdev
;
320 sarray
->data
[6 * sarray
->dim
[0].stride
] = 0;
323 /* File size (bytes) */
324 sarray
->data
[7 * sarray
->dim
[0].stride
] = sb
.st_size
;
326 /* Last access time */
327 sarray
->data
[8 * sarray
->dim
[0].stride
] = sb
.st_atime
;
329 /* Last modification time */
330 sarray
->data
[9 * sarray
->dim
[0].stride
] = sb
.st_mtime
;
332 /* Last file status change time */
333 sarray
->data
[10 * sarray
->dim
[0].stride
] = sb
.st_ctime
;
335 /* Preferred I/O block size (-1 if not available) */
336 #if HAVE_STRUCT_STAT_ST_BLKSIZE
337 sarray
->data
[11 * sarray
->dim
[0].stride
] = sb
.st_blksize
;
339 sarray
->data
[11 * sarray
->dim
[0].stride
] = -1;
342 /* Number of blocks allocated (-1 if not available) */
343 #if HAVE_STRUCT_STAT_ST_BLOCKS
344 sarray
->data
[12 * sarray
->dim
[0].stride
] = sb
.st_blocks
;
346 sarray
->data
[12 * sarray
->dim
[0].stride
] = -1;
351 *status
= (val
== 0) ? 0 : errno
;
355 prefix(fstat_i8_sub
) (GFC_INTEGER_8
* unit
, gfc_array_i8
* sarray
,
356 GFC_INTEGER_8
* status
)
362 index_type stride
[GFC_MAX_DIMENSIONS
- 1];
364 /* If the rank of the array is not 1, abort. */
365 if (GFC_DESCRIPTOR_RANK (sarray
) != 1)
366 runtime_error ("Array rank of SARRAY is not 1.");
368 /* If the array is too small, abort. */
369 if (sarray
->dim
[0].ubound
+ 1 - sarray
->dim
[0].lbound
< 13)
370 runtime_error ("Array size of SARRAY is too small.");
372 if (sarray
->dim
[0].stride
== 0)
373 sarray
->dim
[0].stride
= 1;
375 /* Convert Fortran unit number to C file descriptor. */
376 val
= unit_to_fd ((int) *unit
);
378 val
= fstat(val
, &sb
);
383 sarray
->data
[0] = sb
.st_dev
;
386 sarray
->data
[sarray
->dim
[0].stride
] = sb
.st_ino
;
389 sarray
->data
[2 * sarray
->dim
[0].stride
] = sb
.st_mode
;
391 /* Number of (hard) links */
392 sarray
->data
[3 * sarray
->dim
[0].stride
] = sb
.st_nlink
;
395 sarray
->data
[4 * sarray
->dim
[0].stride
] = sb
.st_uid
;
398 sarray
->data
[5 * sarray
->dim
[0].stride
] = sb
.st_gid
;
400 /* ID of device containing directory entry for file (0 if not available) */
401 #if HAVE_STRUCT_STAT_ST_RDEV
402 sarray
->data
[6 * sarray
->dim
[0].stride
] = sb
.st_rdev
;
404 sarray
->data
[6 * sarray
->dim
[0].stride
] = 0;
407 /* File size (bytes) */
408 sarray
->data
[7 * sarray
->dim
[0].stride
] = sb
.st_size
;
410 /* Last access time */
411 sarray
->data
[8 * sarray
->dim
[0].stride
] = sb
.st_atime
;
413 /* Last modification time */
414 sarray
->data
[9 * sarray
->dim
[0].stride
] = sb
.st_mtime
;
416 /* Last file status change time */
417 sarray
->data
[10 * sarray
->dim
[0].stride
] = sb
.st_ctime
;
419 /* Preferred I/O block size (-1 if not available) */
420 #if HAVE_STRUCT_STAT_ST_BLKSIZE
421 sarray
->data
[11 * sarray
->dim
[0].stride
] = sb
.st_blksize
;
423 sarray
->data
[11 * sarray
->dim
[0].stride
] = -1;
426 /* Number of blocks allocated (-1 if not available) */
427 #if HAVE_STRUCT_STAT_ST_BLOCKS
428 sarray
->data
[12 * sarray
->dim
[0].stride
] = sb
.st_blocks
;
430 sarray
->data
[12 * sarray
->dim
[0].stride
] = -1;
435 *status
= (val
== 0) ? 0 : errno
;
440 prefix(fstat_i4
) (GFC_INTEGER_4
* unit
, gfc_array_i4
* sarray
)
444 prefix(fstat_i4_sub
) (unit
, sarray
, &val
);
450 prefix(fstat_i8
) (GFC_INTEGER_8
* unit
, gfc_array_i8
* sarray
)
454 prefix(fstat_i8_sub
) (unit
, sarray
, &val
);