[thirdparty/gcc.git] / libgfortran / intrinsics / stat.c

/* Implementation of the STAT and FSTAT intrinsics.
   Copyright (C) 2004-2022 Free Software Foundation, Inc.
   Contributed by Steven G. Kargl <kargls@comcast.net>.

This file is part of the GNU Fortran runtime library (libgfortran).

Libgfortran is free software; you can redistribute it and/or
modify it under the terms of the GNU General Public
License as published by the Free Software Foundation; either
version 3 of the License, or (at your option) any later version.

Libgfortran is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
GNU General Public License for more details.

Under Section 7 of GPL version 3, you are granted additional
permissions described in the GCC Runtime Library Exception, version
3.1, as published by the Free Software Foundation.

You should have received a copy of the GNU General Public License and
a copy of the GCC Runtime Library Exception along with this program;
see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see
<http://www.gnu.org/licenses/>.  */

#include "libgfortran.h"

#include <errno.h>

#ifdef HAVE_SYS_STAT_H
#include <sys/stat.h>
#endif


#ifdef HAVE_STAT

/* SUBROUTINE STAT(FILE, SARRAY, STATUS)
   CHARACTER(len=*), INTENT(IN) :: FILE
   INTEGER, INTENT(OUT), :: SARRAY(13)
   INTEGER, INTENT(OUT), OPTIONAL :: STATUS

   FUNCTION STAT(FILE, SARRAY)
   INTEGER STAT
   CHARACTER(len=*), INTENT(IN) :: FILE
   INTEGER, INTENT(OUT), :: SARRAY(13)  */

/*extern void stat_i4_sub_0 (char *, gfc_array_i4 *, GFC_INTEGER_4 *,
			   gfc_charlen_type, int);
internal_proto(stat_i4_sub_0);*/

static void
stat_i4_sub_0 (char *name, gfc_array_i4 *sarray, GFC_INTEGER_4 *status,
	       gfc_charlen_type name_len, int is_lstat __attribute__ ((unused)))
{
  int val;
  char *str;
  struct stat sb;

  /* If the rank of the array is not 1, abort.  */
  if (GFC_DESCRIPTOR_RANK (sarray) != 1)
    runtime_error ("Array rank of SARRAY is not 1.");

  /* If the array is too small, abort.  */
  if (GFC_DESCRIPTOR_EXTENT(sarray,0) < 13)
    runtime_error ("Array size of SARRAY is too small.");

  /* Make a null terminated copy of the string.  */
  str = fc_strdup (name, name_len);

  /* On platforms that don't provide lstat(), we use stat() instead.  */
#ifdef HAVE_LSTAT
  if (is_lstat)
    val = lstat(str, &sb);
  else
#endif
    val = stat(str, &sb);

  free (str);

  if (val == 0)
    {
      index_type stride = GFC_DESCRIPTOR_STRIDE(sarray,0);

      /* Device ID  */
      sarray->base_addr[0 * stride] = sb.st_dev;

      /* Inode number  */
      sarray->base_addr[1 * stride] = sb.st_ino;

      /* File mode  */
      sarray->base_addr[2 * stride] = sb.st_mode;

      /* Number of (hard) links  */
      sarray->base_addr[3 * stride] = sb.st_nlink;

      /* Owner's uid  */
      sarray->base_addr[4 * stride] = sb.st_uid;

      /* Owner's gid  */
      sarray->base_addr[5 * stride] = sb.st_gid;

      /* ID of device containing directory entry for file (0 if not available) */
#if HAVE_STRUCT_STAT_ST_RDEV
      sarray->base_addr[6 * stride] = sb.st_rdev;
#else
      sarray->base_addr[6 * stride] = 0;
#endif

      /* File size (bytes)  */
      sarray->base_addr[7 * stride] = sb.st_size;

      /* Last access time  */
      sarray->base_addr[8 * stride] = sb.st_atime;

      /* Last modification time  */
      sarray->base_addr[9 * stride] = sb.st_mtime;

      /* Last file status change time  */
      sarray->base_addr[10 * stride] = sb.st_ctime;

      /* Preferred I/O block size (-1 if not available)  */
#if HAVE_STRUCT_STAT_ST_BLKSIZE
      sarray->base_addr[11 * stride] = sb.st_blksize;
#else
      sarray->base_addr[11 * stride] = -1;
#endif

      /* Number of blocks allocated (-1 if not available)  */
#if HAVE_STRUCT_STAT_ST_BLOCKS
      sarray->base_addr[12 * stride] = sb.st_blocks;
#else
      sarray->base_addr[12 * stride] = -1;
#endif
    }

  if (status != NULL)
    *status = (val == 0) ? 0 : errno;
}


extern void stat_i4_sub (char *, gfc_array_i4 *, GFC_INTEGER_4 *,
			 gfc_charlen_type);
iexport_proto(stat_i4_sub);

void
stat_i4_sub (char *name, gfc_array_i4 *sarray, GFC_INTEGER_4 *status,
	     gfc_charlen_type name_len)
{
  stat_i4_sub_0 (name, sarray, status, name_len, 0);
}
iexport(stat_i4_sub);


extern void lstat_i4_sub (char *, gfc_array_i4 *, GFC_INTEGER_4 *,
			 gfc_charlen_type);
iexport_proto(lstat_i4_sub);

void
lstat_i4_sub (char *name, gfc_array_i4 *sarray, GFC_INTEGER_4 *status,
	     gfc_charlen_type name_len)
{
  stat_i4_sub_0 (name, sarray, status, name_len, 1);
}
iexport(lstat_i4_sub);


