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

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

This file is part of the GNU Fortran 95 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 2 of the License, or (at your option) any later version.

In addition to the permissions in the GNU General Public License, the
Free Software Foundation gives you unlimited permission to link the
compiled version of this file into combinations with other programs,
and to distribute those combinations without any restriction coming
from the use of this file.  (The General Public License restrictions
do apply in other respects; for example, they cover modification of
the file, and distribution when not linked into a combine
executable.)

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.

You should have received a copy of the GNU General Public
License along with libgfortran; see the file COPYING.  If not,
write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
Boston, MA 02110-1301, USA.  */

#include "config.h"
#include "libgfortran.h"

#ifdef HAVE_SYS_TYPES_H
#include <sys/types.h>
#endif

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

#ifdef HAVE_STDLIB_H
#include <stdlib.h>
#endif

#ifdef HAVE_STRING_H
#include <string.h>
#endif

#include <errno.h>

/* 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 (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)
{
  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 (sarray->dim[0].ubound + 1 - sarray->dim[0].lbound < 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';

  val = stat(str, &sb);

  if (val == 0)
    {
      /* Device ID  */
      sarray->data[0 * sarray->dim[0].stride] = sb.st_dev;

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

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

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

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

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

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

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

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

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

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

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

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

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

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)
{
  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 (sarray->dim[0].ubound + 1 - sarray->dim[0].lbound < 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';

  val = stat(str, &sb);

  if (val == 0)
    {
      /* Device ID  */
      sarray->data[0] = sb.st_dev;

      /* Inode number  */
      sarray->data[sarray->dim[0].stride] = sb.st_ino;

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

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

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

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

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

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

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

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

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

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

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

  if (status != NULL)
    *status = (val == 0) ? 0 : errno;
}
iexport(stat_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 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 (sarray->dim[0].ubound + 1 - sarray->dim[0].lbound < 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)
    {
      /* Device ID  */
      sarray->data[0 * sarray->dim[0].stride] = sb.st_dev;

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

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

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

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

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

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

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

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

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

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

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

      /* Number of blocks allocated (-1 if not available)  */
#if HAVE_STRUCT_STAT_ST_BLOCKS
      sarray->data[12 * sarray->dim[0].stride] = sb.st_blocks;
#else
      sarray->data[12 * sarray->dim[0].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 (sarray->dim[0].ubound + 1 - sarray->dim[0].lbound < 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)
    {
      /* Device ID  */
      sarray->data[0] = sb.st_dev;

      /* Inode number  */
      sarray->data[sarray->dim[0].stride] = sb.st_ino;

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

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

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

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

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

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

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

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

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

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

      /* Number of blocks allocated (-1 if not available)  */
#if HAVE_STRUCT_STAT_ST_BLOCKS
      sarray->data[12 * sarray->dim[0].stride] = sb.st_blocks;
#else
      sarray->data[12 * sarray->dim[0].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;
}
Commit	Line	Data
f177a087	1	/* Implementation of the STAT and FSTAT intrinsics.
6ff24d45	2	Copyright (C) 2004, 2005, 2006 Free Software Foundation, Inc.
f177a087 SK	3	Contributed by Steven G. Kargl <kargls@comcast.net>.
	4
	5	This file is part of the GNU Fortran 95 runtime library (libgfortran).
	6
	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
57dea9f6 TM	10	version 2 of the License, or (at your option) any later version.
	11
	12	In addition to the permissions in the GNU General Public License, the
	13	Free Software Foundation gives you unlimited permission to link the
	14	compiled version of this file into combinations with other programs,
	15	and to distribute those combinations without any restriction coming
	16	from the use of this file. (The General Public License restrictions
	17	do apply in other respects; for example, they cover modification of
	18	the file, and distribution when not linked into a combine
	19	executable.)
f177a087 SK	20
	21	Libgfortran is distributed in the hope that it will be useful,
	22	but WITHOUT ANY WARRANTY; without even the implied warranty of
	23	MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
57dea9f6	24	GNU General Public License for more details.
f177a087	25
57dea9f6 TM	26	You should have received a copy of the GNU General Public
57dea9f6 TM	27	License along with libgfortran; see the file COPYING. If not,
fe2ae685 KC	28	write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
fe2ae685 KC	29	Boston, MA 02110-1301, USA. */
f177a087 SK	30
	31	#include "config.h"
	32	#include "libgfortran.h"
	33
	34	#ifdef HAVE_SYS_TYPES_H
	35	#include <sys/types.h>
	36	#endif
	37
	38	#ifdef HAVE_SYS_STAT_H
	39	#include <sys/stat.h>
	40	#endif
	41
	42	#ifdef HAVE_STDLIB_H
	43	#include <stdlib.h>
	44	#endif
	45
	46	#ifdef HAVE_STRING_H
	47	#include <string.h>
	48	#endif
	49
	50	#include <errno.h>
	51
f177a087 SK	52	/* SUBROUTINE STAT(FILE, SARRAY, STATUS)
	53	CHARACTER(len=*), INTENT(IN) :: FILE
	54	INTEGER, INTENT(OUT), :: SARRAY(13)
	55	INTEGER, INTENT(OUT), OPTIONAL :: STATUS
	56
	57	FUNCTION STAT(FILE, SARRAY)
	58	INTEGER STAT
	59	CHARACTER(len=*), INTENT(IN) :: FILE
	60	INTEGER, INTENT(OUT), :: SARRAY(13) */
	61
7d7b8bfe RH	62	extern void stat_i4_sub (char , gfc_array_i4 , GFC_INTEGER_4 *,
	63	gfc_charlen_type);
	64	iexport_proto(stat_i4_sub);
	65
f177a087	66	void
7d7b8bfe RH	67	stat_i4_sub (char name, gfc_array_i4 sarray, GFC_INTEGER_4 *status,
7d7b8bfe RH	68	gfc_charlen_type name_len)
f177a087	69	{
f177a087 SK	70	int val;
	71	char *str;
	72	struct stat sb;
	73
f177a087 SK	74	/* If the rank of the array is not 1, abort. */
	75	if (GFC_DESCRIPTOR_RANK (sarray) != 1)
	76	runtime_error ("Array rank of SARRAY is not 1.");
	77
	78	/* If the array is too small, abort. */
	79	if (sarray->dim[0].ubound + 1 - sarray->dim[0].lbound < 13)
7d7b8bfe	80	runtime_error ("Array size of SARRAY is too small.");
f177a087	81
f177a087 SK	82	/* Trim trailing spaces from name. */
	83	while (name_len > 0 && name[name_len - 1] == ' ')
	84	name_len--;
	85
	86	/* Make a null terminated copy of the string. */
	87	str = gfc_alloca (name_len + 1);
	88	memcpy (str, name, name_len);
deeab820	89	str[name_len] = '\0';
f177a087 SK	90
	91	val = stat(str, &sb);
	92
deeab820	93	if (val == 0)
f177a087 SK	94	{
	95	/* Device ID */
	96	sarray->data[0 * sarray->dim[0].stride] = sb.st_dev;
	97
	98	/* Inode number */
	99	sarray->data[1 * sarray->dim[0].stride] = sb.st_ino;
	100
	101	/* File mode */
	102	sarray->data[2 * sarray->dim[0].stride] = sb.st_mode;
	103
	104	/* Number of (hard) links */
	105	sarray->data[3 * sarray->dim[0].stride] = sb.st_nlink;
	106
	107	/* Owner's uid */
	108	sarray->data[4 * sarray->dim[0].stride] = sb.st_uid;
	109
	110	/* Owner's gid */
	111	sarray->data[5 * sarray->dim[0].stride] = sb.st_gid;
deeab820	112
f177a087 SK	113	/* ID of device containing directory entry for file (0 if not available) */
	114	#if HAVE_STRUCT_STAT_ST_RDEV
	115	sarray->data[6 * sarray->dim[0].stride] = sb.st_rdev;
	116	#else
	117	sarray->data[6 * sarray->dim[0].stride] = 0;
	118	#endif
	119
	120	/* File size (bytes) */
	121	sarray->data[7 * sarray->dim[0].stride] = sb.st_size;
	122
	123	/* Last access time */
	124	sarray->data[8 * sarray->dim[0].stride] = sb.st_atime;
	125
	126	/* Last modification time */
	127	sarray->data[9 * sarray->dim[0].stride] = sb.st_mtime;
	128
	129	/* Last file status change time */
	130	sarray->data[10 * sarray->dim[0].stride] = sb.st_ctime;
	131
	132	/* Preferred I/O block size (-1 if not available) */
	133	#if HAVE_STRUCT_STAT_ST_BLKSIZE
	134	sarray->data[11 * sarray->dim[0].stride] = sb.st_blksize;
	135	#else
	136	sarray->data[11 * sarray->dim[0].stride] = -1;
	137	#endif
	138
	139	/* Number of blocks allocated (-1 if not available) */
	140	#if HAVE_STRUCT_STAT_ST_BLOCKS
	141	sarray->data[12 * sarray->dim[0].stride] = sb.st_blocks;
	142	#else
	143	sarray->data[12 * sarray->dim[0].stride] = -1;
	144	#endif
	145	}
	146
deeab820	147	if (status != NULL)
f177a087 SK	148	*status = (val == 0) ? 0 : errno;
f177a087 SK	149	}
7d7b8bfe RH	150	iexport(stat_i4_sub);
	151
	152	extern void stat_i8_sub (char , gfc_array_i8 , GFC_INTEGER_8 *,
	153	gfc_charlen_type);
	154	iexport_proto(stat_i8_sub);
f177a087 SK	155
f177a087 SK	156	void
7d7b8bfe RH	157	stat_i8_sub (char name, gfc_array_i8 sarray, GFC_INTEGER_8 *status,
7d7b8bfe RH	158	gfc_charlen_type name_len)
f177a087	159	{
f177a087 SK	160	int val;
	161	char *str;
	162	struct stat sb;
	163
f177a087 SK	164	/* If the rank of the array is not 1, abort. */
	165	if (GFC_DESCRIPTOR_RANK (sarray) != 1)
	166	runtime_error ("Array rank of SARRAY is not 1.");
	167
	168	/* If the array is too small, abort. */
	169	if (sarray->dim[0].ubound + 1 - sarray->dim[0].lbound < 13)
7d7b8bfe	170	runtime_error ("Array size of SARRAY is too small.");
f177a087	171
f177a087 SK	172	/* Trim trailing spaces from name. */
	173	while (name_len > 0 && name[name_len - 1] == ' ')
	174	name_len--;
	175
	176	/* Make a null terminated copy of the string. */
	177	str = gfc_alloca (name_len + 1);
	178	memcpy (str, name, name_len);
deeab820	179	str[name_len] = '\0';
f177a087 SK	180
	181	val = stat(str, &sb);
	182
	183	if (val == 0)
	184	{
	185	/* Device ID */
	186	sarray->data[0] = sb.st_dev;
	187
	188	/* Inode number */
	189	sarray->data[sarray->dim[0].stride] = sb.st_ino;
	190
	191	/* File mode */
	192	sarray->data[2 * sarray->dim[0].stride] = sb.st_mode;
	193
	194	/* Number of (hard) links */
	195	sarray->data[3 * sarray->dim[0].stride] = sb.st_nlink;
deeab820	196
f177a087 SK	197	/* Owner's uid */
	198	sarray->data[4 * sarray->dim[0].stride] = sb.st_uid;
	199
	200	/* Owner's gid */
	201	sarray->data[5 * sarray->dim[0].stride] = sb.st_gid;
deeab820	202
f177a087 SK	203	/* ID of device containing directory entry for file (0 if not available) */
	204	#if HAVE_STRUCT_STAT_ST_RDEV
	205	sarray->data[6 * sarray->dim[0].stride] = sb.st_rdev;
	206	#else
	207	sarray->data[6 * sarray->dim[0].stride] = 0;
	208	#endif
	209
	210	/* File size (bytes) */
	211	sarray->data[7 * sarray->dim[0].stride] = sb.st_size;
	212
	213	/* Last access time */
	214	sarray->data[8 * sarray->dim[0].stride] = sb.st_atime;
	215
	216	/* Last modification time */
	217	sarray->data[9 * sarray->dim[0].stride] = sb.st_mtime;
	218
	219	/* Last file status change time */
	220	sarray->data[10 * sarray->dim[0].stride] = sb.st_ctime;
	221
	222	/* Preferred I/O block size (-1 if not available) */
	223	#if HAVE_STRUCT_STAT_ST_BLKSIZE
	224	sarray->data[11 * sarray->dim[0].stride] = sb.st_blksize;
	225	#else
	226	sarray->data[11 * sarray->dim[0].stride] = -1;
	227	#endif
	228
	229	/* Number of blocks allocated (-1 if not available) */
	230	#if HAVE_STRUCT_STAT_ST_BLOCKS
	231	sarray->data[12 * sarray->dim[0].stride] = sb.st_blocks;
	232	#else
	233	sarray->data[12 * sarray->dim[0].stride] = -1;
	234	#endif
	235	}
	236
deeab820	237	if (status != NULL)
f177a087 SK	238	*status = (val == 0) ? 0 : errno;
f177a087 SK	239	}
7d7b8bfe	240	iexport(stat_i8_sub);
f177a087	241
7d7b8bfe RH	242	extern GFC_INTEGER_4 stat_i4 (char , gfc_array_i4 , gfc_charlen_type);
7d7b8bfe RH	243	export_proto(stat_i4);
f177a087 SK	244
f177a087 SK	245	GFC_INTEGER_4
7d7b8bfe	246	stat_i4 (char name, gfc_array_i4 sarray, gfc_charlen_type name_len)
f177a087	247	{
f177a087	248	GFC_INTEGER_4 val;
7d7b8bfe	249	stat_i4_sub (name, sarray, &val, name_len);
f177a087 SK	250	return val;
	251	}
	252
7d7b8bfe RH	253	extern GFC_INTEGER_8 stat_i8 (char , gfc_array_i8 , gfc_charlen_type);
7d7b8bfe RH	254	export_proto(stat_i8);
f177a087 SK	255
f177a087 SK	256	GFC_INTEGER_8
7d7b8bfe	257	stat_i8 (char name, gfc_array_i8 sarray, gfc_charlen_type name_len)
f177a087	258	{
f177a087	259	GFC_INTEGER_8 val;
7d7b8bfe	260	stat_i8_sub (name, sarray, &val, name_len);
f177a087 SK	261	return val;
	262	}
	263
	264
	265	/* SUBROUTINE FSTAT(UNIT, SARRAY, STATUS)
deeab820	266	INTEGER, INTENT(IN) :: UNIT
f177a087	267	INTEGER, INTENT(OUT) :: SARRAY(13)
deeab820	268	INTEGER, INTENT(OUT), OPTIONAL :: STATUS
f177a087 SK	269
	270	FUNCTION FSTAT(UNIT, SARRAY)
	271	INTEGER FSTAT
deeab820	272	INTEGER, INTENT(IN) :: UNIT
f177a087 SK	273	INTEGER, INTENT(OUT) :: SARRAY(13) */
f177a087 SK	274
7d7b8bfe RH	275	extern void fstat_i4_sub (GFC_INTEGER_4 , gfc_array_i4 , GFC_INTEGER_4 *);
	276	iexport_proto(fstat_i4_sub);
	277
f177a087	278	void
7d7b8bfe	279	fstat_i4_sub (GFC_INTEGER_4 unit, gfc_array_i4 sarray, GFC_INTEGER_4 *status)
f177a087	280	{
f177a087 SK	281	int val;
	282	struct stat sb;
	283
f177a087 SK	284	/* If the rank of the array is not 1, abort. */
	285	if (GFC_DESCRIPTOR_RANK (sarray) != 1)
	286	runtime_error ("Array rank of SARRAY is not 1.");
	287
	288	/* If the array is too small, abort. */
	289	if (sarray->dim[0].ubound + 1 - sarray->dim[0].lbound < 13)
7d7b8bfe	290	runtime_error ("Array size of SARRAY is too small.");
f177a087	291
f177a087 SK	292	/* Convert Fortran unit number to C file descriptor. */
	293	val = unit_to_fd (*unit);
	294	if (val >= 0)
	295	val = fstat(val, &sb);
	296
	297	if (val == 0)
	298	{
	299	/* Device ID */
	300	sarray->data[0 * sarray->dim[0].stride] = sb.st_dev;
	301
	302	/* Inode number */
	303	sarray->data[1 * sarray->dim[0].stride] = sb.st_ino;
deeab820	304
f177a087 SK	305	/* File mode */
	306	sarray->data[2 * sarray->dim[0].stride] = sb.st_mode;
	307
	308	/* Number of (hard) links */
	309	sarray->data[3 * sarray->dim[0].stride] = sb.st_nlink;
	310
	311	/* Owner's uid */
	312	sarray->data[4 * sarray->dim[0].stride] = sb.st_uid;
	313
	314	/* Owner's gid */
	315	sarray->data[5 * sarray->dim[0].stride] = sb.st_gid;
deeab820	316
f177a087 SK	317	/* ID of device containing directory entry for file (0 if not available) */
	318	#if HAVE_STRUCT_STAT_ST_RDEV
	319	sarray->data[6 * sarray->dim[0].stride] = sb.st_rdev;
	320	#else
	321	sarray->data[6 * sarray->dim[0].stride] = 0;
	322	#endif
	323
	324	/* File size (bytes) */
	325	sarray->data[7 * sarray->dim[0].stride] = sb.st_size;
	326
	327	/* Last access time */
	328	sarray->data[8 * sarray->dim[0].stride] = sb.st_atime;
	329
	330	/* Last modification time */
	331	sarray->data[9 * sarray->dim[0].stride] = sb.st_mtime;
	332
	333	/* Last file status change time */
	334	sarray->data[10 * sarray->dim[0].stride] = sb.st_ctime;
	335
	336	/* Preferred I/O block size (-1 if not available) */
	337	#if HAVE_STRUCT_STAT_ST_BLKSIZE
	338	sarray->data[11 * sarray->dim[0].stride] = sb.st_blksize;
	339	#else
	340	sarray->data[11 * sarray->dim[0].stride] = -1;
	341	#endif
	342
	343	/* Number of blocks allocated (-1 if not available) */
	344	#if HAVE_STRUCT_STAT_ST_BLOCKS
	345	sarray->data[12 * sarray->dim[0].stride] = sb.st_blocks;
	346	#else
	347	sarray->data[12 * sarray->dim[0].stride] = -1;
	348	#endif
	349	}
	350
deeab820	351	if (status != NULL)
f177a087 SK	352	*status = (val == 0) ? 0 : errno;
f177a087 SK	353	}
7d7b8bfe RH	354	iexport(fstat_i4_sub);
	355
	356	extern void fstat_i8_sub (GFC_INTEGER_8 , gfc_array_i8 , GFC_INTEGER_8 *);
	357	iexport_proto(fstat_i8_sub);
f177a087 SK	358
f177a087 SK	359	void
7d7b8bfe	360	fstat_i8_sub (GFC_INTEGER_8 unit, gfc_array_i8 sarray, GFC_INTEGER_8 *status)
f177a087	361	{
f177a087 SK	362	int val;
	363	struct stat sb;
	364
f177a087 SK	365	/* If the rank of the array is not 1, abort. */
	366	if (GFC_DESCRIPTOR_RANK (sarray) != 1)
	367	runtime_error ("Array rank of SARRAY is not 1.");
	368
	369	/* If the array is too small, abort. */
	370	if (sarray->dim[0].ubound + 1 - sarray->dim[0].lbound < 13)
7d7b8bfe	371	runtime_error ("Array size of SARRAY is too small.");
f177a087	372
f177a087 SK	373	/* Convert Fortran unit number to C file descriptor. */
	374	val = unit_to_fd ((int) *unit);
	375	if (val >= 0)
	376	val = fstat(val, &sb);
	377
	378	if (val == 0)
	379	{
	380	/* Device ID */
	381	sarray->data[0] = sb.st_dev;
	382
	383	/* Inode number */
	384	sarray->data[sarray->dim[0].stride] = sb.st_ino;
	385
	386	/* File mode */
	387	sarray->data[2 * sarray->dim[0].stride] = sb.st_mode;
	388
	389	/* Number of (hard) links */
	390	sarray->data[3 * sarray->dim[0].stride] = sb.st_nlink;
	391
	392	/* Owner's uid */
	393	sarray->data[4 * sarray->dim[0].stride] = sb.st_uid;
	394
	395	/* Owner's gid */
	396	sarray->data[5 * sarray->dim[0].stride] = sb.st_gid;
deeab820	397
f177a087 SK	398	/* ID of device containing directory entry for file (0 if not available) */
	399	#if HAVE_STRUCT_STAT_ST_RDEV
	400	sarray->data[6 * sarray->dim[0].stride] = sb.st_rdev;
	401	#else
	402	sarray->data[6 * sarray->dim[0].stride] = 0;
	403	#endif
	404
	405	/* File size (bytes) */
	406	sarray->data[7 * sarray->dim[0].stride] = sb.st_size;
	407
	408	/* Last access time */
	409	sarray->data[8 * sarray->dim[0].stride] = sb.st_atime;
	410
	411	/* Last modification time */
	412	sarray->data[9 * sarray->dim[0].stride] = sb.st_mtime;
	413
	414	/* Last file status change time */
	415	sarray->data[10 * sarray->dim[0].stride] = sb.st_ctime;
	416
	417	/* Preferred I/O block size (-1 if not available) */
	418	#if HAVE_STRUCT_STAT_ST_BLKSIZE
	419	sarray->data[11 * sarray->dim[0].stride] = sb.st_blksize;
	420	#else
	421	sarray->data[11 * sarray->dim[0].stride] = -1;
	422	#endif
	423
	424	/* Number of blocks allocated (-1 if not available) */
	425	#if HAVE_STRUCT_STAT_ST_BLOCKS
	426	sarray->data[12 * sarray->dim[0].stride] = sb.st_blocks;
	427	#else
	428	sarray->data[12 * sarray->dim[0].stride] = -1;
	429	#endif
	430	}
	431
deeab820	432	if (status != NULL)
f177a087 SK	433	*status = (val == 0) ? 0 : errno;
f177a087 SK	434	}
7d7b8bfe	435	iexport(fstat_i8_sub);
f177a087	436
7d7b8bfe RH	437	extern GFC_INTEGER_4 fstat_i4 (GFC_INTEGER_4 , gfc_array_i4 );
7d7b8bfe RH	438	export_proto(fstat_i4);
f177a087 SK	439
f177a087 SK	440	GFC_INTEGER_4
7d7b8bfe	441	fstat_i4 (GFC_INTEGER_4 unit, gfc_array_i4 sarray)
f177a087	442	{
f177a087	443	GFC_INTEGER_4 val;
7d7b8bfe	444	fstat_i4_sub (unit, sarray, &val);
f177a087 SK	445	return val;
	446	}
	447
7d7b8bfe RH	448	extern GFC_INTEGER_8 fstat_i8 (GFC_INTEGER_8 , gfc_array_i8 );
7d7b8bfe RH	449	export_proto(fstat_i8);
f177a087 SK	450
f177a087 SK	451	GFC_INTEGER_8
7d7b8bfe	452	fstat_i8 (GFC_INTEGER_8 unit, gfc_array_i8 sarray)
f177a087	453	{
f177a087	454	GFC_INTEGER_8 val;
7d7b8bfe	455	fstat_i8_sub (unit, sarray, &val);
f177a087 SK	456	return val;
f177a087 SK	457	}