2004-12-02 Steven G. Kargl <kargls@comcast.net>

	Paul Brook  <paul@codesourcery.com>

libgfortran/
	* intrinsics/flush.c: New file.
	* intrinsics/fnum.c: ditto
	* intrinsics/stat.c: ditto
	* io/io.h (unit_to_fd): Add prototype.
	* io/unix.c (unit_to_fd): New function.
	* configure.ac: Add test for members of struct stat.  Check for
	sys/types.h and sys/stat.h
	* Makefile.am: Add intrinsics/{flush.c,fnum.c,stat.c}
	* configure.in: Regenerate.
	* config.h.in: Regenerate.
	* Makefile.in: Regenerate.
fortran/
	* check.c (gfc_check_flush, gfc_check_fnum): New functions.
	(gfc_check_fstat, gfc_check_fstat_sub): New functions.
	(gfc_check_stat, gfc_check_stat_sub): New functions.
	* gfortran.h (GFC_ISYM_FNUM,GFC_ISYM_FSTAT,GFC_ISYM_STAT): New symbols
	* intrinsic.c (add_functions,add_subroutines): Add flush, fnum,
	fstat, and stat to intrinsics symbol tables.
	* intrinsic.h (gfc_check_flush, gfc_resolve_stat_sub): Add prototypes.
	(gfc_resolve_fstat_sub, gfc_resolve_stat): Ditto.
	* iresolve.c (gfc_resolve_fnum, gfc_resolve_fstat): New functions.
	(gfc_resolve_stat, gfc_resolve_flush): New functions.
	(gfc_resolve_stat_sub,gfc_resolve_fstat_sub): New functions
	* trans-intrinsic.c (gfc_conv_intrinsic_function): Add new intrinsics.


git-svn-id: https://gcc.gnu.org/svn/gcc/trunk@91611 138bc75d-0d04-0410-961f-82ee72b054a4

3 files changed, 564 insertions, 0 deletions

diff --git a/libgfortran/intrinsics/flush.c b/libgfortran/intrinsics/flush.c
new file mode 100644
index 00000000000..4603d709f48
--- /dev/null
+++ b/libgfortran/intrinsics/flush.c
@@ -0,0 +1,66 @@
+/* Implementation of the FLUSH intrinsic.
+   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_STDLIB_H
+#include <stdlib.h>
+#endif
+
+#include "../io/io.h"
+
+/* SUBROUTINE FLUSH(UNIT)
+   INTEGER, INTENT(IN), OPTIONAL :: UNIT  */
+
+static void
+recursive_flush (gfc_unit *us)
+{
+  /* There can be no open files.  */
+  if (us == NULL)
+    return;
+
+  flush (us->s);
+  recursive_flush (us->left);
+  recursive_flush (us->right);
+}
+
+
+void
+prefix(flush_i4) (GFC_INTEGER_4 * unit)
+{
+
+  gfc_unit *us;
+
+  /* flush all streams */
+  if (unit == NULL)
+    {
+      us = g.unit_root;
+      recursive_flush(us);
+    }
+  else
+    {
+      us = find_unit(*unit);
+      if (us != NULL)
+        flush (us->s);
+    }
+}
diff --git a/libgfortran/intrinsics/fnum.c b/libgfortran/intrinsics/fnum.c
new file mode 100644
index 00000000000..251cfb4e937
--- /dev/null
+++ b/libgfortran/intrinsics/fnum.c
@@ -0,0 +1,42 @@
+/* Implementation of the FNUM 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"
+
+#include "../io/io.h"
+
+/* FUNCTION FNUM(UNIT)
+   INTEGER FNUM
+   INTEGER, INTENT(IN), :: UNIT  */
+
+GFC_INTEGER_4
+prefix(fnum_i4) (GFC_INTEGER_4 * unit)
+{
+  return unit_to_fd (*unit);
+}
+
+
+GFC_INTEGER_8
+prefix(fnum_i8) (GFC_INTEGER_8 * unit)
+{
+  return unit_to_fd (*unit);
+}
diff --git a/libgfortran/intrinsics/stat.c b/libgfortran/intrinsics/stat.c
new file mode 100644
index 00000000000..e597e44aa1c
--- /dev/null
+++ b/libgfortran/intrinsics/stat.c
@@ -0,0 +1,456 @@
+/* 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)  */
+
+void
+prefix(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;
+}
+
+void
+prefix(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;
+}
+
+
+GFC_INTEGER_4
+prefix(stat_i4) (char * name, gfc_array_i4 * sarray,
+                 gfc_charlen_type name_len)
+{
+
+  GFC_INTEGER_4 val;
+  prefix(stat_i4_sub) (name, sarray, &val, name_len);
+  return val;
+}
+
+
+GFC_INTEGER_8
+prefix(stat_i8) (char * name, gfc_array_i8 * sarray,
+                 gfc_charlen_type name_len)
+{
+
+  GFC_INTEGER_8 val;
+  prefix(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)  */
+
+void
+prefix(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;
+}
+
+void
+prefix(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;
+}
+
+
+GFC_INTEGER_4
+prefix(fstat_i4) (GFC_INTEGER_4 * unit, gfc_array_i4 * sarray)
+{
+
+  GFC_INTEGER_4 val;
+  prefix(fstat_i4_sub) (unit, sarray, &val);
+  return val;
+}
+
+
+GFC_INTEGER_8
+prefix(fstat_i8) (GFC_INTEGER_8 * unit, gfc_array_i8 * sarray)
+{
+
+  GFC_INTEGER_8 val;
+  prefix(fstat_i8_sub) (unit, sarray, &val);
+  return val;
+}