static void
stat_i8_sub_0 (char *name, gfc_array_i8 *sarray, GFC_INTEGER_8 *status,
	       gfc_charlen_type name_len, int is_lstat __attribute__ ((unused)))
{
  int val;
  char *str;
  struct stat sb;

  /* If the rank of the array is not 1, abort.  */
  if (GFC_DESCRIPTOR_RANK (sarray) != 1)
    runtime_error ("Array rank of SARRAY is not 1.");

  /* If the array is too small, abort.  */
  if (GFC_DESCRIPTOR_EXTENT(sarray,0) < 13)
    runtime_error ("Array size of SARRAY is too small.");

  /* Make a null terminated copy of the string.  */
  str = fc_strdup (name, name_len);

  /* On platforms that don't provide lstat(), we use stat() instead.  */
#ifdef HAVE_LSTAT
  if (is_lstat)
    val = lstat(str, &sb);
  else
#endif
    val = stat(str, &sb);

  free (str);

  if (val == 0)
    {
      index_type stride = GFC_DESCRIPTOR_STRIDE(sarray,0);

      /* Device ID  */
      sarray->base_addr[0] = sb.st_dev;

      /* Inode number  */
      sarray->base_addr[stride] = sb.st_ino;

      /* File mode  */
      sarray->base_addr[2 * stride] = sb.st_mode;

      /* Number of (hard) links  */
      sarray->base_addr[3 * stride] = sb.st_nlink;

      /* Owner's uid  */
      sarray->base_addr[4 * stride] = sb.st_uid;

      /* Owner's gid  */
      sarray->base_addr[5 * stride] = sb.st_gid;

      /* ID of device containing directory entry for file (0 if not available) */
#if HAVE_STRUCT_STAT_ST_RDEV
      sarray->base_addr[6 * stride] = sb.st_rdev;
#else
      sarray->base_addr[6 * stride] = 0;
#endif

      /* File size (bytes)  */
      sarray->base_addr[7 * stride] = sb.st_size;

      /* Last access time  */
      sarray->base_addr[8 * stride] = sb.st_atime;

      /* Last modification time  */
      sarray->base_addr[9 * stride] = sb.st_mtime;

      /* Last file status change time  */
      sarray->base_addr[10 * stride] = sb.st_ctime;

      /* Preferred I/O block size (-1 if not available)  */
#if HAVE_STRUCT_STAT_ST_BLKSIZE
      sarray->base_addr[11 * stride] = sb.st_blksize;
#else
      sarray->base_addr[11 * stride] = -1;
#endif

      /* Number of blocks allocated (-1 if not available)  */
#if HAVE_STRUCT_STAT_ST_BLOCKS
      sarray->base_addr[12 * stride] = sb.st_blocks;
#else
      sarray->base_addr[12 * stride] = -1;
#endif
    }

  if (status != NULL)
    *status = (val == 0) ? 0 : errno;
}


extern void stat_i8_sub (char *, gfc_array_i8 *, GFC_INTEGER_8 *,
			 gfc_charlen_type);
iexport_proto(stat_i8_sub);

void
stat_i8_sub (char *name, gfc_array_i8 *sarray, GFC_INTEGER_8 *status,
	     gfc_charlen_type name_len)
{
  stat_i8_sub_0 (name, sarray, status, name_len, 0);
}

iexport(stat_i8_sub);


extern void lstat_i8_sub (char *, gfc_array_i8 *, GFC_INTEGER_8 *,
			 gfc_charlen_type);
iexport_proto(lstat_i8_sub);

void
lstat_i8_sub (char *name, gfc_array_i8 *sarray, GFC_INTEGER_8 *status,
	     gfc_charlen_type name_len)
{
  stat_i8_sub_0 (name, sarray, status, name_len, 1);
}

iexport(lstat_i8_sub);


extern GFC_INTEGER_4 stat_i4 (char *, gfc_array_i4 *, gfc_charlen_type);
export_proto(stat_i4);

GFC_INTEGER_4
stat_i4 (char *name, gfc_array_i4 *sarray, gfc_charlen_type name_len)
{
  GFC_INTEGER_4 val;
  stat_i4_sub (name, sarray, &val, name_len);
  return val;
}

extern GFC_INTEGER_8 stat_i8 (char *, gfc_array_i8 *, gfc_charlen_type);
export_proto(stat_i8);

GFC_INTEGER_8
stat_i8 (char *name, gfc_array_i8 *sarray, gfc_charlen_type name_len)
{
  GFC_INTEGER_8 val;
  stat_i8_sub (name, sarray, &val, name_len);
  return val;
}


/* SUBROUTINE LSTAT(FILE, SARRAY, STATUS)
   CHARACTER(len=*), INTENT(IN) :: FILE
   INTEGER, INTENT(OUT), :: SARRAY(13)
   INTEGER, INTENT(OUT), OPTIONAL :: STATUS

   FUNCTION LSTAT(FILE, SARRAY)
   INTEGER LSTAT
   CHARACTER(len=*), INTENT(IN) :: FILE
   INTEGER, INTENT(OUT), :: SARRAY(13)  */

extern GFC_INTEGER_4 lstat_i4 (char *, gfc_array_i4 *, gfc_charlen_type);
export_proto(lstat_i4);

GFC_INTEGER_4
lstat_i4 (char *name, gfc_array_i4 *sarray, gfc_charlen_type name_len)
{
  GFC_INTEGER_4 val;
  lstat_i4_sub (name, sarray, &val, name_len);
  return val;
}

extern GFC_INTEGER_8 lstat_i8 (char *, gfc_array_i8 *, gfc_charlen_type);
export_proto(lstat_i8);

GFC_INTEGER_8
lstat_i8 (char *name, gfc_array_i8 *sarray, gfc_charlen_type name_len)
{
  GFC_INTEGER_8 val;
  lstat_i8_sub (name, sarray, &val, name_len);
  return val;
}

