1760c2415Smrg /* Implementation of the STAT and FSTAT intrinsics.
2*0bfacb9bSmrg Copyright (C) 2004-2020 Free Software Foundation, Inc.
3760c2415Smrg Contributed by Steven G. Kargl <kargls@comcast.net>.
4760c2415Smrg
5760c2415Smrg This file is part of the GNU Fortran runtime library (libgfortran).
6760c2415Smrg
7760c2415Smrg Libgfortran is free software; you can redistribute it and/or
8760c2415Smrg modify it under the terms of the GNU General Public
9760c2415Smrg License as published by the Free Software Foundation; either
10760c2415Smrg version 3 of the License, or (at your option) any later version.
11760c2415Smrg
12760c2415Smrg Libgfortran is distributed in the hope that it will be useful,
13760c2415Smrg but WITHOUT ANY WARRANTY; without even the implied warranty of
14760c2415Smrg MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15760c2415Smrg GNU General Public License for more details.
16760c2415Smrg
17760c2415Smrg Under Section 7 of GPL version 3, you are granted additional
18760c2415Smrg permissions described in the GCC Runtime Library Exception, version
19760c2415Smrg 3.1, as published by the Free Software Foundation.
20760c2415Smrg
21760c2415Smrg You should have received a copy of the GNU General Public License and
22760c2415Smrg a copy of the GCC Runtime Library Exception along with this program;
23760c2415Smrg see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
24760c2415Smrg <http://www.gnu.org/licenses/>. */
25760c2415Smrg
26760c2415Smrg #include "libgfortran.h"
27760c2415Smrg
28760c2415Smrg #include <errno.h>
29760c2415Smrg
30760c2415Smrg #ifdef HAVE_SYS_STAT_H
31760c2415Smrg #include <sys/stat.h>
32760c2415Smrg #endif
33760c2415Smrg
34760c2415Smrg
35760c2415Smrg
36760c2415Smrg #ifdef HAVE_STAT
37760c2415Smrg
38760c2415Smrg /* SUBROUTINE STAT(FILE, SARRAY, STATUS)
39760c2415Smrg CHARACTER(len=*), INTENT(IN) :: FILE
40760c2415Smrg INTEGER, INTENT(OUT), :: SARRAY(13)
41760c2415Smrg INTEGER, INTENT(OUT), OPTIONAL :: STATUS
42760c2415Smrg
43760c2415Smrg FUNCTION STAT(FILE, SARRAY)
44760c2415Smrg INTEGER STAT
45760c2415Smrg CHARACTER(len=*), INTENT(IN) :: FILE
46760c2415Smrg INTEGER, INTENT(OUT), :: SARRAY(13) */
47760c2415Smrg
48760c2415Smrg /*extern void stat_i4_sub_0 (char *, gfc_array_i4 *, GFC_INTEGER_4 *,
49760c2415Smrg gfc_charlen_type, int);
50760c2415Smrg internal_proto(stat_i4_sub_0);*/
51760c2415Smrg
52760c2415Smrg static void
stat_i4_sub_0(char * name,gfc_array_i4 * sarray,GFC_INTEGER_4 * status,gfc_charlen_type name_len,int is_lstat)53760c2415Smrg stat_i4_sub_0 (char *name, gfc_array_i4 *sarray, GFC_INTEGER_4 *status,
54760c2415Smrg gfc_charlen_type name_len, int is_lstat __attribute__ ((unused)))
55760c2415Smrg {
56760c2415Smrg int val;
57760c2415Smrg char *str;
58760c2415Smrg struct stat sb;
59760c2415Smrg
60760c2415Smrg /* If the rank of the array is not 1, abort. */
61760c2415Smrg if (GFC_DESCRIPTOR_RANK (sarray) != 1)
62760c2415Smrg runtime_error ("Array rank of SARRAY is not 1.");
63760c2415Smrg
64760c2415Smrg /* If the array is too small, abort. */
65760c2415Smrg if (GFC_DESCRIPTOR_EXTENT(sarray,0) < 13)
66760c2415Smrg runtime_error ("Array size of SARRAY is too small.");
67760c2415Smrg
68760c2415Smrg /* Make a null terminated copy of the string. */
69760c2415Smrg str = fc_strdup (name, name_len);
70760c2415Smrg
71760c2415Smrg /* On platforms that don't provide lstat(), we use stat() instead. */
72760c2415Smrg #ifdef HAVE_LSTAT
73760c2415Smrg if (is_lstat)
74760c2415Smrg val = lstat(str, &sb);
75760c2415Smrg else
76760c2415Smrg #endif
77760c2415Smrg val = stat(str, &sb);
78760c2415Smrg
79760c2415Smrg free (str);
80760c2415Smrg
81760c2415Smrg if (val == 0)
82760c2415Smrg {
83760c2415Smrg index_type stride = GFC_DESCRIPTOR_STRIDE(sarray,0);
84760c2415Smrg
85760c2415Smrg /* Device ID */
86760c2415Smrg sarray->base_addr[0 * stride] = sb.st_dev;
87760c2415Smrg
88760c2415Smrg /* Inode number */
89760c2415Smrg sarray->base_addr[1 * stride] = sb.st_ino;
90760c2415Smrg
91760c2415Smrg /* File mode */
92760c2415Smrg sarray->base_addr[2 * stride] = sb.st_mode;
93760c2415Smrg
94760c2415Smrg /* Number of (hard) links */
95760c2415Smrg sarray->base_addr[3 * stride] = sb.st_nlink;
96760c2415Smrg
97760c2415Smrg /* Owner's uid */
98760c2415Smrg sarray->base_addr[4 * stride] = sb.st_uid;
99760c2415Smrg
100760c2415Smrg /* Owner's gid */
101760c2415Smrg sarray->base_addr[5 * stride] = sb.st_gid;
102760c2415Smrg
103760c2415Smrg /* ID of device containing directory entry for file (0 if not available) */
104760c2415Smrg #if HAVE_STRUCT_STAT_ST_RDEV
105760c2415Smrg sarray->base_addr[6 * stride] = sb.st_rdev;
106760c2415Smrg #else
107760c2415Smrg sarray->base_addr[6 * stride] = 0;
108760c2415Smrg #endif
109760c2415Smrg
110760c2415Smrg /* File size (bytes) */
111760c2415Smrg sarray->base_addr[7 * stride] = sb.st_size;
112760c2415Smrg
113760c2415Smrg /* Last access time */
114760c2415Smrg sarray->base_addr[8 * stride] = sb.st_atime;
115760c2415Smrg
116760c2415Smrg /* Last modification time */
117760c2415Smrg sarray->base_addr[9 * stride] = sb.st_mtime;
118760c2415Smrg
119760c2415Smrg /* Last file status change time */
120760c2415Smrg sarray->base_addr[10 * stride] = sb.st_ctime;
121760c2415Smrg
122760c2415Smrg /* Preferred I/O block size (-1 if not available) */
123760c2415Smrg #if HAVE_STRUCT_STAT_ST_BLKSIZE
124760c2415Smrg sarray->base_addr[11 * stride] = sb.st_blksize;
125760c2415Smrg #else
126760c2415Smrg sarray->base_addr[11 * stride] = -1;
127760c2415Smrg #endif
128760c2415Smrg
129760c2415Smrg /* Number of blocks allocated (-1 if not available) */
130760c2415Smrg #if HAVE_STRUCT_STAT_ST_BLOCKS
131760c2415Smrg sarray->base_addr[12 * stride] = sb.st_blocks;
132760c2415Smrg #else
133760c2415Smrg sarray->base_addr[12 * stride] = -1;
134760c2415Smrg #endif
135760c2415Smrg }
136760c2415Smrg
137760c2415Smrg if (status != NULL)
138760c2415Smrg *status = (val == 0) ? 0 : errno;
139760c2415Smrg }
140760c2415Smrg
141760c2415Smrg
142760c2415Smrg extern void stat_i4_sub (char *, gfc_array_i4 *, GFC_INTEGER_4 *,
143760c2415Smrg gfc_charlen_type);
144760c2415Smrg iexport_proto(stat_i4_sub);
145760c2415Smrg
146760c2415Smrg void
stat_i4_sub(char * name,gfc_array_i4 * sarray,GFC_INTEGER_4 * status,gfc_charlen_type name_len)147760c2415Smrg stat_i4_sub (char *name, gfc_array_i4 *sarray, GFC_INTEGER_4 *status,
148760c2415Smrg gfc_charlen_type name_len)
149760c2415Smrg {
150760c2415Smrg stat_i4_sub_0 (name, sarray, status, name_len, 0);
151760c2415Smrg }
152760c2415Smrg iexport(stat_i4_sub);
153760c2415Smrg
154760c2415Smrg
155760c2415Smrg extern void lstat_i4_sub (char *, gfc_array_i4 *, GFC_INTEGER_4 *,
156760c2415Smrg gfc_charlen_type);
157760c2415Smrg iexport_proto(lstat_i4_sub);
158760c2415Smrg
159760c2415Smrg void
lstat_i4_sub(char * name,gfc_array_i4 * sarray,GFC_INTEGER_4 * status,gfc_charlen_type name_len)160760c2415Smrg lstat_i4_sub (char *name, gfc_array_i4 *sarray, GFC_INTEGER_4 *status,
161760c2415Smrg gfc_charlen_type name_len)
162760c2415Smrg {
163760c2415Smrg stat_i4_sub_0 (name, sarray, status, name_len, 1);
164760c2415Smrg }
165760c2415Smrg iexport(lstat_i4_sub);
166760c2415Smrg
167760c2415Smrg
168760c2415Smrg
169760c2415Smrg static void
stat_i8_sub_0(char * name,gfc_array_i8 * sarray,GFC_INTEGER_8 * status,gfc_charlen_type name_len,int is_lstat)170760c2415Smrg stat_i8_sub_0 (char *name, gfc_array_i8 *sarray, GFC_INTEGER_8 *status,
171760c2415Smrg gfc_charlen_type name_len, int is_lstat __attribute__ ((unused)))
172760c2415Smrg {
173760c2415Smrg int val;
174760c2415Smrg char *str;
175760c2415Smrg struct stat sb;
176760c2415Smrg
177760c2415Smrg /* If the rank of the array is not 1, abort. */
178760c2415Smrg if (GFC_DESCRIPTOR_RANK (sarray) != 1)
179760c2415Smrg runtime_error ("Array rank of SARRAY is not 1.");
180760c2415Smrg
181760c2415Smrg /* If the array is too small, abort. */
182760c2415Smrg if (GFC_DESCRIPTOR_EXTENT(sarray,0) < 13)
183760c2415Smrg runtime_error ("Array size of SARRAY is too small.");
184760c2415Smrg
185760c2415Smrg /* Make a null terminated copy of the string. */
186760c2415Smrg str = fc_strdup (name, name_len);
187760c2415Smrg
188760c2415Smrg /* On platforms that don't provide lstat(), we use stat() instead. */
189760c2415Smrg #ifdef HAVE_LSTAT
190760c2415Smrg if (is_lstat)
191760c2415Smrg val = lstat(str, &sb);
192760c2415Smrg else
193760c2415Smrg #endif
194760c2415Smrg val = stat(str, &sb);
195760c2415Smrg
196760c2415Smrg free (str);
197760c2415Smrg
198760c2415Smrg if (val == 0)
199760c2415Smrg {
200760c2415Smrg index_type stride = GFC_DESCRIPTOR_STRIDE(sarray,0);
201760c2415Smrg
202760c2415Smrg /* Device ID */
203760c2415Smrg sarray->base_addr[0] = sb.st_dev;
204760c2415Smrg
205760c2415Smrg /* Inode number */
206760c2415Smrg sarray->base_addr[stride] = sb.st_ino;
207760c2415Smrg
208760c2415Smrg /* File mode */
209760c2415Smrg sarray->base_addr[2 * stride] = sb.st_mode;
210760c2415Smrg
211760c2415Smrg /* Number of (hard) links */
212760c2415Smrg sarray->base_addr[3 * stride] = sb.st_nlink;
213760c2415Smrg
214760c2415Smrg /* Owner's uid */
215760c2415Smrg sarray->base_addr[4 * stride] = sb.st_uid;
216760c2415Smrg
217760c2415Smrg /* Owner's gid */
218760c2415Smrg sarray->base_addr[5 * stride] = sb.st_gid;
219760c2415Smrg
220760c2415Smrg /* ID of device containing directory entry for file (0 if not available) */
221760c2415Smrg #if HAVE_STRUCT_STAT_ST_RDEV
222760c2415Smrg sarray->base_addr[6 * stride] = sb.st_rdev;
223760c2415Smrg #else
224760c2415Smrg sarray->base_addr[6 * stride] = 0;
225760c2415Smrg #endif
226760c2415Smrg
227760c2415Smrg /* File size (bytes) */
228760c2415Smrg sarray->base_addr[7 * stride] = sb.st_size;
229760c2415Smrg
230760c2415Smrg /* Last access time */
231760c2415Smrg sarray->base_addr[8 * stride] = sb.st_atime;
232760c2415Smrg
233760c2415Smrg /* Last modification time */
234760c2415Smrg sarray->base_addr[9 * stride] = sb.st_mtime;
235760c2415Smrg
236760c2415Smrg /* Last file status change time */
237760c2415Smrg sarray->base_addr[10 * stride] = sb.st_ctime;
238760c2415Smrg
239760c2415Smrg /* Preferred I/O block size (-1 if not available) */
240760c2415Smrg #if HAVE_STRUCT_STAT_ST_BLKSIZE
241760c2415Smrg sarray->base_addr[11 * stride] = sb.st_blksize;
242760c2415Smrg #else
243760c2415Smrg sarray->base_addr[11 * stride] = -1;
244760c2415Smrg #endif
245760c2415Smrg
246760c2415Smrg /* Number of blocks allocated (-1 if not available) */
247760c2415Smrg #if HAVE_STRUCT_STAT_ST_BLOCKS
248760c2415Smrg sarray->base_addr[12 * stride] = sb.st_blocks;
249760c2415Smrg #else
250760c2415Smrg sarray->base_addr[12 * stride] = -1;
251760c2415Smrg #endif
252760c2415Smrg }
253760c2415Smrg
254760c2415Smrg if (status != NULL)
255760c2415Smrg *status = (val == 0) ? 0 : errno;
256760c2415Smrg }
257760c2415Smrg
258760c2415Smrg
259760c2415Smrg extern void stat_i8_sub (char *, gfc_array_i8 *, GFC_INTEGER_8 *,
260760c2415Smrg gfc_charlen_type);
261760c2415Smrg iexport_proto(stat_i8_sub);
262760c2415Smrg
263760c2415Smrg void
stat_i8_sub(char * name,gfc_array_i8 * sarray,GFC_INTEGER_8 * status,gfc_charlen_type name_len)264760c2415Smrg stat_i8_sub (char *name, gfc_array_i8 *sarray, GFC_INTEGER_8 *status,
265760c2415Smrg gfc_charlen_type name_len)
266760c2415Smrg {
267760c2415Smrg stat_i8_sub_0 (name, sarray, status, name_len, 0);
268760c2415Smrg }
269760c2415Smrg
270760c2415Smrg iexport(stat_i8_sub);
271760c2415Smrg
272760c2415Smrg
273760c2415Smrg extern void lstat_i8_sub (char *, gfc_array_i8 *, GFC_INTEGER_8 *,
274760c2415Smrg gfc_charlen_type);
275760c2415Smrg iexport_proto(lstat_i8_sub);
276760c2415Smrg
277760c2415Smrg void
lstat_i8_sub(char * name,gfc_array_i8 * sarray,GFC_INTEGER_8 * status,gfc_charlen_type name_len)278760c2415Smrg lstat_i8_sub (char *name, gfc_array_i8 *sarray, GFC_INTEGER_8 *status,
279760c2415Smrg gfc_charlen_type name_len)
280760c2415Smrg {
281760c2415Smrg stat_i8_sub_0 (name, sarray, status, name_len, 1);
282760c2415Smrg }
283760c2415Smrg
284760c2415Smrg iexport(lstat_i8_sub);
285760c2415Smrg
286760c2415Smrg
287760c2415Smrg extern GFC_INTEGER_4 stat_i4 (char *, gfc_array_i4 *, gfc_charlen_type);
288760c2415Smrg export_proto(stat_i4);
289760c2415Smrg
290760c2415Smrg GFC_INTEGER_4
stat_i4(char * name,gfc_array_i4 * sarray,gfc_charlen_type name_len)291760c2415Smrg stat_i4 (char *name, gfc_array_i4 *sarray, gfc_charlen_type name_len)
292760c2415Smrg {
293760c2415Smrg GFC_INTEGER_4 val;
294760c2415Smrg stat_i4_sub (name, sarray, &val, name_len);
295760c2415Smrg return val;
296760c2415Smrg }
297760c2415Smrg
298760c2415Smrg extern GFC_INTEGER_8 stat_i8 (char *, gfc_array_i8 *, gfc_charlen_type);
299760c2415Smrg export_proto(stat_i8);
300760c2415Smrg
301760c2415Smrg GFC_INTEGER_8
stat_i8(char * name,gfc_array_i8 * sarray,gfc_charlen_type name_len)302760c2415Smrg stat_i8 (char *name, gfc_array_i8 *sarray, gfc_charlen_type name_len)
303760c2415Smrg {
304760c2415Smrg GFC_INTEGER_8 val;
305760c2415Smrg stat_i8_sub (name, sarray, &val, name_len);
306760c2415Smrg return val;
307760c2415Smrg }
308760c2415Smrg
309760c2415Smrg
310760c2415Smrg /* SUBROUTINE LSTAT(FILE, SARRAY, STATUS)
311760c2415Smrg CHARACTER(len=*), INTENT(IN) :: FILE
312760c2415Smrg INTEGER, INTENT(OUT), :: SARRAY(13)
313760c2415Smrg INTEGER, INTENT(OUT), OPTIONAL :: STATUS
314760c2415Smrg
315760c2415Smrg FUNCTION LSTAT(FILE, SARRAY)
316760c2415Smrg INTEGER LSTAT
317760c2415Smrg CHARACTER(len=*), INTENT(IN) :: FILE
318760c2415Smrg INTEGER, INTENT(OUT), :: SARRAY(13) */
319760c2415Smrg
320760c2415Smrg extern GFC_INTEGER_4 lstat_i4 (char *, gfc_array_i4 *, gfc_charlen_type);
321760c2415Smrg export_proto(lstat_i4);
322760c2415Smrg
323760c2415Smrg GFC_INTEGER_4
lstat_i4(char * name,gfc_array_i4 * sarray,gfc_charlen_type name_len)324760c2415Smrg lstat_i4 (char *name, gfc_array_i4 *sarray, gfc_charlen_type name_len)
325760c2415Smrg {
326760c2415Smrg GFC_INTEGER_4 val;
327760c2415Smrg lstat_i4_sub (name, sarray, &val, name_len);
328760c2415Smrg return val;
329760c2415Smrg }
330760c2415Smrg
331760c2415Smrg extern GFC_INTEGER_8 lstat_i8 (char *, gfc_array_i8 *, gfc_charlen_type);
332760c2415Smrg export_proto(lstat_i8);
333760c2415Smrg
334760c2415Smrg GFC_INTEGER_8
lstat_i8(char * name,gfc_array_i8 * sarray,gfc_charlen_type name_len)335760c2415Smrg lstat_i8 (char *name, gfc_array_i8 *sarray, gfc_charlen_type name_len)
336760c2415Smrg {
337760c2415Smrg GFC_INTEGER_8 val;
338760c2415Smrg lstat_i8_sub (name, sarray, &val, name_len);
339760c2415Smrg return val;
340760c2415Smrg }
341760c2415Smrg
342760c2415Smrg #endif
343760c2415Smrg
344760c2415Smrg
345760c2415Smrg #ifdef HAVE_FSTAT
346760c2415Smrg
347760c2415Smrg /* SUBROUTINE FSTAT(UNIT, SARRAY, STATUS)
348760c2415Smrg INTEGER, INTENT(IN) :: UNIT
349760c2415Smrg INTEGER, INTENT(OUT) :: SARRAY(13)
350760c2415Smrg INTEGER, INTENT(OUT), OPTIONAL :: STATUS
351760c2415Smrg
352760c2415Smrg FUNCTION FSTAT(UNIT, SARRAY)
353760c2415Smrg INTEGER FSTAT
354760c2415Smrg INTEGER, INTENT(IN) :: UNIT
355760c2415Smrg INTEGER, INTENT(OUT) :: SARRAY(13) */
356760c2415Smrg
357760c2415Smrg extern void fstat_i4_sub (GFC_INTEGER_4 *, gfc_array_i4 *, GFC_INTEGER_4 *);
358760c2415Smrg iexport_proto(fstat_i4_sub);
359760c2415Smrg
360760c2415Smrg void
fstat_i4_sub(GFC_INTEGER_4 * unit,gfc_array_i4 * sarray,GFC_INTEGER_4 * status)361760c2415Smrg fstat_i4_sub (GFC_INTEGER_4 *unit, gfc_array_i4 *sarray, GFC_INTEGER_4 *status)
362760c2415Smrg {
363760c2415Smrg int val;
364760c2415Smrg struct stat sb;
365760c2415Smrg
366760c2415Smrg /* If the rank of the array is not 1, abort. */
367760c2415Smrg if (GFC_DESCRIPTOR_RANK (sarray) != 1)
368760c2415Smrg runtime_error ("Array rank of SARRAY is not 1.");
369760c2415Smrg
370760c2415Smrg /* If the array is too small, abort. */
371760c2415Smrg if (GFC_DESCRIPTOR_EXTENT(sarray,0) < 13)
372760c2415Smrg runtime_error ("Array size of SARRAY is too small.");
373760c2415Smrg
374760c2415Smrg /* Convert Fortran unit number to C file descriptor. */
375760c2415Smrg val = unit_to_fd (*unit);
376760c2415Smrg if (val >= 0)
377760c2415Smrg val = fstat(val, &sb);
378760c2415Smrg
379760c2415Smrg if (val == 0)
380760c2415Smrg {
381760c2415Smrg index_type stride = GFC_DESCRIPTOR_STRIDE(sarray,0);
382760c2415Smrg
383760c2415Smrg /* Device ID */
384760c2415Smrg sarray->base_addr[0 * stride] = sb.st_dev;
385760c2415Smrg
386760c2415Smrg /* Inode number */
387760c2415Smrg sarray->base_addr[1 * stride] = sb.st_ino;
388760c2415Smrg
389760c2415Smrg /* File mode */
390760c2415Smrg sarray->base_addr[2 * stride] = sb.st_mode;
391760c2415Smrg
392760c2415Smrg /* Number of (hard) links */
393760c2415Smrg sarray->base_addr[3 * stride] = sb.st_nlink;
394760c2415Smrg
395760c2415Smrg /* Owner's uid */
396760c2415Smrg sarray->base_addr[4 * stride] = sb.st_uid;
397760c2415Smrg
398760c2415Smrg /* Owner's gid */
399760c2415Smrg sarray->base_addr[5 * stride] = sb.st_gid;
400760c2415Smrg
401760c2415Smrg /* ID of device containing directory entry for file (0 if not available) */
402760c2415Smrg #if HAVE_STRUCT_STAT_ST_RDEV
403760c2415Smrg sarray->base_addr[6 * stride] = sb.st_rdev;
404760c2415Smrg #else
405760c2415Smrg sarray->base_addr[6 * stride] = 0;
406760c2415Smrg #endif
407760c2415Smrg
408760c2415Smrg /* File size (bytes) */
409760c2415Smrg sarray->base_addr[7 * stride] = sb.st_size;
410760c2415Smrg
411760c2415Smrg /* Last access time */
412760c2415Smrg sarray->base_addr[8 * stride] = sb.st_atime;
413760c2415Smrg
414760c2415Smrg /* Last modification time */
415760c2415Smrg sarray->base_addr[9 * stride] = sb.st_mtime;
416760c2415Smrg
417760c2415Smrg /* Last file status change time */
418760c2415Smrg sarray->base_addr[10 * stride] = sb.st_ctime;
419760c2415Smrg
420760c2415Smrg /* Preferred I/O block size (-1 if not available) */
421760c2415Smrg #if HAVE_STRUCT_STAT_ST_BLKSIZE
422760c2415Smrg sarray->base_addr[11 * stride] = sb.st_blksize;
423760c2415Smrg #else
424760c2415Smrg sarray->base_addr[11 * stride] = -1;
425760c2415Smrg #endif
426760c2415Smrg
427760c2415Smrg /* Number of blocks allocated (-1 if not available) */
428760c2415Smrg #if HAVE_STRUCT_STAT_ST_BLOCKS
429760c2415Smrg sarray->base_addr[12 * stride] = sb.st_blocks;
430760c2415Smrg #else
431760c2415Smrg sarray->base_addr[12 * stride] = -1;
432760c2415Smrg #endif
433760c2415Smrg }
434760c2415Smrg
435760c2415Smrg if (status != NULL)
436760c2415Smrg *status = (val == 0) ? 0 : errno;
437760c2415Smrg }
438760c2415Smrg iexport(fstat_i4_sub);
439760c2415Smrg
440760c2415Smrg extern void fstat_i8_sub (GFC_INTEGER_8 *, gfc_array_i8 *, GFC_INTEGER_8 *);
441760c2415Smrg iexport_proto(fstat_i8_sub);
442760c2415Smrg
443760c2415Smrg void
fstat_i8_sub(GFC_INTEGER_8 * unit,gfc_array_i8 * sarray,GFC_INTEGER_8 * status)444760c2415Smrg fstat_i8_sub (GFC_INTEGER_8 *unit, gfc_array_i8 *sarray, GFC_INTEGER_8 *status)
445760c2415Smrg {
446760c2415Smrg int val;
447760c2415Smrg struct stat sb;
448760c2415Smrg
449760c2415Smrg /* If the rank of the array is not 1, abort. */
450760c2415Smrg if (GFC_DESCRIPTOR_RANK (sarray) != 1)
451760c2415Smrg runtime_error ("Array rank of SARRAY is not 1.");
452760c2415Smrg
453760c2415Smrg /* If the array is too small, abort. */
454760c2415Smrg if (GFC_DESCRIPTOR_EXTENT(sarray,0) < 13)
455760c2415Smrg runtime_error ("Array size of SARRAY is too small.");
456760c2415Smrg
457760c2415Smrg /* Convert Fortran unit number to C file descriptor. */
458760c2415Smrg val = unit_to_fd ((int) *unit);
459760c2415Smrg if (val >= 0)
460760c2415Smrg val = fstat(val, &sb);
461760c2415Smrg
462760c2415Smrg if (val == 0)
463760c2415Smrg {
464760c2415Smrg index_type stride = GFC_DESCRIPTOR_STRIDE(sarray,0);
465760c2415Smrg
466760c2415Smrg /* Device ID */
467760c2415Smrg sarray->base_addr[0] = sb.st_dev;
468760c2415Smrg
469760c2415Smrg /* Inode number */
470760c2415Smrg sarray->base_addr[stride] = sb.st_ino;
471760c2415Smrg
472760c2415Smrg /* File mode */
473760c2415Smrg sarray->base_addr[2 * stride] = sb.st_mode;
474760c2415Smrg
475760c2415Smrg /* Number of (hard) links */
476760c2415Smrg sarray->base_addr[3 * stride] = sb.st_nlink;
477760c2415Smrg
478760c2415Smrg /* Owner's uid */
479760c2415Smrg sarray->base_addr[4 * stride] = sb.st_uid;
480760c2415Smrg
481760c2415Smrg /* Owner's gid */
482760c2415Smrg sarray->base_addr[5 * stride] = sb.st_gid;
483760c2415Smrg
484760c2415Smrg /* ID of device containing directory entry for file (0 if not available) */
485760c2415Smrg #if HAVE_STRUCT_STAT_ST_RDEV
486760c2415Smrg sarray->base_addr[6 * stride] = sb.st_rdev;
487760c2415Smrg #else
488760c2415Smrg sarray->base_addr[6 * stride] = 0;
489760c2415Smrg #endif
490760c2415Smrg
491760c2415Smrg /* File size (bytes) */
492760c2415Smrg sarray->base_addr[7 * stride] = sb.st_size;
493760c2415Smrg
494760c2415Smrg /* Last access time */
495760c2415Smrg sarray->base_addr[8 * stride] = sb.st_atime;
496760c2415Smrg
497760c2415Smrg /* Last modification time */
498760c2415Smrg sarray->base_addr[9 * stride] = sb.st_mtime;
499760c2415Smrg
500760c2415Smrg /* Last file status change time */
501760c2415Smrg sarray->base_addr[10 * stride] = sb.st_ctime;
502760c2415Smrg
503760c2415Smrg /* Preferred I/O block size (-1 if not available) */
504760c2415Smrg #if HAVE_STRUCT_STAT_ST_BLKSIZE
505760c2415Smrg sarray->base_addr[11 * stride] = sb.st_blksize;
506760c2415Smrg #else
507760c2415Smrg sarray->base_addr[11 * stride] = -1;
508760c2415Smrg #endif
509760c2415Smrg
510760c2415Smrg /* Number of blocks allocated (-1 if not available) */
511760c2415Smrg #if HAVE_STRUCT_STAT_ST_BLOCKS
512760c2415Smrg sarray->base_addr[12 * stride] = sb.st_blocks;
513760c2415Smrg #else
514760c2415Smrg sarray->base_addr[12 * stride] = -1;
515760c2415Smrg #endif
516760c2415Smrg }
517760c2415Smrg
518760c2415Smrg if (status != NULL)
519760c2415Smrg *status = (val == 0) ? 0 : errno;
520760c2415Smrg }
521760c2415Smrg iexport(fstat_i8_sub);
522760c2415Smrg
523760c2415Smrg extern GFC_INTEGER_4 fstat_i4 (GFC_INTEGER_4 *, gfc_array_i4 *);
524760c2415Smrg export_proto(fstat_i4);
525760c2415Smrg
526760c2415Smrg GFC_INTEGER_4
fstat_i4(GFC_INTEGER_4 * unit,gfc_array_i4 * sarray)527760c2415Smrg fstat_i4 (GFC_INTEGER_4 *unit, gfc_array_i4 *sarray)
528760c2415Smrg {
529760c2415Smrg GFC_INTEGER_4 val;
530760c2415Smrg fstat_i4_sub (unit, sarray, &val);
531760c2415Smrg return val;
532760c2415Smrg }
533760c2415Smrg
534760c2415Smrg extern GFC_INTEGER_8 fstat_i8 (GFC_INTEGER_8 *, gfc_array_i8 *);
535760c2415Smrg export_proto(fstat_i8);
536760c2415Smrg
537760c2415Smrg GFC_INTEGER_8
fstat_i8(GFC_INTEGER_8 * unit,gfc_array_i8 * sarray)538760c2415Smrg fstat_i8 (GFC_INTEGER_8 *unit, gfc_array_i8 *sarray)
539760c2415Smrg {
540760c2415Smrg GFC_INTEGER_8 val;
541760c2415Smrg fstat_i8_sub (unit, sarray, &val);
542760c2415Smrg return val;
543760c2415Smrg }
544760c2415Smrg
545760c2415Smrg #endif
546