Re: [gfortran] Fix PR 19479: Simplification of the {L|U}BOUND intrinsics

[Tobias Schlüter <tobias dot schlueter at physik dot uni-muenchen dot de>]

Thanks,

Steve Kargl wrote:
> The above appears to have whitespace problems.

I have reindented the function, plus added a pair of braces around the
statement in the loop.  While looking at this, I realised that
gfc_simplify_bound is a static function, so I removed the 'gfc_' prefix.  For
reference I'll attach what I will commit once building & testing finishes.

- Tobi

Index: fortran/ChangeLog
===================================================================
RCS file: /cvs/gcc/gcc/gcc/fortran/ChangeLog,v
retrieving revision 1.339
diff -u -p -r1.339 ChangeLog
--- fortran/ChangeLog	28 Feb 2005 19:59:05 -0000	1.339
+++ fortran/ChangeLog	28 Feb 2005 22:00:02 -0000
@@ -1,3 +1,10 @@
+2005-02-28  Tobias Schl"uter  <tobias.schlueter@physik.uni-muenchen.de>
+	(port from g95)
+
+	PR fortran/19479
+	* simplify.c (gfc_simplify_bound): Rename to ...
+	(simplify_bound): ... this and overhaul.
+
 2005-02-28  Steven G. Kargl  <kargl@gcc.gnu.org>
 
 	* trans-intrinsic.c (gfc_conv_intrinsic_iargc): remove boolean argument.
Index: fortran/simplify.c
===================================================================
RCS file: /cvs/gcc/gcc/gcc/fortran/simplify.c,v
retrieving revision 1.19
diff -u -p -r1.19 simplify.c
--- fortran/simplify.c	19 Feb 2005 20:29:05 -0000	1.19
+++ fortran/simplify.c	28 Feb 2005 22:00:02 -0000
@@ -1766,16 +1766,18 @@ gfc_simplify_kind (gfc_expr * e)
 
 
 static gfc_expr *
-gfc_simplify_bound (gfc_expr * array, gfc_expr * dim, int upper)
+simplify_bound (gfc_expr * array, gfc_expr * dim, int upper)
 {
   gfc_ref *ref;
   gfc_array_spec *as;
-  int i;
+  gfc_expr *e;
+  int d;
 
   if (array->expr_type != EXPR_VARIABLE)
     return NULL;
 
   if (dim == NULL)
+    /* TODO: Simplify constant multi-dimensional bounds.  */
     return NULL;
 
   if (dim->expr_type != EXPR_CONSTANT)
@@ -1783,29 +1785,66 @@ gfc_simplify_bound (gfc_expr * array, gf
 
   /* Follow any component references.  */
   as = array->symtree->n.sym->as;
-  ref = array->ref;
-  while (ref->next != NULL)
+  for (ref = array->ref; ref; ref = ref->next)
+    {
+      switch (ref->type)
+	{
+	case REF_ARRAY:
+	  switch (ref->u.ar.type)
+	    {
+	    case AR_ELEMENT:
+	      as = NULL;
+	      continue;
+
+	    case AR_FULL:
+	      /* We're done because 'as' has already been set in the
+		 previous iteration.  */
+	      goto done;
+
+	    case AR_SECTION:
+	    case AR_UNKNOWN:
+	      return NULL;
+	    }
+
+	  gcc_unreachable ();
+
+	case REF_COMPONENT:
+	  as = ref->u.c.component->as;
+	  continue;
+
+	case REF_SUBSTRING:
+	  continue;
+	}
+    }
+
+  gcc_unreachable ();
+
+ done:
+  if (as->type == AS_DEFERRED || as->type == AS_ASSUMED_SHAPE)
+    return NULL;
+
+  d = mpz_get_si (dim->value.integer);
+
+  if (d < 1 || d > as->rank
+      || (d == as->rank && as->type == AS_ASSUMED_SIZE && upper))
     {
-      if (ref->type == REF_COMPONENT)
-	as = ref->u.c.sym->as;
-      ref = ref->next;
+      gfc_error ("DIM argument at %L is out of bounds", &dim->where);
+      return &gfc_bad_expr;
     }
 
-  if (ref->type != REF_ARRAY || ref->u.ar.type != AR_FULL)
+  e = upper ? as->upper[d-1] : as->lower[d-1];
+
+  if (e->expr_type != EXPR_CONSTANT)
     return NULL;
-  
-  i = mpz_get_si (dim->value.integer);
-  if (upper) 
-    return gfc_copy_expr (as->upper[i-1]);
-  else
-    return gfc_copy_expr (as->lower[i-1]);
+
+  return gfc_copy_expr (e);
 }
 
 
 gfc_expr *
 gfc_simplify_lbound (gfc_expr * array, gfc_expr * dim)
 {
-  return gfc_simplify_bound (array, dim, 0);
+  return simplify_bound (array, dim, 0);
 }
 
 
@@ -3578,7 +3617,7 @@ gfc_simplify_trim (gfc_expr * e)
 gfc_expr *
 gfc_simplify_ubound (gfc_expr * array, gfc_expr * dim)
 {
-  return gfc_simplify_bound (array, dim, 1);
+  return simplify_bound (array, dim, 1);
 }
 
 
Index: testsuite/ChangeLog
===================================================================
RCS file: /cvs/gcc/gcc/gcc/testsuite/ChangeLog,v
retrieving revision 1.5098
diff -u -p -r1.5098 ChangeLog
--- testsuite/ChangeLog	28 Feb 2005 19:22:28 -0000	1.5098
+++ testsuite/ChangeLog	28 Feb 2005 22:00:08 -0000
@@ -1,3 +1,8 @@
+2005-02-28  Tobias Schl"uter  <tobias.schlueter@physik.uni-muenchen.de>
+
+	PR fortran/19479
+	* gfortran.dg/bound_1.f90: New test.
+
 2005-02-28  Joseph S. Myers  <joseph@codesourcery.com>
 
 	PR c/20245
Index: testsuite/gfortran.dg/bound_1.f90
===================================================================
RCS file: testsuite/gfortran.dg/bound_1.f90
diff -N testsuite/gfortran.dg/bound_1.f90
--- /dev/null	1 Jan 1970 00:00:00 -0000
+++ testsuite/gfortran.dg/bound_1.f90	28 Feb 2005 22:00:12 -0000
@@ -0,0 +1,20 @@
+! { dg-do run }
+  implicit none
+
+  type test_type
+    integer, dimension(5) :: a
+  end type test_type
+
+  type (test_type), target :: tt(2)
+  integer i
+
+  i = ubound(tt(1)%a, 1)
+  if (i/=5) call abort()
+  i = lbound(tt(1)%a, 1)
+  if (i/=1) call abort()
+
+  i = ubound(tt, 1)
+  if (i/=2) call abort()
+  i = lbound(tt, 1)
+  if (i/=1) call abort()
+end