#endif


#ifdef HAVE_FSTAT

/* SUBROUTINE FSTAT(UNIT, SARRAY, STATUS)
   INTEGER, INTENT(IN) :: UNIT
   INTEGER, INTENT(OUT) :: SARRAY(13)
   INTEGER, INTENT(OUT), OPTIONAL :: STATUS

   FUNCTION FSTAT(UNIT, SARRAY)
   INTEGER FSTAT
   INTEGER, INTENT(IN) :: UNIT
   INTEGER, INTENT(OUT) :: SARRAY(13)  */

extern void fstat_i4_sub (GFC_INTEGER_4 *, gfc_array_i4 *, GFC_INTEGER_4 *);
iexport_proto(fstat_i4_sub);

void
fstat_i4_sub (GFC_INTEGER_4 *unit, gfc_array_i4 *sarray, GFC_INTEGER_4 *status)
{
  int val;
  struct stat sb;

  /* If the rank of the array is not 1, abort.  */
  if (GFC_DESCRIPTOR_RANK (sarray) != 1)
    runtime_error ("Array rank of SARRAY is not 1.");

  /* If the array is too small, abort.  */
  if (GFC_DESCRIPTOR_EXTENT(sarray,0) < 13)
    runtime_error ("Array size of SARRAY is too small.");

  /* Convert Fortran unit number to C file descriptor.  */
  val = unit_to_fd (*unit);
  if (val >= 0)
    val = fstat(val, &sb);

  if (val == 0)
    {
      index_type stride = GFC_DESCRIPTOR_STRIDE(sarray,0);

      /* Device ID  */
      sarray->base_addr[0 * stride] = sb.st_dev;

      /* Inode number  */
      sarray->base_addr[1 * stride] = sb.st_ino;

      /* File mode  */
      sarray->base_addr[2 * stride] = sb.st_mode;

      /* Number of (hard) links  */
      sarray->base_addr[3 * stride] = sb.st_nlink;

      /* Owner's uid  */
      sarray->base_addr[4 * stride] = sb.st_uid;

      /* Owner's gid  */
      sarray->base_addr[5 * stride] = sb.st_gid;

      /* ID of device containing directory entry for file (0 if not available) */
#if HAVE_STRUCT_STAT_ST_RDEV
      sarray->base_addr[6 * stride] = sb.st_rdev;
#else
      sarray->base_addr[6 * stride] = 0;
#endif

      /* File size (bytes)  */
      sarray->base_addr[7 * stride] = sb.st_size;

      /* Last access time  */
      sarray->base_addr[8 * stride] = sb.st_atime;

      /* Last modification time  */
      sarray->base_addr[9 * stride] = sb.st_mtime;

      /* Last file status change time  */
      sarray->base_addr[10 * stride] = sb.st_ctime;

      /* Preferred I/O block size (-1 if not available)  */
#if HAVE_STRUCT_STAT_ST_BLKSIZE
      sarray->base_addr[11 * stride] = sb.st_blksize;
#else
      sarray->base_addr[11 * stride] = -1;
#endif

      /* Number of blocks allocated (-1 if not available)  */
#if HAVE_STRUCT_STAT_ST_BLOCKS
      sarray->base_addr[12 * stride] = sb.st_blocks;
#else
      sarray->base_addr[12 * stride] = -1;
#endif
    }

  if (status != NULL)
    *status = (val == 0) ? 0 : errno;
}
iexport(fstat_i4_sub);

extern void fstat_i8_sub (GFC_INTEGER_8 *, gfc_array_i8 *, GFC_INTEGER_8 *);
iexport_proto(fstat_i8_sub);

void
fstat_i8_sub (GFC_INTEGER_8 *unit, gfc_array_i8 *sarray, GFC_INTEGER_8 *status)
{
  int val;
  struct stat sb;

  /* If the rank of the array is not 1, abort.  */
  if (GFC_DESCRIPTOR_RANK (sarray) != 1)
    runtime_error ("Array rank of SARRAY is not 1.");

  /* If the array is too small, abort.  */
  if (GFC_DESCRIPTOR_EXTENT(sarray,0) < 13)
    runtime_error ("Array size of SARRAY is too small.");

  /* Convert Fortran unit number to C file descriptor.  */
  val = unit_to_fd ((int) *unit);
  if (val >= 0)
    val = fstat(val, &sb);

  if (val == 0)
    {
      index_type stride = GFC_DESCRIPTOR_STRIDE(sarray,0);

      /* Device ID  */
      sarray->base_addr[0] = sb.st_dev;

      /* Inode number  */
      sarray->base_addr[stride] = sb.st_ino;

      /* File mode  */
      sarray->base_addr[2 * stride] = sb.st_mode;

      /* Number of (hard) links  */
      sarray->base_addr[3 * stride] = sb.st_nlink;

      /* Owner's uid  */
      sarray->base_addr[4 * stride] = sb.st_uid;

      /* Owner's gid  */
      sarray->base_addr[5 * stride] = sb.st_gid;

      /* ID of device containing directory entry for file (0 if not available) */
#if HAVE_STRUCT_STAT_ST_RDEV
      sarray->base_addr[6 * stride] = sb.st_rdev;
#else
      sarray->base_addr[6 * stride] = 0;
#endif

      /* File size (bytes)  */
      sarray->base_addr[7 * stride] = sb.st_size;

      /* Last access time  */
      sarray->base_addr[8 * stride] = sb.st_atime;

      /* Last modification time  */
      sarray->base_addr[9 * stride] = sb.st_mtime;

      /* Last file status change time  */
      sarray->base_addr[10 * stride] = sb.st_ctime;

      /* Preferred I/O block size (-1 if not available)  */
#if HAVE_STRUCT_STAT_ST_BLKSIZE
      sarray->base_addr[11 * stride] = sb.st_blksize;
#else
      sarray->base_addr[11 * stride] = -1;
#endif

      /* Number of blocks allocated (-1 if not available)  */
#if HAVE_STRUCT_STAT_ST_BLOCKS
      sarray->base_addr[12 * stride] = sb.st_blocks;
#else
      sarray->base_addr[12 * stride] = -1;
#endif
    }

  if (status != NULL)
    *status = (val == 0) ? 0 : errno;
}
iexport(fstat_i8_sub);

