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

/* Implementation of the STAT and FSTAT intrinsics.
   Copyright (C) 2004-2015 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 <string.h>
#include <errno.h>

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

#include <stdlib.h>


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