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

/* Implementation of the STAT and FSTAT intrinsics.
   Copyright (C) 2004-2014 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.");

  /* Trim trailing spaces from name.  */
  while (name_len > 0 && name[name_len - 1] == ' ')
    name_len--;

  /* Make a null terminated copy of the string.  */
  str = gfc_alloca (name_len + 1);
  memcpy (str, name, name_len);
  str[name_len] = '\0';

  /* 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);

  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.");

  /* Trim trailing spaces from name.  */
  while (name_len > 0 && name[name_len - 1] == ' ')
    name_len--;

  /* Make a null terminated copy of the string.  */
  str = gfc_alloca (name_len + 1);
  memcpy (str, name, name_len);
  str[name_len] = '\0';

  /* 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);

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