extern GFC_INTEGER_4 fstat_i4 (GFC_INTEGER_4 *, gfc_array_i4 *);
export_proto(fstat_i4);

GFC_INTEGER_4
fstat_i4 (GFC_INTEGER_4 *unit, gfc_array_i4 *sarray)
{
  GFC_INTEGER_4 val;
  fstat_i4_sub (unit, sarray, &val);
  return val;
}

extern GFC_INTEGER_8 fstat_i8 (GFC_INTEGER_8 *, gfc_array_i8 *);
export_proto(fstat_i8);

GFC_INTEGER_8
fstat_i8 (GFC_INTEGER_8 *unit, gfc_array_i8 *sarray)
{
  GFC_INTEGER_8 val;
  fstat_i8_sub (unit, sarray, &val);
  return val;
}

#endif
Commit	Line	Data
f177a087	1	/* Implementation of the STAT and FSTAT intrinsics.
7adcbafe	2	Copyright (C) 2004-2022 Free Software Foundation, Inc.
f177a087 SK	3	Contributed by Steven G. Kargl <kargls@comcast.net>.
f177a087 SK	4
74544378	5	This file is part of the GNU Fortran runtime library (libgfortran).
f177a087 SK	6
f177a087 SK	7	Libgfortran is free software; you can redistribute it and/or
57dea9f6	8	modify it under the terms of the GNU General Public
f177a087	9	License as published by the Free Software Foundation; either
748086b7	10	version 3 of the License, or (at your option) any later version.
f177a087 SK	11
	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
57dea9f6	15	GNU General Public License for more details.
f177a087	16
748086b7 JJ	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.
	20
	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/>. */
f177a087	25
f177a087 SK	26	#include "libgfortran.h"
f177a087 SK	27
36ae8a61 FXC	28	#include <errno.h>
36ae8a61 FXC	29
f177a087 SK	30	#ifdef HAVE_SYS_STAT_H
	31	#include <sys/stat.h>
	32	#endif
	33
f177a087	34
29e86cb0 FXC	35
	36	#ifdef HAVE_STAT
	37
f177a087 SK	38	/* SUBROUTINE STAT(FILE, SARRAY, STATUS)
	39	CHARACTER(len=*), INTENT(IN) :: FILE
	40	INTEGER, INTENT(OUT), :: SARRAY(13)
	41	INTEGER, INTENT(OUT), OPTIONAL :: STATUS
	42
	43	FUNCTION STAT(FILE, SARRAY)
	44	INTEGER STAT
	45	CHARACTER(len=*), INTENT(IN) :: FILE
	46	INTEGER, INTENT(OUT), :: SARRAY(13) */
	47
bf3fb7e4 FXC	48	/extern void stat_i4_sub_0 (char , gfc_array_i4 , GFC_INTEGER_4 ,
	49	gfc_charlen_type, int);
	50	internal_proto(stat_i4_sub_0);*/
