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

/* Implementation of the STAT and FSTAT intrinsics.
   Copyright (C) 2004 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 Lesser General Public
License as published by the Free Software Foundation; either
version 2.1 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 Lesser General Public License for more details.

You should have received a copy of the GNU Lesser General Public
License along with libgfor; see the file COPYING.LIB.  If not,
write to the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
Boston, MA 02111-1307, 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>

#include "../io/io.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;

  index_type stride[GFC_MAX_DIMENSIONS - 1];
      
  /* 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.");

  if (sarray->dim[0].stride == 0)
    sarray->dim[0].stride = 1;

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

  index_type stride[GFC_MAX_DIMENSIONS - 1];
      
  /* 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.");

  if (sarray->dim[0].stride == 0)
    sarray->dim[0].stride = 1;

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

  index_type stride[GFC_MAX_DIMENSIONS - 1];
      
  /* 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.");

  if (sarray->dim[0].stride == 0)
    sarray->dim[0].stride = 1;

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

  index_type stride[GFC_MAX_DIMENSIONS - 1];
      
  /* 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.");

  if (sarray->dim[0].stride == 0)
    sarray->dim[0].stride = 1;

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