[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
	1	/* Implementation of the STAT and FSTAT intrinsics.
	2	Copyright (C) 2004-2022 Free Software Foundation, Inc.
	3	Contributed by Steven G. Kargl <kargls@comcast.net>.
	4
	5	This file is part of the GNU Fortran runtime library (libgfortran).
	6
	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.
	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
	15	GNU General Public License for more details.
	16
	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/>. */
	25
	26	#include "libgfortran.h"
	27
	28	#include <errno.h>
	29
	30	#ifdef HAVE_SYS_STAT_H
	31	#include <sys/stat.h>
	32	#endif
	33
	34
	35
	36	#ifdef HAVE_STAT
	37
	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
	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);*/
	51
	52	static void
	53	stat_i4_sub_0 (char name, gfc_array_i4 sarray, GFC_INTEGER_4 *status,
	54	gfc_charlen_type name_len, int is_lstat __attribute__ ((unused)))
	55	{
	56	int val;
	57	char *str;
	58	struct stat sb;
	59
	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. */
	65	if (GFC_DESCRIPTOR_EXTENT(sarray,0) < 13)
	66	runtime_error ("Array size of SARRAY is too small.");
	67
	68	/* Make a null terminated copy of the string. */
	69	str = fc_strdup (name, name_len);
	70
	71	/* On platforms that don't provide lstat(), we use stat() instead. */
	72	#ifdef HAVE_LSTAT
	73	if (is_lstat)
	74	val = lstat(str, &sb);
	75	else
	76	#endif
	77	val = stat(str, &sb);
	78
	79	free (str);
	80
	81	if (val == 0)
	82	{
	83	index_type stride = GFC_DESCRIPTOR_STRIDE(sarray,0);
	84
	85	/* Device ID */
	86	sarray->base_addr[0 * stride] = sb.st_dev;
	87
	88	/* Inode number */
	89	sarray->base_addr[1 * stride] = sb.st_ino;
	90
	91	/* File mode */
	92	sarray->base_addr[2 * stride] = sb.st_mode;
	93
	94	/* Number of (hard) links */
	95	sarray->base_addr[3 * stride] = sb.st_nlink;
	96
	97	/* Owner's uid */
	98	sarray->base_addr[4 * stride] = sb.st_uid;
	99
	100	/* Owner's gid */
	101	sarray->base_addr[5 * stride] = sb.st_gid;
	102
	103	/* ID of device containing directory entry for file (0 if not available) */
	104	#if HAVE_STRUCT_STAT_ST_RDEV
	105	sarray->base_addr[6 * stride] = sb.st_rdev;
	106	#else
	107	sarray->base_addr[6 * stride] = 0;
	108	#endif
	109
	110	/* File size (bytes) */
	111	sarray->base_addr[7 * stride] = sb.st_size;
	112
	113	/* Last access time */
	114	sarray->base_addr[8 * stride] = sb.st_atime;
	115
	116	/* Last modification time */
	117	sarray->base_addr[9 * stride] = sb.st_mtime;
	118
	119	/* Last file status change time */
	120	sarray->base_addr[10 * stride] = sb.st_ctime;
	121
	122	/* Preferred I/O block size (-1 if not available) */
	123	#if HAVE_STRUCT_STAT_ST_BLKSIZE
	124	sarray->base_addr[11 * stride] = sb.st_blksize;
	125	#else
	126	sarray->base_addr[11 * stride] = -1;
	127	#endif
	128
	129	/* Number of blocks allocated (-1 if not available) */
	130	#if HAVE_STRUCT_STAT_ST_BLOCKS
	131	sarray->base_addr[12 * stride] = sb.st_blocks;
	132	#else
	133	sarray->base_addr[12 * stride] = -1;
	134	#endif
	135	}
	136
	137	if (status != NULL)
	138	*status = (val == 0) ? 0 : errno;
	139	}
	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	}
	152	iexport(stat_i4_sub);
	153
	154
	155	extern void lstat_i4_sub (char , gfc_array_i4 , GFC_INTEGER_4 *,
	156	gfc_charlen_type);
	157	iexport_proto(lstat_i4_sub);
	158
	159	void
	160	lstat_i4_sub (char name, gfc_array_i4 sarray, GFC_INTEGER_4 *status,
	161	gfc_charlen_type name_len)
	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,
	171	gfc_charlen_type name_len, int is_lstat __attribute__ ((unused)))
	172	{
	173	int val;
	174	char *str;
	175	struct stat sb;
	176
	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. */
	182	if (GFC_DESCRIPTOR_EXTENT(sarray,0) < 13)
	183	runtime_error ("Array size of SARRAY is too small.");
	184
	185	/* Make a null terminated copy of the string. */
	186	str = fc_strdup (name, name_len);
	187
	188	/* On platforms that don't provide lstat(), we use stat() instead. */
	189	#ifdef HAVE_LSTAT
	190	if (is_lstat)
	191	val = lstat(str, &sb);
	192	else
	193	#endif
	194	val = stat(str, &sb);
	195
	196	free (str);
	197
	198	if (val == 0)
	199	{
	200	index_type stride = GFC_DESCRIPTOR_STRIDE(sarray,0);
	201
	202	/* Device ID */
	203	sarray->base_addr[0] = sb.st_dev;
	204
	205	/* Inode number */
	206	sarray->base_addr[stride] = sb.st_ino;
	207
	208	/* File mode */
	209	sarray->base_addr[2 * stride] = sb.st_mode;
	210
	211	/* Number of (hard) links */
	212	sarray->base_addr[3 * stride] = sb.st_nlink;
	213
	214	/* Owner's uid */
	215	sarray->base_addr[4 * stride] = sb.st_uid;
	216
	217	/* Owner's gid */
	218	sarray->base_addr[5 * stride] = sb.st_gid;
	219
	220	/* ID of device containing directory entry for file (0 if not available) */
	221	#if HAVE_STRUCT_STAT_ST_RDEV
	222	sarray->base_addr[6 * stride] = sb.st_rdev;
	223	#else
	224	sarray->base_addr[6 * stride] = 0;
	225	#endif
	226
	227	/* File size (bytes) */
	228	sarray->base_addr[7 * stride] = sb.st_size;
	229
	230	/* Last access time */
	231	sarray->base_addr[8 * stride] = sb.st_atime;
	232
	233	/* Last modification time */
	234	sarray->base_addr[9 * stride] = sb.st_mtime;
	235
	236	/* Last file status change time */
	237	sarray->base_addr[10 * stride] = sb.st_ctime;
	238
	239	/* Preferred I/O block size (-1 if not available) */
	240	#if HAVE_STRUCT_STAT_ST_BLKSIZE
	241	sarray->base_addr[11 * stride] = sb.st_blksize;
	242	#else
	243	sarray->base_addr[11 * stride] = -1;
	244	#endif
	245
	246	/* Number of blocks allocated (-1 if not available) */
	247	#if HAVE_STRUCT_STAT_ST_BLOCKS
	248	sarray->base_addr[12 * stride] = sb.st_blocks;
	249	#else
	250	sarray->base_addr[12 * stride] = -1;
	251	#endif
	252	}
	253
	254	if (status != NULL)
	255	*status = (val == 0) ? 0 : errno;
	256	}
	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
	270	iexport(stat_i8_sub);
	271
	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
	287	extern GFC_INTEGER_4 stat_i4 (char , gfc_array_i4 , gfc_charlen_type);
	288	export_proto(stat_i4);
	289
	290	GFC_INTEGER_4
	291	stat_i4 (char name, gfc_array_i4 sarray, gfc_charlen_type name_len)
	292	{
	293	GFC_INTEGER_4 val;
	294	stat_i4_sub (name, sarray, &val, name_len);
	295	return val;
	296	}
	297
	298	extern GFC_INTEGER_8 stat_i8 (char , gfc_array_i8 , gfc_charlen_type);
	299	export_proto(stat_i8);
	300
	301	GFC_INTEGER_8
	302	stat_i8 (char name, gfc_array_i8 sarray, gfc_charlen_type name_len)
	303	{
	304	GFC_INTEGER_8 val;
	305	stat_i8_sub (name, sarray, &val, name_len);
	306	return val;
	307	}
	308
	309
	310	/* SUBROUTINE LSTAT(FILE, SARRAY, STATUS)
	311	CHARACTER(len=*), INTENT(IN) :: FILE
	312	INTEGER, INTENT(OUT), :: SARRAY(13)
	313	INTEGER, INTENT(OUT), OPTIONAL :: STATUS
	314
	315	FUNCTION LSTAT(FILE, SARRAY)
	316	INTEGER LSTAT
	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
	342	#endif
	343
	344
	345	#ifdef HAVE_FSTAT
	346
	347	/* SUBROUTINE FSTAT(UNIT, SARRAY, STATUS)
	348	INTEGER, INTENT(IN) :: UNIT
	349	INTEGER, INTENT(OUT) :: SARRAY(13)
	350	INTEGER, INTENT(OUT), OPTIONAL :: STATUS
	351
	352	FUNCTION FSTAT(UNIT, SARRAY)
	353	INTEGER FSTAT
	354	INTEGER, INTENT(IN) :: UNIT
	355	INTEGER, INTENT(OUT) :: SARRAY(13) */
	356
	357	extern void fstat_i4_sub (GFC_INTEGER_4 , gfc_array_i4 , GFC_INTEGER_4 *);
	358	iexport_proto(fstat_i4_sub);
	359
	360	void
	361	fstat_i4_sub (GFC_INTEGER_4 unit, gfc_array_i4 sarray, GFC_INTEGER_4 *status)
	362	{
	363	int val;
	364	struct stat sb;
	365
	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. */
	371	if (GFC_DESCRIPTOR_EXTENT(sarray,0) < 13)
	372	runtime_error ("Array size of SARRAY is too small.");
	373
	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	{
	381	index_type stride = GFC_DESCRIPTOR_STRIDE(sarray,0);
	382
	383	/* Device ID */
	384	sarray->base_addr[0 * stride] = sb.st_dev;
	385
	386	/* Inode number */
	387	sarray->base_addr[1 * stride] = sb.st_ino;
	388
	389	/* File mode */
	390	sarray->base_addr[2 * stride] = sb.st_mode;
	391
	392	/* Number of (hard) links */
	393	sarray->base_addr[3 * stride] = sb.st_nlink;
	394
	395	/* Owner's uid */
	396	sarray->base_addr[4 * stride] = sb.st_uid;
	397
	398	/* Owner's gid */
	399	sarray->base_addr[5 * stride] = sb.st_gid;
	400
	401	/* ID of device containing directory entry for file (0 if not available) */
	402	#if HAVE_STRUCT_STAT_ST_RDEV
	403	sarray->base_addr[6 * stride] = sb.st_rdev;
	404	#else
	405	sarray->base_addr[6 * stride] = 0;
	406	#endif
	407
	408	/* File size (bytes) */
	409	sarray->base_addr[7 * stride] = sb.st_size;
	410
	411	/* Last access time */
	412	sarray->base_addr[8 * stride] = sb.st_atime;
	413
	414	/* Last modification time */
	415	sarray->base_addr[9 * stride] = sb.st_mtime;
	416
	417	/* Last file status change time */
	418	sarray->base_addr[10 * stride] = sb.st_ctime;
	419
	420	/* Preferred I/O block size (-1 if not available) */
	421	#if HAVE_STRUCT_STAT_ST_BLKSIZE
	422	sarray->base_addr[11 * stride] = sb.st_blksize;
	423	#else
	424	sarray->base_addr[11 * stride] = -1;
	425	#endif
	426
	427	/* Number of blocks allocated (-1 if not available) */
	428	#if HAVE_STRUCT_STAT_ST_BLOCKS
	429	sarray->base_addr[12 * stride] = sb.st_blocks;
	430	#else
	431	sarray->base_addr[12 * stride] = -1;
	432	#endif
	433	}
	434
	435	if (status != NULL)
	436	*status = (val == 0) ? 0 : errno;
	437	}
	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);
	442
	443	void
	444	fstat_i8_sub (GFC_INTEGER_8 unit, gfc_array_i8 sarray, GFC_INTEGER_8 *status)
	445	{
	446	int val;
	447	struct stat sb;
	448
	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. */
	454	if (GFC_DESCRIPTOR_EXTENT(sarray,0) < 13)
	455	runtime_error ("Array size of SARRAY is too small.");
	456
	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	{
	464	index_type stride = GFC_DESCRIPTOR_STRIDE(sarray,0);
	465
	466	/* Device ID */
	467	sarray->base_addr[0] = sb.st_dev;
	468
	469	/* Inode number */
	470	sarray->base_addr[stride] = sb.st_ino;
	471
	472	/* File mode */
	473	sarray->base_addr[2 * stride] = sb.st_mode;
	474
	475	/* Number of (hard) links */
	476	sarray->base_addr[3 * stride] = sb.st_nlink;
	477
	478	/* Owner's uid */
	479	sarray->base_addr[4 * stride] = sb.st_uid;
	480
	481	/* Owner's gid */
	482	sarray->base_addr[5 * stride] = sb.st_gid;
	483
	484	/* ID of device containing directory entry for file (0 if not available) */
	485	#if HAVE_STRUCT_STAT_ST_RDEV
	486	sarray->base_addr[6 * stride] = sb.st_rdev;
	487	#else
	488	sarray->base_addr[6 * stride] = 0;
	489	#endif
	490
	491	/* File size (bytes) */
	492	sarray->base_addr[7 * stride] = sb.st_size;
	493
	494	/* Last access time */
	495	sarray->base_addr[8 * stride] = sb.st_atime;
	496
	497	/* Last modification time */
	498	sarray->base_addr[9 * stride] = sb.st_mtime;
	499
	500	/* Last file status change time */
	501	sarray->base_addr[10 * stride] = sb.st_ctime;
	502
	503	/* Preferred I/O block size (-1 if not available) */
	504	#if HAVE_STRUCT_STAT_ST_BLKSIZE
	505	sarray->base_addr[11 * stride] = sb.st_blksize;
	506	#else
	507	sarray->base_addr[11 * stride] = -1;
	508	#endif
	509
	510	/* Number of blocks allocated (-1 if not available) */
	511	#if HAVE_STRUCT_STAT_ST_BLOCKS
	512	sarray->base_addr[12 * stride] = sb.st_blocks;
	513	#else
	514	sarray->base_addr[12 * stride] = -1;
	515	#endif
	516	}
	517
	518	if (status != NULL)
	519	*status = (val == 0) ? 0 : errno;
	520	}
	521	iexport(fstat_i8_sub);
	522
	523	extern GFC_INTEGER_4 fstat_i4 (GFC_INTEGER_4 , gfc_array_i4 );
	524	export_proto(fstat_i4);
	525
	526	GFC_INTEGER_4
	527	fstat_i4 (GFC_INTEGER_4 unit, gfc_array_i4 sarray)
	528	{
	529	GFC_INTEGER_4 val;
	530	fstat_i4_sub (unit, sarray, &val);
	531	return val;
	532	}
	533
	534	extern GFC_INTEGER_8 fstat_i8 (GFC_INTEGER_8 , gfc_array_i8 );
	535	export_proto(fstat_i8);
	536
	537	GFC_INTEGER_8
	538	fstat_i8 (GFC_INTEGER_8 unit, gfc_array_i8 sarray)
	539	{
	540	GFC_INTEGER_8 val;
	541	fstat_i8_sub (unit, sarray, &val);
	542	return val;
	543	}
	544
	545	#endif