7d7b8bfe	51
bf3fb7e4 FXC	52	static void
bf3fb7e4 FXC	53	stat_i4_sub_0 (char name, gfc_array_i4 sarray, GFC_INTEGER_4 *status,
101eebdb	54	gfc_charlen_type name_len, int is_lstat __attribute__ ((unused)))
f177a087	55	{
f177a087 SK	56	int val;
	57	char *str;
	58	struct stat sb;
	59
f177a087 SK	60	/* If the rank of the array is not 1, abort. */
	61	if (GFC_DESCRIPTOR_RANK (sarray) != 1)
	62	runtime_error ("Array rank of SARRAY is not 1.");
	63
	64	/* If the array is too small, abort. */
dfb55fdc	65	if (GFC_DESCRIPTOR_EXTENT(sarray,0) < 13)
7d7b8bfe	66	runtime_error ("Array size of SARRAY is too small.");
f177a087	67
f177a087	68	/* Make a null terminated copy of the string. */
581d2326	69	str = fc_strdup (name, name_len);
f177a087	70
29e86cb0 FXC	71	/* On platforms that don't provide lstat(), we use stat() instead. */
29e86cb0 FXC	72	#ifdef HAVE_LSTAT
bf3fb7e4 FXC	73	if (is_lstat)
	74	val = lstat(str, &sb);
	75	else
29e86cb0	76	#endif
bf3fb7e4	77	val = stat(str, &sb);
f177a087	78
581d2326 JB	79	free (str);
581d2326 JB	80
deeab820	81	if (val == 0)
f177a087	82	{
dfb55fdc TK	83	index_type stride = GFC_DESCRIPTOR_STRIDE(sarray,0);
dfb55fdc TK	84
f177a087	85	/* Device ID */
21d1335b	86	sarray->base_addr[0 * stride] = sb.st_dev;
f177a087 SK	87
f177a087 SK	88	/* Inode number */
21d1335b	89	sarray->base_addr[1 * stride] = sb.st_ino;
f177a087 SK	90
f177a087 SK	91	/* File mode */
21d1335b	92	sarray->base_addr[2 * stride] = sb.st_mode;
f177a087 SK	93
f177a087 SK	94	/* Number of (hard) links */
21d1335b	95	sarray->base_addr[3 * stride] = sb.st_nlink;
f177a087 SK	96
f177a087 SK	97	/* Owner's uid */
21d1335b	98	sarray->base_addr[4 * stride] = sb.st_uid;
f177a087 SK	99
f177a087 SK	100	/* Owner's gid */
21d1335b	101	sarray->base_addr[5 * stride] = sb.st_gid;
deeab820	102
f177a087 SK	103	/* ID of device containing directory entry for file (0 if not available) */
f177a087 SK	104	#if HAVE_STRUCT_STAT_ST_RDEV
21d1335b	105	sarray->base_addr[6 * stride] = sb.st_rdev;
f177a087	106	#else
21d1335b	107	sarray->base_addr[6 * stride] = 0;
f177a087 SK	108	#endif
	109
	110	/* File size (bytes) */
21d1335b	111	sarray->base_addr[7 * stride] = sb.st_size;
f177a087 SK	112
f177a087 SK	113	/* Last access time */
21d1335b	114	sarray->base_addr[8 * stride] = sb.st_atime;
f177a087 SK	115
f177a087 SK	116	/* Last modification time */
21d1335b	117	sarray->base_addr[9 * stride] = sb.st_mtime;
f177a087 SK	118
f177a087 SK	119	/* Last file status change time */
21d1335b	120	sarray->base_addr[10 * stride] = sb.st_ctime;
f177a087 SK	121
	122	/* Preferred I/O block size (-1 if not available) */
	123	#if HAVE_STRUCT_STAT_ST_BLKSIZE
21d1335b	124	sarray->base_addr[11 * stride] = sb.st_blksize;
f177a087	125	#else
21d1335b	126	sarray->base_addr[11 * stride] = -1;
f177a087 SK	127	#endif
	128
	129	/* Number of blocks allocated (-1 if not available) */
	130	#if HAVE_STRUCT_STAT_ST_BLOCKS
21d1335b	131	sarray->base_addr[12 * stride] = sb.st_blocks;
f177a087	132	#else
21d1335b	133	sarray->base_addr[12 * stride] = -1;
f177a087 SK	134	#endif
	135	}
	136
deeab820	137	if (status != NULL)
f177a087 SK	138	*status = (val == 0) ? 0 : errno;
f177a087 SK	139	}
bf3fb7e4 FXC	140
	141
	142	extern void stat_i4_sub (char , gfc_array_i4 , GFC_INTEGER_4 *,
	143	gfc_charlen_type);
	144	iexport_proto(stat_i4_sub);
	145
	146	void
	147	stat_i4_sub (char name, gfc_array_i4 sarray, GFC_INTEGER_4 *status,
	148	gfc_charlen_type name_len)
	149	{
	150	stat_i4_sub_0 (name, sarray, status, name_len, 0);
	151	}
