This is the mail archive of the gcc-patches@gcc.gnu.org mailing list for the GCC project.


Index Nav: [Date Index] [Subject Index] [Author Index] [Thread Index]
Message Nav: [Date Prev] [Date Next] [Thread Prev] [Thread Next]
Other format: [Raw text]

Re: [PATCH, gfortran] g77's FNUM, STAT, FSTAT, and FLUSH intrinsics


On Sunday 28 November 2004 17:02, Steve Kargl wrote:
> I have implemented FLUSH via Janne's comments.  That is, I have
> left struct unix_stream in unix.c and left fd_flush() with its
> static declaration.  FLUSH now uses Janne's flush() wrapper, which
> is simply a redirection via a cast of *stream to a *unix_stream.
>
> This has been bootstrapped and regression tested with no new regressions
> on i386-unknown-freebsd6.0.

Your type kind handling is broken.  These functions should accept any integer 
kind for the intent(in) arguments, and require default integer kind for 
intent(out) arguments.

For example:
i = fnum(j_8) ! legal
i = fnum(j_1) ! legal
call fstat (i_1, a, s) ! legal
call fstat(i, a, s_2) ! illegal
i = fstat(i_8, a_8) ! illegal

You probably need to go back and check the other intrinsics that have been 
added recently for similar bugs.

Modified and applied as attached.
Tested on i686-linux.

Paul

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.
Index: gcc/fortran/check.c
===================================================================
RCS file: /var/cvsroot/gcc-cvs/gcc/gcc/fortran/check.c,v
retrieving revision 1.17
diff -u -p -r1.17 check.c
--- gcc/fortran/check.c	20 Nov 2004 01:44:45 -0000	1.17
+++ gcc/fortran/check.c	2 Dec 2004 03:42:34 -0000
@@ -750,6 +750,20 @@ gfc_check_eoshift (gfc_expr * array, gfc
 }
 
 
+try
+gfc_check_fnum (gfc_expr * unit)
+{
+
+  if (type_check (unit, 0, BT_INTEGER) == FAILURE)
+    return FAILURE;
+
+  if (scalar_check (unit, 0) == FAILURE)
+    return FAILURE;
+
+  return SUCCESS;
+}
+
+
 /* This is used for the g77 one-argument Bessel functions, and the
    error function.  */
 