7d7b8bfe RH	152	iexport(stat_i4_sub);
7d7b8bfe RH	153
bf3fb7e4 FXC	154
bf3fb7e4 FXC	155	extern void lstat_i4_sub (char , gfc_array_i4 , GFC_INTEGER_4 *,
7d7b8bfe	156	gfc_charlen_type);
bf3fb7e4	157	iexport_proto(lstat_i4_sub);
f177a087 SK	158
f177a087 SK	159	void
bf3fb7e4	160	lstat_i4_sub (char name, gfc_array_i4 sarray, GFC_INTEGER_4 *status,
7d7b8bfe	161	gfc_charlen_type name_len)
bf3fb7e4 FXC	162	{
	163	stat_i4_sub_0 (name, sarray, status, name_len, 1);
	164	}
	165	iexport(lstat_i4_sub);
	166
	167
	168
	169	static void
	170	stat_i8_sub_0 (char name, gfc_array_i8 sarray, GFC_INTEGER_8 *status,
101eebdb	171	gfc_charlen_type name_len, int is_lstat __attribute__ ((unused)))
f177a087	172	{
f177a087 SK	173	int val;
	174	char *str;
	175	struct stat sb;
	176
f177a087 SK	177	/* If the rank of the array is not 1, abort. */
	178	if (GFC_DESCRIPTOR_RANK (sarray) != 1)
	179	runtime_error ("Array rank of SARRAY is not 1.");
	180
	181	/* If the array is too small, abort. */
dfb55fdc	182	if (GFC_DESCRIPTOR_EXTENT(sarray,0) < 13)
7d7b8bfe	183	runtime_error ("Array size of SARRAY is too small.");
f177a087	184
f177a087	185	/* Make a null terminated copy of the string. */
581d2326	186	str = fc_strdup (name, name_len);
f177a087	187
29e86cb0 FXC	188	/* On platforms that don't provide lstat(), we use stat() instead. */
29e86cb0 FXC	189	#ifdef HAVE_LSTAT
bf3fb7e4 FXC	190	if (is_lstat)
	191	val = lstat(str, &sb);
	192	else
29e86cb0	193	#endif
bf3fb7e4	194	val = stat(str, &sb);
f177a087	195
581d2326 JB	196	free (str);
581d2326 JB	197
f177a087 SK	198	if (val == 0)
f177a087 SK	199	{
dfb55fdc TK	200	index_type stride = GFC_DESCRIPTOR_STRIDE(sarray,0);
dfb55fdc TK	201
f177a087	202	/* Device ID */
21d1335b	203	sarray->base_addr[0] = sb.st_dev;
f177a087 SK	204
f177a087 SK	205	/* Inode number */
21d1335b	206	sarray->base_addr[stride] = sb.st_ino;
f177a087 SK	207
f177a087 SK	208	/* File mode */
21d1335b	209	sarray->base_addr[2 * stride] = sb.st_mode;
f177a087 SK	210
f177a087 SK	211	/* Number of (hard) links */
21d1335b	212	sarray->base_addr[3 * stride] = sb.st_nlink;
deeab820	213
f177a087	214	/* Owner's uid */
21d1335b	215	sarray->base_addr[4 * stride] = sb.st_uid;
f177a087 SK	216
f177a087 SK	217	/* Owner's gid */
21d1335b	218	sarray->base_addr[5 * stride] = sb.st_gid;
deeab820	219
f177a087 SK	220	/* ID of device containing directory entry for file (0 if not available) */
f177a087 SK	221	#if HAVE_STRUCT_STAT_ST_RDEV
21d1335b	222	sarray->base_addr[6 * stride] = sb.st_rdev;
f177a087	223	#else
21d1335b	224	sarray->base_addr[6 * stride] = 0;
f177a087 SK	225	#endif
	226
	227	/* File size (bytes) */
21d1335b	228	sarray->base_addr[7 * stride] = sb.st_size;
f177a087 SK	229
f177a087 SK	230	/* Last access time */
21d1335b	231	sarray->base_addr[8 * stride] = sb.st_atime;
f177a087 SK	232
f177a087 SK	233	/* Last modification time */
21d1335b	234	sarray->base_addr[9 * stride] = sb.st_mtime;
f177a087 SK	235
f177a087 SK	236	/* Last file status change time */
21d1335b	237	sarray->base_addr[10 * stride] = sb.st_ctime;
f177a087 SK	238
	239	/* Preferred I/O block size (-1 if not available) */
	240	#if HAVE_STRUCT_STAT_ST_BLKSIZE
21d1335b	241	sarray->base_addr[11 * stride] = sb.st_blksize;
f177a087	242	#else
21d1335b	243	sarray->base_addr[11 * stride] = -1;
f177a087 SK	244	#endif
	245
	246	/* Number of blocks allocated (-1 if not available) */
	247	#if HAVE_STRUCT_STAT_ST_BLOCKS
21d1335b	248	sarray->base_addr[12 * stride] = sb.st_blocks;
f177a087	249	#else
21d1335b	250	sarray->base_addr[12 * stride] = -1;
f177a087 SK	251	#endif
	252	}
	253
deeab820	254	if (status != NULL)
f177a087 SK	255	*status = (val == 0) ? 0 : errno;
f177a087 SK	256	}
bf3fb7e4 FXC	257
	258
	259	extern void stat_i8_sub (char , gfc_array_i8 , GFC_INTEGER_8 *,
	260	gfc_charlen_type);
	261	iexport_proto(stat_i8_sub);
	262
	263	void
	264	stat_i8_sub (char name, gfc_array_i8 sarray, GFC_INTEGER_8 *status,
	265	gfc_charlen_type name_len)
	266	{
	267	stat_i8_sub_0 (name, sarray, status, name_len, 0);
	268	}
	269
7d7b8bfe	270	iexport(stat_i8_sub);
f177a087	271
bf3fb7e4 FXC	272
	273	extern void lstat_i8_sub (char , gfc_array_i8 , GFC_INTEGER_8 *,
	274	gfc_charlen_type);
	275	iexport_proto(lstat_i8_sub);
	276
	277	void
	278	lstat_i8_sub (char name, gfc_array_i8 sarray, GFC_INTEGER_8 *status,
	279	gfc_charlen_type name_len)
	280	{
	281	stat_i8_sub_0 (name, sarray, status, name_len, 1);
	282	}
	283
	284	iexport(lstat_i8_sub);
	285
	286
7d7b8bfe RH	287	extern GFC_INTEGER_4 stat_i4 (char , gfc_array_i4 , gfc_charlen_type);
7d7b8bfe RH	288	export_proto(stat_i4);
f177a087 SK	289
f177a087 SK	290	GFC_INTEGER_4
7d7b8bfe	291	stat_i4 (char name, gfc_array_i4 sarray, gfc_charlen_type name_len)
f177a087	292	{
f177a087	293	GFC_INTEGER_4 val;
7d7b8bfe	294	stat_i4_sub (name, sarray, &val, name_len);
f177a087 SK	295	return val;
	296	}
	297
7d7b8bfe RH	298	extern GFC_INTEGER_8 stat_i8 (char , gfc_array_i8 , gfc_charlen_type);
7d7b8bfe RH	299	export_proto(stat_i8);
f177a087 SK	300
f177a087 SK	301	GFC_INTEGER_8
7d7b8bfe	302	stat_i8 (char name, gfc_array_i8 sarray, gfc_charlen_type name_len)
f177a087	303	{
f177a087	304	GFC_INTEGER_8 val;
7d7b8bfe	305	stat_i8_sub (name, sarray, &val, name_len);
f177a087 SK	306	return val;
	307	}
	308
	309
29e86cb0	310	/* SUBROUTINE LSTAT(FILE, SARRAY, STATUS)
bf3fb7e4 FXC	311	CHARACTER(len=*), INTENT(IN) :: FILE
	312	INTEGER, INTENT(OUT), :: SARRAY(13)
	313	INTEGER, INTENT(OUT), OPTIONAL :: STATUS
	314
29e86cb0 FXC	315	FUNCTION LSTAT(FILE, SARRAY)
29e86cb0 FXC	316	INTEGER LSTAT
bf3fb7e4 FXC	317	CHARACTER(len=*), INTENT(IN) :: FILE
	318	INTEGER, INTENT(OUT), :: SARRAY(13) */
	319
	320	extern GFC_INTEGER_4 lstat_i4 (char , gfc_array_i4 , gfc_charlen_type);
	321	export_proto(lstat_i4);
	322
	323	GFC_INTEGER_4
	324	lstat_i4 (char name, gfc_array_i4 sarray, gfc_charlen_type name_len)
	325	{
	326	GFC_INTEGER_4 val;
	327	lstat_i4_sub (name, sarray, &val, name_len);
	328	return val;
	329	}
	330
	331	extern GFC_INTEGER_8 lstat_i8 (char , gfc_array_i8 , gfc_charlen_type);
	332	export_proto(lstat_i8);
	333
	334	GFC_INTEGER_8
	335	lstat_i8 (char name, gfc_array_i8 sarray, gfc_charlen_type name_len)
	336	{
	337	GFC_INTEGER_8 val;
	338	lstat_i8_sub (name, sarray, &val, name_len);
	339	return val;
	340	}
	341
29e86cb0 FXC	342	#endif
29e86cb0 FXC	343
bf3fb7e4	344
29e86cb0	345	#ifdef HAVE_FSTAT
bf3fb7e4	346
f177a087	347	/* SUBROUTINE FSTAT(UNIT, SARRAY, STATUS)
deeab820	348	INTEGER, INTENT(IN) :: UNIT
f177a087	349	INTEGER, INTENT(OUT) :: SARRAY(13)
deeab820	350	INTEGER, INTENT(OUT), OPTIONAL :: STATUS
f177a087 SK	351
	352	FUNCTION FSTAT(UNIT, SARRAY)
	353	INTEGER FSTAT
deeab820	354	INTEGER, INTENT(IN) :: UNIT
f177a087 SK	355	INTEGER, INTENT(OUT) :: SARRAY(13) */
f177a087 SK	356
7d7b8bfe RH	357	extern void fstat_i4_sub (GFC_INTEGER_4 , gfc_array_i4 , GFC_INTEGER_4 *);
	358	iexport_proto(fstat_i4_sub);
	359
f177a087	360	void
7d7b8bfe	361	fstat_i4_sub (GFC_INTEGER_4 unit, gfc_array_i4 sarray, GFC_INTEGER_4 *status)
f177a087	362	{
f177a087 SK	363	int val;
	364	struct stat sb;
	365
f177a087 SK	366	/* If the rank of the array is not 1, abort. */
	367	if (GFC_DESCRIPTOR_RANK (sarray) != 1)
	368	runtime_error ("Array rank of SARRAY is not 1.");
	369
	370	/* If the array is too small, abort. */
dfb55fdc	371	if (GFC_DESCRIPTOR_EXTENT(sarray,0) < 13)
7d7b8bfe	372	runtime_error ("Array size of SARRAY is too small.");
f177a087	373
f177a087 SK	374	/* Convert Fortran unit number to C file descriptor. */
	375	val = unit_to_fd (*unit);
	376	if (val >= 0)
	377	val = fstat(val, &sb);
	378
	379	if (val == 0)
	380	{
dfb55fdc TK	381	index_type stride = GFC_DESCRIPTOR_STRIDE(sarray,0);
dfb55fdc TK	382
f177a087	383	/* Device ID */
21d1335b	384	sarray->base_addr[0 * stride] = sb.st_dev;
f177a087 SK	385
f177a087 SK	386	/* Inode number */
21d1335b	387	sarray->base_addr[1 * stride] = sb.st_ino;
deeab820	388
f177a087	389	/* File mode */
21d1335b	390	sarray->base_addr[2 * stride] = sb.st_mode;
f177a087 SK	391
f177a087 SK	392	/* Number of (hard) links */
21d1335b	393	sarray->base_addr[3 * stride] = sb.st_nlink;
f177a087 SK	394
f177a087 SK	395	/* Owner's uid */
21d1335b	396	sarray->base_addr[4 * stride] = sb.st_uid;
f177a087 SK	397
f177a087 SK	398	/* Owner's gid */
21d1335b	399	sarray->base_addr[5 * stride] = sb.st_gid;
deeab820	400
f177a087 SK	401	/* ID of device containing directory entry for file (0 if not available) */
f177a087 SK	402	#if HAVE_STRUCT_STAT_ST_RDEV
21d1335b	403	sarray->base_addr[6 * stride] = sb.st_rdev;
f177a087	404	#else
21d1335b	405	sarray->base_addr[6 * stride] = 0;
f177a087 SK	406	#endif
	407
	408	/* File size (bytes) */
21d1335b	409	sarray->base_addr[7 * stride] = sb.st_size;
f177a087 SK	410
f177a087 SK	411	/* Last access time */
21d1335b	412	sarray->base_addr[8 * stride] = sb.st_atime;
f177a087 SK	413
f177a087 SK	414	/* Last modification time */
21d1335b	415	sarray->base_addr[9 * stride] = sb.st_mtime;
f177a087 SK	416
f177a087 SK	417	/* Last file status change time */
21d1335b	418	sarray->base_addr[10 * stride] = sb.st_ctime;
f177a087 SK	419
	420	/* Preferred I/O block size (-1 if not available) */
	421	#if HAVE_STRUCT_STAT_ST_BLKSIZE
21d1335b	422	sarray->base_addr[11 * stride] = sb.st_blksize;
f177a087	423	#else
21d1335b	424	sarray->base_addr[11 * stride] = -1;
f177a087 SK	425	#endif
	426
	427	/* Number of blocks allocated (-1 if not available) */
	428	#if HAVE_STRUCT_STAT_ST_BLOCKS
21d1335b	429	sarray->base_addr[12 * stride] = sb.st_blocks;
f177a087	430	#else
21d1335b	431	sarray->base_addr[12 * stride] = -1;
f177a087 SK	432	#endif
	433	}
	434
deeab820	435	if (status != NULL)
f177a087 SK	436	*status = (val == 0) ? 0 : errno;
f177a087 SK	437	}
7d7b8bfe RH	438	iexport(fstat_i4_sub);
	439
	440	extern void fstat_i8_sub (GFC_INTEGER_8 , gfc_array_i8 , GFC_INTEGER_8 *);
	441	iexport_proto(fstat_i8_sub);