@@ -1623,6 +1637,7 @@ gfc_check_spread (gfc_expr * source, gfc
 
   if (type_check (ncopies, 2, BT_INTEGER) == FAILURE)
     return FAILURE;
+
   if (scalar_check (ncopies, 2) == FAILURE)
     return FAILURE;
 
@@ -1631,6 +1646,104 @@ gfc_check_spread (gfc_expr * source, gfc
 
 
 try
+gfc_check_fstat (gfc_expr * unit, gfc_expr * array)
+{
+
+  if (type_check (unit, 0, BT_INTEGER) == FAILURE)
+    return FAILURE;
+
+  if (scalar_check (unit, 0) == FAILURE)
+    return FAILURE;
+
+  if (type_check (array, 1, BT_INTEGER) == FAILURE
+      || kind_value_check (unit, 0, gfc_default_integer_kind) == FAILURE)
+    return FAILURE;
+
+  if (array_check (array, 1) == FAILURE)
+    return FAILURE;
+
+  return SUCCESS;
+}
+
+
+try
+gfc_check_fstat_sub (gfc_expr * unit, gfc_expr * array, gfc_expr * status)
+{
+
+  if (type_check (unit, 0, BT_INTEGER) == FAILURE)
+    return FAILURE;
+
+  if (scalar_check (unit, 0) == FAILURE)
+    return FAILURE;
+
+  if (type_check (array, 1, BT_INTEGER) == FAILURE
+      || kind_value_check (array, 1, gfc_default_integer_kind) == FAILURE)
+    return FAILURE;
+
+  if (array_check (array, 1) == FAILURE)
+    return FAILURE;
+
+  if (status == NULL)
+    return SUCCESS;
+
+  if (type_check (status, 2, BT_INTEGER) == FAILURE
+      || kind_value_check (status, 2, gfc_default_integer_kind) == FAILURE)
+    return FAILURE;
+
+  if (scalar_check (status, 2) == FAILURE)
+    return FAILURE;
+
+  return SUCCESS;
+}
+
+
+try
+gfc_check_stat (gfc_expr * name, gfc_expr * array)
+{
+
+  if (type_check (name, 0, BT_CHARACTER) == FAILURE)
+    return FAILURE;
+
+  if (type_check (array, 1, BT_INTEGER) == FAILURE
+      || kind_value_check (array, 1, gfc_default_integer_kind) == FAILURE)
+    return FAILURE;
+
+  if (array_check (array, 1) == FAILURE)
+    return FAILURE;
+
+  return SUCCESS;
+}
+
+
+try
+gfc_check_stat_sub (gfc_expr * name, gfc_expr * array, gfc_expr * status)
+{
+
+  if (type_check (name, 0, BT_CHARACTER) == FAILURE)
+    return FAILURE;
+
+  if (type_check (array, 1, BT_INTEGER) == FAILURE
+      || kind_value_check (array, 1, gfc_default_integer_kind) == FAILURE)
+    return FAILURE;
+
+  if (array_check (array, 1) == FAILURE)
+    return FAILURE;
+
+  if (status == NULL)
+    return SUCCESS;
+
+  if (type_check (status, 2, BT_INTEGER) == FAILURE
+      || kind_value_check (array, 1, gfc_default_integer_kind) == FAILURE)
+    return FAILURE;
+
+  if (scalar_check (status, 2) == FAILURE)
+    return FAILURE;
+
+  return SUCCESS;
+}
+
+
+try
 gfc_check_transfer (gfc_expr * source ATTRIBUTE_UNUSED,
 		    gfc_expr * mold ATTRIBUTE_UNUSED,
 		    gfc_expr * size)
@@ -2139,6 +2252,23 @@ gfc_check_exit (gfc_expr * status)
 
 
 try
+gfc_check_flush (gfc_expr * unit)
+{
+  
+  if (unit == NULL)
+    return SUCCESS;
+
+  if (type_check (unit, 0, BT_INTEGER) == FAILURE)
+    return FAILURE;
+
+  if (scalar_check (unit, 0) == FAILURE)
+    return FAILURE;
+
+  return SUCCESS;
+}
+
+
+try
 gfc_check_umask (gfc_expr * mask)
 {
 
Index: gcc/fortran/gfortran.h
===================================================================
RCS file: /var/cvsroot/gcc-cvs/gcc/gcc/fortran/gfortran.h,v
retrieving revision 1.43
diff -u -p -r1.43 gfortran.h
--- gcc/fortran/gfortran.h	20 Nov 2004 01:44:45 -0000	1.43
+++ gcc/fortran/gfortran.h	2 Dec 2004 02:41:41 -0000
@@ -315,7 +315,9 @@ enum gfc_generic_isym_id
   GFC_ISYM_EXP,
   GFC_ISYM_EXPONENT,
   GFC_ISYM_FLOOR,
+  GFC_ISYM_FNUM,
   GFC_ISYM_FRACTION,
+  GFC_ISYM_FSTAT,
   GFC_ISYM_GETCWD,
   GFC_ISYM_GETGID,
   GFC_ISYM_GETPID,
@@ -379,6 +381,7 @@ enum gfc_generic_isym_id
   GFC_ISYM_SPREAD,
   GFC_ISYM_SQRT,
   GFC_ISYM_SR_KIND,
+  GFC_ISYM_STAT,
   GFC_ISYM_SUM,
   GFC_ISYM_SYSTEM,
   GFC_ISYM_TAN,
Index: gcc/fortran/intrinsic.c
===================================================================
RCS file: /var/cvsroot/gcc-cvs/gcc/gcc/fortran/intrinsic.c,v
retrieving revision 1.31
diff -u -p -r1.31 intrinsic.c
--- gcc/fortran/intrinsic.c	2 Dec 2004 01:34:26 -0000	1.31
+++ gcc/fortran/intrinsic.c	2 Dec 2004 02:45:35 -0000
@@ -857,7 +857,7 @@ add_functions (void)
     *s = "s", *dm = "dim", *kind = "kind", *msk = "mask",
     *x = "x", *sh = "shift", *stg = "string", *ssg = "substring",
     *y = "y", *sz = "size", *sta = "string_a", *stb = "string_b",
-    *z = "z", *ln = "len";
+    *z = "z", *ln = "len", *ut = "unit";
 
   int di, dr, dd, dl, dc, dz, ii;
 
@@ -1280,12 +1280,25 @@ add_functions (void)
 
   make_generic ("floor", GFC_ISYM_FLOOR, GFC_STD_F95);
 
+  /* G77 compatible fnum */
+  add_sym_1 ("fnum", 0, 1, BT_INTEGER, di, GFC_STD_GNU,
+	     gfc_check_fnum, NULL, gfc_resolve_fnum,
+	     ut, BT_INTEGER, di, REQUIRED);
+
+  make_generic ("fnum", GFC_ISYM_FNUM, GFC_STD_GNU);
+
   add_sym_1 ("fraction", 1, 1, BT_REAL, dr, GFC_STD_F95,
 	     gfc_check_x, gfc_simplify_fraction, gfc_resolve_fraction,
 	     x, BT_REAL, dr, REQUIRED);
 
   make_generic ("fraction", GFC_ISYM_FRACTION, GFC_STD_F95);
 
+  add_sym_2 ("fstat", 0, 1, BT_INTEGER, di, GFC_STD_GNU,
+	     gfc_check_fstat, NULL, gfc_resolve_fstat,
+	     a, BT_INTEGER, di, REQUIRED, b, BT_INTEGER, di, REQUIRED);
+
+  make_generic ("fstat", GFC_ISYM_FSTAT, GFC_STD_GNU);
+
   /* Unix IDs (g77 compatibility)  */
   add_sym_1 ("getcwd", 0, 1, BT_INTEGER, di,  GFC_STD_GNU,
 	     NULL, NULL, gfc_resolve_getcwd,
@@ -1876,6 +1889,12 @@ add_functions (void)
 
   make_generic ("sqrt", GFC_ISYM_SQRT, GFC_STD_F77);
 
+  add_sym_2 ("stat", 0, 1, BT_INTEGER, di, GFC_STD_GNU,
+	     gfc_check_stat, NULL, gfc_resolve_stat,
+	     a, BT_CHARACTER, dc, REQUIRED, b, BT_INTEGER, di, REQUIRED);
+
+  make_generic ("stat", GFC_ISYM_STAT, GFC_STD_GNU);
+
   add_sym_3red ("sum", 0, 1, BT_UNKNOWN, 0, GFC_STD_F95,
                 gfc_check_product_sum, NULL, gfc_resolve_sum,
 		ar, BT_REAL, dr, REQUIRED, dm, BT_INTEGER, ii, OPTIONAL,
@@ -1983,7 +2002,7 @@ add_subroutines (void)
     *f = "from", *sz = "size", *ln = "len", *cr = "count_rate",
     *com = "command", *length = "length", *st = "status",
     *val = "value", *num = "number", *name = "name",
-    *trim_name = "trim_name";
+    *trim_name = "trim_name", *ut = "unit";
 
   int di, dr, dc, dl;
 
@@ -2073,6 +2092,20 @@ add_subroutines (void)
              gfc_check_exit, NULL, gfc_resolve_exit,
 	      c, BT_INTEGER, di, OPTIONAL);
 
+  add_sym_1s ("flush", 0, 1, BT_UNKNOWN, 0, GFC_STD_GNU,
+	      gfc_check_flush, NULL, gfc_resolve_flush,
+	      c, BT_INTEGER, di, OPTIONAL);
+
+  add_sym_3s ("fstat", 0, 1, BT_UNKNOWN, 0, GFC_STD_GNU,
+	      gfc_check_fstat_sub, NULL, gfc_resolve_fstat_sub,
+	      ut, BT_INTEGER, di, REQUIRED, vl, BT_INTEGER, di, REQUIRED,
+	      st, BT_INTEGER, di, OPTIONAL);
+
+  add_sym_3s ("stat", 0, 1, BT_UNKNOWN, 0, GFC_STD_GNU,
+	      gfc_check_stat_sub, NULL, gfc_resolve_stat_sub,
+	      name, BT_CHARACTER, dc, REQUIRED, vl, BT_INTEGER, di, REQUIRED,
+	      st, BT_INTEGER, di, OPTIONAL);
+
   add_sym_2s ("system", 0, 1, BT_UNKNOWN, 0, GFC_STD_GNU,
 	      NULL, NULL, gfc_resolve_system_sub,
 	      c, BT_CHARACTER, dc, REQUIRED, st, BT_INTEGER, di, OPTIONAL);
Index: gcc/fortran/intrinsic.h
===================================================================
RCS file: /var/cvsroot/gcc-cvs/gcc/gcc/fortran/intrinsic.h,v
retrieving revision 1.19
diff -u -p -r1.19 intrinsic.h
--- gcc/fortran/intrinsic.h	20 Nov 2004 01:44:45 -0000	1.19
+++ gcc/fortran/intrinsic.h	2 Dec 2004 02:41:41 -0000
@@ -47,6 +47,8 @@ try gfc_check_digits (gfc_expr *);
 try gfc_check_dot_product (gfc_expr *, gfc_expr *);
 try gfc_check_eoshift (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *);
 try gfc_check_etime (gfc_expr *);
+try gfc_check_fstat (gfc_expr *, gfc_expr *);
+try gfc_check_fnum (gfc_expr *);
 try gfc_check_g77_math1 (gfc_expr *);
 try gfc_check_huge (gfc_expr *);
 try gfc_check_i (gfc_expr *);
@@ -95,6 +97,7 @@ try gfc_check_size (gfc_expr *, gfc_expr
 try gfc_check_sign (gfc_expr *, gfc_expr *);
 try gfc_check_spread (gfc_expr *, gfc_expr *, gfc_expr *);
 try gfc_check_srand (gfc_expr *);
+try gfc_check_stat (gfc_expr *, gfc_expr *);
 try gfc_check_sum (gfc_expr *, gfc_expr *, gfc_expr *);
 try gfc_check_transfer (gfc_expr *, gfc_expr *, gfc_expr *);
 try gfc_check_transpose (gfc_expr *);
@@ -112,12 +115,15 @@ try gfc_check_cpu_time (gfc_expr *);
 try gfc_check_system_clock (gfc_expr *, gfc_expr *, gfc_expr *);
 try gfc_check_date_and_time (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *);
 try gfc_check_exit (gfc_expr *);
+try gfc_check_flush (gfc_expr *);
+try gfc_check_fstat_sub (gfc_expr *, gfc_expr *, gfc_expr *);
 try gfc_check_mvbits (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *,
 		      gfc_expr *);
 try gfc_check_random_number (gfc_expr *);
 try gfc_check_random_seed (gfc_expr *, gfc_expr *, gfc_expr *);
 try gfc_check_etime_sub (gfc_expr *, gfc_expr *);
 try gfc_check_getcwd_sub (gfc_expr *, gfc_expr *);
+try gfc_check_stat_sub (gfc_expr *, gfc_expr *, gfc_expr *);
 try gfc_check_system_sub (gfc_expr *, gfc_expr *);
 try gfc_check_umask_sub (gfc_expr *, gfc_expr *);
 try gfc_check_unlink_sub (gfc_expr *, gfc_expr *);
@@ -261,7 +267,9 @@ void gfc_resolve_etime_sub (gfc_code *);
 void gfc_resolve_exp (gfc_expr *, gfc_expr *);
 void gfc_resolve_exponent (gfc_expr *, gfc_expr *);
 void gfc_resolve_floor (gfc_expr *, gfc_expr *, gfc_expr *);
+void gfc_resolve_fnum (gfc_expr *, gfc_expr *);
 void gfc_resolve_fraction (gfc_expr *, gfc_expr *);
+void gfc_resolve_fstat (gfc_expr *, gfc_expr *, gfc_expr *);
 void gfc_resolve_g77_math1 (gfc_expr *, gfc_expr *);
 void gfc_resolve_getcwd (gfc_expr *, gfc_expr *);
 void gfc_resolve_getgid (gfc_expr *);
@@ -315,6 +323,7 @@ void gfc_resolve_sinh (gfc_expr *, gfc_e
 void gfc_resolve_spacing (gfc_expr *, gfc_expr *);
 void gfc_resolve_spread (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *);
 void gfc_resolve_sqrt (gfc_expr *, gfc_expr *);
+void gfc_resolve_stat (gfc_expr *, gfc_expr *, gfc_expr *);
 void gfc_resolve_srand (gfc_code *);
 void gfc_resolve_sum (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *);
 void gfc_resolve_system (gfc_expr *, gfc_expr *);
@@ -333,6 +342,8 @@ void gfc_resolve_verify (gfc_expr *, gfc
 /* Intrinsic subroutine resolution.  */
 void gfc_resolve_cpu_time (gfc_code *);
 void gfc_resolve_exit (gfc_code *);
+void gfc_resolve_flush (gfc_code *);
+void gfc_resolve_fstat_sub (gfc_code *);
 void gfc_resolve_getarg (gfc_code *);
 void gfc_resolve_getcwd_sub (gfc_code *);
 void gfc_resolve_get_command (gfc_code *);
@@ -340,6 +351,7 @@ void gfc_resolve_get_command_argument (g
 void gfc_resolve_get_environment_variable (gfc_code *);
 void gfc_resolve_mvbits (gfc_code *);
 void gfc_resolve_random_number (gfc_code *);
+void gfc_resolve_stat_sub (gfc_code *);
 void gfc_resolve_system_clock (gfc_code *);
 void gfc_resolve_system_sub (gfc_code *);
 void gfc_resolve_umask_sub (gfc_code *);
Index: gcc/fortran/iresolve.c
===================================================================
RCS file: /var/cvsroot/gcc-cvs/gcc/gcc/fortran/iresolve.c,v
retrieving revision 1.22
diff -u -p -r1.22 iresolve.c
--- gcc/fortran/iresolve.c	20 Nov 2004 01:44:45 -0000	1.22
+++ gcc/fortran/iresolve.c	2 Dec 2004 03:42:18 -0000
@@ -553,6 +553,18 @@ gfc_resolve_floor (gfc_expr * f, gfc_exp
 
 
 void
+gfc_resolve_fnum (gfc_expr * f, gfc_expr * n)
+{
+
+  f->ts.type = BT_INTEGER;
+  f->ts.kind = gfc_default_integer_kind;
+  if (n->ts.kind != f->ts.kind)
+    gfc_convert_type (n, &f->ts, 2);
+  f->value.function.name = gfc_get_string (PREFIX("fnum_i%d"), f->ts.kind);
+}
+
+
+void
 gfc_resolve_fraction (gfc_expr * f, gfc_expr * x)
 {
 
@@ -1283,6 +1295,32 @@ gfc_resolve_sqrt (gfc_expr * f, gfc_expr
 }
 
 
+/* Resolve the g77 compatibility function STAT AND FSTAT.  */
+
+void
+gfc_resolve_stat (gfc_expr * f, gfc_expr * n ATTRIBUTE_UNUSED,
+		  gfc_expr * a ATTRIBUTE_UNUSED)
+{
+
+  f->ts.type = BT_INTEGER;
+  f->ts.kind = gfc_default_integer_kind;
+  f->value.function.name = gfc_get_string (PREFIX("stat_i%d"), f->ts.kind);
+}
+
+
+void
+gfc_resolve_fstat (gfc_expr * f, gfc_expr * n, gfc_expr * a ATTRIBUTE_UNUSED)
+{
+
+  f->ts.type = BT_INTEGER;
+  f->ts.kind = gfc_default_integer_kind;
+  if (n->ts.kind != f->ts.kind)
+    gfc_convert_type (n, &f->ts, 2);
+
+  f->value.function.name = gfc_get_string (PREFIX("fstat_i%d"), f->ts.kind);
+}
+
+
 void
 gfc_resolve_sum (gfc_expr * f, gfc_expr * array, gfc_expr * dim,
 		 gfc_expr * mask)
@@ -1679,6 +1717,53 @@ gfc_resolve_exit (gfc_code * c)
   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
 }
 
+/* Resolve the FLUSH intrinsic subroutine.  */
+
+void
+gfc_resolve_flush (gfc_code * c)
+{
+  const char *name;
+  gfc_typespec ts;
+  gfc_expr *n;
+
+  ts.type = BT_INTEGER;
+  ts.kind = gfc_default_integer_kind;
+  n = c->ext.actual->expr;
+  if (n != NULL
+      && n->ts.kind != ts.kind)
+    gfc_convert_type (n, &ts, 2);
+
+  name = gfc_get_string (PREFIX("flush_i%d"), ts.kind);
+  c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
+}
+
+/* Resolve the STAT and FSTAT intrinsic subroutines.  */
+
+void
+gfc_resolve_stat_sub (gfc_code * c)
+{
+  const char *name;
+
+  name = gfc_get_string (PREFIX("stat_i%d_sub"), gfc_default_integer_kind);
+  c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
+}
+
+
+void
+gfc_resolve_fstat_sub (gfc_code * c)
+{
+  const char *name;
+  gfc_expr *u;
+  gfc_typespec *ts;
+
+  u = c->ext.actual->expr;
+  ts = &c->ext.actual->next->expr->ts;
+  if (u->ts.kind != ts->kind)
+    gfc_convert_type (u, ts, 2);
+  name = gfc_get_string (PREFIX("fstat_i%d_sub"), ts->kind);
+  c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
+}
+
 /* Resolve the UMASK intrinsic subroutine.  */
 
 void
Index: gcc/fortran/trans-intrinsic.c
===================================================================
RCS file: /var/cvsroot/gcc-cvs/gcc/gcc/fortran/trans-intrinsic.c,v
retrieving revision 1.31
diff -u -p -r1.31 trans-intrinsic.c
--- gcc/fortran/trans-intrinsic.c	20 Nov 2004 01:44:45 -0000	1.31
+++ gcc/fortran/trans-intrinsic.c	2 Dec 2004 02:41:41 -0000
@@ -2964,15 +2964,18 @@ gfc_conv_intrinsic_function (gfc_se * se
       break;
 
     case GFC_ISYM_DOT_PRODUCT:
-    case GFC_ISYM_MATMUL:
-    case GFC_ISYM_IRAND:
-    case GFC_ISYM_RAND:
     case GFC_ISYM_ETIME:
-    case GFC_ISYM_SECOND:
+    case GFC_ISYM_FNUM:
+    case GFC_ISYM_FSTAT:
     case GFC_ISYM_GETCWD:
     case GFC_ISYM_GETGID:
     case GFC_ISYM_GETPID:
     case GFC_ISYM_GETUID:
+    case GFC_ISYM_IRAND:
+    case GFC_ISYM_MATMUL:
+    case GFC_ISYM_RAND:
+    case GFC_ISYM_SECOND:
+    case GFC_ISYM_STAT:
     case GFC_ISYM_SYSTEM:
     case GFC_ISYM_UMASK:
     case GFC_ISYM_UNLINK:
Index: libgfortran/Makefile.am
===================================================================
RCS file: /var/cvsroot/gcc-cvs/gcc/libgfortran/Makefile.am,v
retrieving revision 1.24
diff -u -p -r1.24 Makefile.am
--- libgfortran/Makefile.am	2 Dec 2004 00:42:12 -0000	1.24
+++ libgfortran/Makefile.am	2 Dec 2004 02:37:58 -0000
@@ -53,6 +53,8 @@ intrinsics/eoshift0.c \
 intrinsics/eoshift2.c \
 intrinsics/etime.c \
 intrinsics/exit.c \
+intrinsics/flush.c \
+intrinsics/fnum.c \
 intrinsics/getcwd.c \
 intrinsics/getXid.c \
 intrinsics/ishftc.c \
@@ -68,6 +70,7 @@ intrinsics/reshape_generic.c \
 intrinsics/reshape_packed.c \
 intrinsics/selected_int_kind.f90 \
 intrinsics/selected_real_kind.f90 \
+intrinsics/stat.c \
 intrinsics/system_clock.c \
 intrinsics/transpose_generic.c \
 intrinsics/umask.c \
Index: libgfortran/Makefile.in
===================================================================
RCS file: /var/cvsroot/gcc-cvs/gcc/libgfortran/Makefile.in,v
retrieving revision 1.24
diff -u -p -r1.24 Makefile.in
--- libgfortran/Makefile.in	2 Dec 2004 00:42:12 -0000	1.24
+++ libgfortran/Makefile.in	2 Dec 2004 02:38:13 -0000
@@ -128,12 +128,13 @@ am__objects_32 = backspace.lo close.lo e
 am__objects_33 = associated.lo abort.lo args.lo bessel.lo \
 	c99_functions.lo cpu_time.lo cshift0.lo date_and_time.lo \
 	env.lo erf.lo eoshift0.lo eoshift2.lo etime.lo exit.lo \
-	getcwd.lo getXid.lo ishftc.lo mvbits.lo pack_generic.lo \
-	size.lo spread_generic.lo string_intrinsics.lo system.lo \
-	rand.lo random.lo reshape_generic.lo reshape_packed.lo \
-	selected_int_kind.lo selected_real_kind.lo system_clock.lo \
-	transpose_generic.lo umask.lo unlink.lo unpack_generic.lo \
-	in_pack_generic.lo in_unpack_generic.lo normalize.lo
+	flush.lo fnum.lo getcwd.lo getXid.lo ishftc.lo mvbits.lo \
+	pack_generic.lo size.lo spread_generic.lo string_intrinsics.lo \
+	system.lo rand.lo random.lo reshape_generic.lo \
+	reshape_packed.lo selected_int_kind.lo selected_real_kind.lo \
+	stat.lo system_clock.lo transpose_generic.lo umask.lo \
+	unlink.lo unpack_generic.lo in_pack_generic.lo \
+	in_unpack_generic.lo normalize.lo
 am__objects_34 =
 am__objects_35 = _abs_c4.lo _abs_c8.lo _abs_i4.lo _abs_i8.lo \
 	_abs_r4.lo _abs_r8.lo _exp_r4.lo _exp_r8.lo _exp_c4.lo \
@@ -333,6 +334,8 @@ intrinsics/eoshift0.c \
 intrinsics/eoshift2.c \
 intrinsics/etime.c \
 intrinsics/exit.c \
+intrinsics/flush.c \
+intrinsics/fnum.c \
 intrinsics/getcwd.c \
 intrinsics/getXid.c \
 intrinsics/ishftc.c \
@@ -348,6 +351,7 @@ intrinsics/reshape_generic.c \
 intrinsics/reshape_packed.c \
 intrinsics/selected_int_kind.f90 \
 intrinsics/selected_real_kind.f90 \
+intrinsics/stat.c \
 intrinsics/system_clock.c \
 intrinsics/transpose_generic.c \
 intrinsics/umask.c \
@@ -1224,6 +1228,12 @@ etime.lo: intrinsics/etime.c
 exit.lo: intrinsics/exit.c
 	$(LIBTOOL) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o exit.lo `test -f 'intrinsics/exit.c' || echo '$(srcdir)/'`intrinsics/exit.c
 
+flush.lo: intrinsics/flush.c
+	$(LIBTOOL) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o flush.lo `test -f 'intrinsics/flush.c' || echo '$(srcdir)/'`intrinsics/flush.c
+
+fnum.lo: intrinsics/fnum.c
+	$(LIBTOOL) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o fnum.lo `test -f 'intrinsics/fnum.c' || echo '$(srcdir)/'`intrinsics/fnum.c
+
 getcwd.lo: intrinsics/getcwd.c
 	$(LIBTOOL) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o getcwd.lo `test -f 'intrinsics/getcwd.c' || echo '$(srcdir)/'`intrinsics/getcwd.c
 
@@ -1263,6 +1273,9 @@ reshape_generic.lo: intrinsics/reshape_g
 reshape_packed.lo: intrinsics/reshape_packed.c
 	$(LIBTOOL) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o reshape_packed.lo `test -f 'intrinsics/reshape_packed.c' || echo '$(srcdir)/'`intrinsics/reshape_packed.c
 
+stat.lo: intrinsics/stat.c
+	$(LIBTOOL) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o stat.lo `test -f 'intrinsics/stat.c' || echo '$(srcdir)/'`intrinsics/stat.c
+
 system_clock.lo: intrinsics/system_clock.c
 	$(LIBTOOL) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o system_clock.lo `test -f 'intrinsics/system_clock.c' || echo '$(srcdir)/'`intrinsics/system_clock.c
 
Index: libgfortran/config.h.in
===================================================================
RCS file: /var/cvsroot/gcc-cvs/gcc/libgfortran/config.h.in,v
retrieving revision 1.13
diff -u -p -r1.13 config.h.in
--- libgfortran/config.h.in	23 Nov 2004 02:02:29 -0000	1.13
+++ libgfortran/config.h.in	2 Dec 2004 03:52:31 -0000
@@ -165,6 +165,15 @@
 /* Define to 1 if you have the `strtof' function. */
 #undef HAVE_STRTOF
 
+/* Define to 1 if `st_blksize' is member of `struct stat'. */
+#undef HAVE_STRUCT_STAT_ST_BLKSIZE
+
+/* Define to 1 if `st_blocks' is member of `struct stat'. */
+#undef HAVE_STRUCT_STAT_ST_BLOCKS
+
+/* Define to 1 if `st_rdev' is member of `struct stat'. */
+#undef HAVE_STRUCT_STAT_ST_RDEV
+
 /* Define to 1 if you have the <sys/mman.h> header file. */
 #undef HAVE_SYS_MMAN_H
 
Index: libgfortran/configure.ac
===================================================================
RCS file: /var/cvsroot/gcc-cvs/gcc/libgfortran/configure.ac,v
retrieving revision 1.16
diff -u -p -r1.16 configure.ac
--- libgfortran/configure.ac	23 Nov 2004 02:02:37 -0000	1.16
+++ libgfortran/configure.ac	2 Dec 2004 02:37:58 -0000
@@ -152,9 +152,13 @@ AC_TYPE_OFF_T
 AC_STDC_HEADERS
 AC_HAVE_HEADERS(stdlib.h stdio.h string.h stddef.h math.h unistd.h)
 AC_CHECK_HEADERS(time.h sys/params.h sys/time.h sys/times.h sys/resource.h)
-AC_CHECK_HEADERS(sys/mman.h)
+AC_CHECK_HEADERS(sys/mman.h sys/types.h sys/stat.h)
 AC_CHECK_HEADER([complex.h],[AC_DEFINE([HAVE_COMPLEX_H], [1], [complex.h exists])])
 
+AC_CHECK_MEMBERS([struct stat.st_blksize])
+AC_CHECK_MEMBERS([struct stat.st_blocks])
+AC_CHECK_MEMBERS([struct stat.st_rdev])
+
 # Check for complex math functions
 AC_CHECK_LIB([m],[csin],[need_math="no"],[need_math="yes"])
 
Index: libgfortran/intrinsics/flush.c
===================================================================
RCS file: libgfortran/intrinsics/flush.c
diff -N libgfortran/intrinsics/flush.c
--- /dev/null	1 Jan 1970 00:00:00 -0000
+++ libgfortran/intrinsics/flush.c	2 Dec 2004 01:46:35 -0000
@@ -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);
+    }
+}
Index: libgfortran/intrinsics/fnum.c
===================================================================
RCS file: libgfortran/intrinsics/fnum.c
diff -N libgfortran/intrinsics/fnum.c
--- /dev/null	1 Jan 1970 00:00:00 -0000
+++ libgfortran/intrinsics/fnum.c	2 Dec 2004 01:52:09 -0000
@@ -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);
+}
Index: libgfortran/intrinsics/stat.c
===================================================================
RCS file: libgfortran/intrinsics/stat.c
diff -N libgfortran/intrinsics/stat.c
--- /dev/null	1 Jan 1970 00:00:00 -0000
+++ libgfortran/intrinsics/stat.c	2 Dec 2004 01:51:20 -0000
@@ -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;
+}
Index: libgfortran/io/io.h
===================================================================
RCS file: /var/cvsroot/gcc-cvs/gcc/libgfortran/io/io.h,v
retrieving revision 1.10
diff -u -p -r1.10 io.h
--- libgfortran/io/io.h	31 Aug 2004 14:06:48 -0000	1.10
+++ libgfortran/io/io.h	2 Dec 2004 02:37:58 -0000
@@ -465,6 +465,8 @@ void empty_internal_buffer(stream *);
 #define flush prefix(flush)
 try flush (stream *);
 
+#define unit_to_fd prefix(unit_to_fd)
+int unit_to_fd (int);
 
 /* unit.c */
 
Index: libgfortran/io/unix.c
===================================================================
RCS file: /var/cvsroot/gcc-cvs/gcc/libgfortran/io/unix.c,v
retrieving revision 1.14
diff -u -p -r1.14 unix.c
--- libgfortran/io/unix.c	28 Nov 2004 21:13:57 -0000	1.14
+++ libgfortran/io/unix.c	2 Dec 2004 02:37:58 -0000
@@ -286,7 +286,6 @@ sys_exit (int code)
 }
 
 
-
 /*********************************************************************
     File descriptor stream functions
 *********************************************************************/
@@ -918,6 +917,22 @@ fd_to_stream (int fd, int prot)
 }
 
 
+/* Given the Fortran unit number, convert it to a C file descriptor.  */
+
+int
+unit_to_fd(int unit)
+{
+
+  gfc_unit *us;
+
+  us = find_unit(unit);
+  if (us == NULL)
+    return -1;
+
+  return ((unix_stream *) us->s)->fd;
+}
+
+
 /* unpack_filename()-- Given a fortran string and a pointer to a
  * buffer that is PATH_MAX characters, convert the fortran string to a
  * C string in the buffer.  Returns nonzero if this is not possible.  */

Index Nav: [Date Index] [Subject Index] [Author Index] [Thread Index]
Message Nav: [Date Prev] [Date Next] [Thread Prev] [Thread Next]