f177a087 SK	442
f177a087 SK	443	void
7d7b8bfe	444	fstat_i8_sub (GFC_INTEGER_8 unit, gfc_array_i8 sarray, GFC_INTEGER_8 *status)
f177a087	445	{
f177a087 SK	446	int val;
	447	struct stat sb;
	448
f177a087 SK	449	/* If the rank of the array is not 1, abort. */
	450	if (GFC_DESCRIPTOR_RANK (sarray) != 1)
	451	runtime_error ("Array rank of SARRAY is not 1.");
	452
	453	/* If the array is too small, abort. */
dfb55fdc	454	if (GFC_DESCRIPTOR_EXTENT(sarray,0) < 13)
7d7b8bfe	455	runtime_error ("Array size of SARRAY is too small.");
f177a087	456
f177a087 SK	457	/* Convert Fortran unit number to C file descriptor. */
	458	val = unit_to_fd ((int) *unit);
	459	if (val >= 0)
	460	val = fstat(val, &sb);
	461
	462	if (val == 0)
	463	{
dfb55fdc TK	464	index_type stride = GFC_DESCRIPTOR_STRIDE(sarray,0);
dfb55fdc TK	465
f177a087	466	/* Device ID */
21d1335b	467	sarray->base_addr[0] = sb.st_dev;
f177a087 SK	468
f177a087 SK	469	/* Inode number */
21d1335b	470	sarray->base_addr[stride] = sb.st_ino;
f177a087 SK	471
f177a087 SK	472	/* File mode */
21d1335b	473	sarray->base_addr[2 * stride] = sb.st_mode;
f177a087 SK	474
f177a087 SK	475	/* Number of (hard) links */
21d1335b	476	sarray->base_addr[3 * stride] = sb.st_nlink;
f177a087 SK	477
f177a087 SK	478	/* Owner's uid */
21d1335b	479	sarray->base_addr[4 * stride] = sb.st_uid;
f177a087 SK	480
f177a087 SK	481	/* Owner's gid */
21d1335b	482	sarray->base_addr[5 * stride] = sb.st_gid;
deeab820	483
f177a087 SK	484	/* ID of device containing directory entry for file (0 if not available) */
f177a087 SK	485	#if HAVE_STRUCT_STAT_ST_RDEV
21d1335b	486	sarray->base_addr[6 * stride] = sb.st_rdev;
f177a087	487	#else
21d1335b	488	sarray->base_addr[6 * stride] = 0;
f177a087 SK	489	#endif
	490
	491	/* File size (bytes) */
21d1335b	492	sarray->base_addr[7 * stride] = sb.st_size;
f177a087 SK	493
f177a087 SK	494	/* Last access time */
21d1335b	495	sarray->base_addr[8 * stride] = sb.st_atime;
f177a087 SK	496
f177a087 SK	497	/* Last modification time */
21d1335b	498	sarray->base_addr[9 * stride] = sb.st_mtime;
f177a087 SK	499
f177a087 SK	500	/* Last file status change time */
21d1335b	501	sarray->base_addr[10 * stride] = sb.st_ctime;
f177a087 SK	502
	503	/* Preferred I/O block size (-1 if not available) */
	504	#if HAVE_STRUCT_STAT_ST_BLKSIZE
21d1335b	505	sarray->base_addr[11 * stride] = sb.st_blksize;
f177a087	506	#else
21d1335b	507	sarray->base_addr[11 * stride] = -1;
f177a087 SK	508	#endif
	509
	510	/* Number of blocks allocated (-1 if not available) */
	511	#if HAVE_STRUCT_STAT_ST_BLOCKS
21d1335b	512	sarray->base_addr[12 * stride] = sb.st_blocks;
f177a087	513	#else
21d1335b	514	sarray->base_addr[12 * stride] = -1;
f177a087 SK	515	#endif
	516	}
	517
deeab820	518	if (status != NULL)
f177a087 SK	519	*status = (val == 0) ? 0 : errno;
f177a087 SK	520	}
7d7b8bfe	521	iexport(fstat_i8_sub);
f177a087	522
7d7b8bfe RH	523	extern GFC_INTEGER_4 fstat_i4 (GFC_INTEGER_4 , gfc_array_i4 );
7d7b8bfe RH	524	export_proto(fstat_i4);
f177a087 SK	525
f177a087 SK	526	GFC_INTEGER_4
7d7b8bfe	527	fstat_i4 (GFC_INTEGER_4 unit, gfc_array_i4 sarray)
f177a087	528	{
f177a087	529	GFC_INTEGER_4 val;
7d7b8bfe	530	fstat_i4_sub (unit, sarray, &val);
f177a087 SK	531	return val;
	532	}
	533
7d7b8bfe RH	534	extern GFC_INTEGER_8 fstat_i8 (GFC_INTEGER_8 , gfc_array_i8 );
7d7b8bfe RH	535	export_proto(fstat_i8);
f177a087 SK	536
f177a087 SK	537	GFC_INTEGER_8
7d7b8bfe	538	fstat_i8 (GFC_INTEGER_8 unit, gfc_array_i8 sarray)
f177a087	539	{
f177a087	540	GFC_INTEGER_8 val;
7d7b8bfe	541	fstat_i8_sub (unit, sarray, &val);
f177a087 SK	542	return val;
f177a087 SK	543	}
29e86cb0 FXC	544
29e86cb0 FXC	545	#endif