[patch, fortran] PR25029 unbounded assumed size array references

[Paul Thomas <paulthomas2 at wanadoo dot fr>]

:ADDPATCH fortran:

This patch fixes PR25029 and, as a side effect, PR21256(aka PR25060),  
PR20868 and PR20870. It is a repaired version of the patch 
http://gcc.gnu.org/ml/fortran/2005-12/msg00396.html that I had to 
remove, after Toon pointed out the problem with argument lists that 
included function references followed by the unbounded assumed size 
references; see http://gcc.gnu.org/ml/fortran/2005-12/msg00466.html.

The modification that had to be made was to use a counter to indicate 
that state of the assumed size checking, rather than a flag. This 
prevents the assumed size checking from being switched back on after 
completing the scan of the innermost argument list in nested function 
references.

The other change to resolve.c that has been made is to not check SIZE 
and UBOUND when their second arguments are not constant.

Finally, the test case was split in two, so that intrinsics are tested 
separately.

It responds in the same way as ifort and DF5.0, so I think that all is 
well. However, that is what I thought before, so I would be grateful if 
Toon and Steve would put the patch through through its paces.

Tobi, my reply to your message about the status of this patch must have 
seemed Delphic in the extreme - and wrong.  I'll sort out the changelog 
when I get to committing this.

Bubblestrapped and regtested on FC3/Athlon1700.

OK for trunk and 4.1?

Paul T

2005-12-31  Paul Thomas  <pault@gcc.gnu.org>

   PR fortran/25029
   PR fortran/21256
   PR fortran/20868
   PR fortran/20870
   * resolve.c (check_assumed_size_reference): New function to check 
for upper
   bound in assumed size array references.
   (resolve_assumed_size_actual): New function to do a very restricted scan
   of actual argument expressions of those procedures for which incomplete
   assumed size array references are not allowed.
   (resolve_function, resolve_call): Switch off assumed size checking of
   actual arguments, except for elemental procedures and intrinsic
   inquiry functions, in some circumstances.
   (resolve_variable): Call check_assumed_size_reference.

2005-12-31  Paul Thomas  <pault@gcc.gnu.org>

   PR fortran/25029
   PR fortran/21256
   * gfortran.dg/assumed_size_refs_1.f90: New test.

   PR fortran/20868
   PR fortran/20870
   * gfortran.dg/assumed_size_refs_2.f90: New test.
   * gfortran.dg/initialization_1.f90: Change warning message.

Index: gcc/fortran/resolve.c
===================================================================
*** gcc/fortran/resolve.c	(revision 109168)
--- gcc/fortran/resolve.c	(working copy)
*************** procedure_kind (gfc_symbol * sym)
*** 695,700 ****
--- 695,762 ----
    return PTYPE_UNKNOWN;
  }
  
+ /* Check references to assumed size arrays.  The flag need_full_assumed_size
+    is non-zero when matching actual arguments.  */
+ 
+ static int need_full_assumed_size = 0;
+ 
+ static int
+ check_assumed_size_reference (gfc_symbol * sym, gfc_expr * e)
+ {
+   gfc_ref * ref;
+   int dim;
+   int last = 1;
+ 
+   if (need_full_assumed_size
+ 	|| !(sym->as && sym->as->type == AS_ASSUMED_SIZE))
+       return 0;
+ 
+   for (ref = e->ref; ref; ref = ref->next)
+     if (ref->type == REF_ARRAY)
+       for (dim = 0; dim < ref->u.ar.as->rank; dim++)
+ 	last = (ref->u.ar.end[dim] == NULL) && (ref->u.ar.type == DIMEN_ELEMENT);
+ 
+   if (last)
+     {
+       gfc_error ("The upper bound in the last dimension must "
+ 		 "appear in the reference to the assumed size "
+ 		 "array '%s' at %L.", sym->name, &e->where);
+       return 1;
+     }
+   return 0;
+ }
+ 
+ 
+ /* Look for bad assumed size array references in argument expressions
+   of elemental and array valued intrinsic procedures.  Since this is
+   called from procedure resolution functions, it only recurses at
+   operators.  */
+ static bool
+ resolve_assumed_size_actual (gfc_expr *e)
+ {
+   if (e == NULL)
+    return false;
+ 
+   switch (e->expr_type)
+     {
+     case EXPR_VARIABLE:
+       if (e->symtree
+ 	    && check_assumed_size_reference (e->symtree->n.sym, e))
+ 	return true;
+       break;
+ 
+     case EXPR_OP:
+       if (resolve_assumed_size_actual (e->value.op.op1)
+ 	    || resolve_assumed_size_actual (e->value.op.op2))
+ 	return true;
+       break;
+ 
+     default:
+       break;
+     }
+   return false;
+ }
+ 
  
  /* Resolve an actual argument list.  Most of the time, this is just
     resolving the expressions in the list.
*************** resolve_function (gfc_expr * expr)
*** 1091,1100 ****
--- 1153,1170 ----
    gfc_actual_arglist *arg;
    const char *name;
    try t;
+   int temp;
+ 
+   /* Switch off assumed size checking and do this again for certain kinds
+      of procedure, once the procedure itself is resolved.  */
+   need_full_assumed_size++;
  
    if (resolve_actual_arglist (expr->value.function.actual) == FAILURE)
      return FAILURE;
  
+   /* Resume assumed_size checking. */
+   need_full_assumed_size--;
+ 
  /* See if function is already resolved.  */
  
    if (expr->value.function.name != NULL)
*************** resolve_function (gfc_expr * expr)
*** 1132,1137 ****
--- 1202,1210 ----
    if (expr->expr_type != EXPR_FUNCTION)
      return t;
  
+   temp = need_full_assumed_size;
+   need_full_assumed_size = 0;
+ 
    if (expr->value.function.actual != NULL
        && ((expr->value.function.esym != NULL
  	   && expr->value.function.esym->attr.elemental)
*************** resolve_function (gfc_expr * expr)
*** 1139,1145 ****
  	      && expr->value.function.isym->elemental)))
      {
        /* The rank of an elemental is the rank of its array argument(s).  */
- 
        for (arg = expr->value.function.actual; arg; arg = arg->next)
  	{
  	  if (arg->expr != NULL && arg->expr->rank > 0)
--- 1212,1217 ----
*************** resolve_function (gfc_expr * expr)
*** 1148,1155 ****
--- 1220,1264 ----
  	      break;
  	    }
  	}
+ 
+       /* Being elemental, the last upper bound of an assumed size array
+ 	 argument must be present.  */
+       for (arg = expr->value.function.actual; arg; arg = arg->next)
+ 	{
+ 	  if (arg->expr != NULL
+ 		&& arg->expr->rank > 0
+ 		&& resolve_assumed_size_actual (arg->expr))
+ 	    return FAILURE;
+ 	}
      }
  
+   else if (expr->value.function.actual != NULL
+       && expr->value.function.isym != NULL
+       && strcmp (expr->value.function.isym->name, "lbound"))
+     {
+       /* Array instrinsics must also have the last upper bound of an
+ 	 asumed size array argument.  UBOUND and SIZE have to be
+ 	 excluded from the check if the second argument is anything
+ 	 than a constant.  */
+       int inquiry;
+       inquiry = strcmp (expr->value.function.isym->name, "ubound") == 0
+ 		  || strcmp (expr->value.function.isym->name, "size") == 0;
+ 	    
+       for (arg = expr->value.function.actual; arg; arg = arg->next)
+ 	{
+ 	  if (inquiry && arg->next != NULL && arg->next->expr
+ 		&& arg->next->expr->expr_type != EXPR_CONSTANT)
+ 	    break;
+ 	  
+ 	  if (arg->expr != NULL
+ 		&& arg->expr->rank > 0
+ 		&& resolve_assumed_size_actual (arg->expr))
+ 	    return FAILURE;
+ 	}
+     }
+ 
+   need_full_assumed_size = temp;
+ 
    if (!pure_function (expr, &name))
      {
        if (forall_flag)
*************** resolve_call (gfc_code * c)
*** 1389,1397 ****
--- 1498,1514 ----
  {
    try t;
  
+   /* Switch off assumed size checking and do this again for certain kinds
+      of procedure, once the procedure itself is resolved.  */
+   need_full_assumed_size++;
+ 
    if (resolve_actual_arglist (c->ext.actual) == FAILURE)
      return FAILURE;
  
+   /* Resume assumed_size checking. */
+   need_full_assumed_size--;
+ 
+ 
    t = SUCCESS;
    if (c->resolved_sym == NULL)
      switch (procedure_kind (c->symtree->n.sym))
*************** resolve_call (gfc_code * c)
*** 1412,1417 ****
--- 1529,1549 ----
  	gfc_internal_error ("resolve_subroutine(): bad function type");
        }
  
+   if (c->ext.actual != NULL
+       && c->symtree->n.sym->attr.elemental)
+     {
+       gfc_actual_arglist * a;
+       /* Being elemental, the last upper bound of an assumed size array
+ 	 argument must be present.  */
+       for (a = c->ext.actual; a; a = a->next)
+ 	{
+ 	  if (a->expr != NULL
+ 		&& a->expr->rank > 0
+ 		&& resolve_assumed_size_actual (a->expr))
+ 	    return FAILURE;
+ 	}
+     }
+ 
    if (t == SUCCESS)
      find_noncopying_intrinsics (c->resolved_sym, c->ext.actual);
    return t;
*************** resolve_variable (gfc_expr * e)
*** 2338,2343 ****
--- 2470,2478 ----
        e->ts = sym->ts;
      }
  
+   if (check_assumed_size_reference (sym, e))
+     return FAILURE;
+ 
    return SUCCESS;
  }
  
Index: gcc/testsuite/gfortran.dg/initialization_1.f90
===================================================================
*** gcc/testsuite/gfortran.dg/initialization_1.f90	(revision 109168)
--- gcc/testsuite/gfortran.dg/initialization_1.f90	(working copy)
*************** contains
*** 26,32 ****
      integer :: l1 = len (ch1)     ! { dg-warning "assumed character length variable" }
  
  ! These are warnings because they are gfortran extensions.
!     integer :: m3 = size (x, 1)   ! { dg-warning "Evaluation of nonstandard initialization" }
      integer :: m4(2) = shape (z)  ! { dg-warning "Evaluation of nonstandard initialization" }
  
  ! This does not depend on non-constant properties.
--- 26,32 ----
      integer :: l1 = len (ch1)     ! { dg-warning "assumed character length variable" }
  
  ! These are warnings because they are gfortran extensions.
!     integer :: m3 = size (x, 1)   ! { dg-warning "upper bound in the last dimension" }
      integer :: m4(2) = shape (z)  ! { dg-warning "Evaluation of nonstandard initialization" }
  
  ! This does not depend on non-constant properties.

!==================assumed_size_refs_1.f90==================
! { dg-do compile }
! Test the fix for PR25029, PR21256 in which references to
! assumed size arrays without an upper bound to the last
! dimension were generating no error. The first version of
! the patch failed in DHSEQR, as pointed out by Toon Moene
! in http://gcc.gnu.org/ml/fortran/2005-12/msg00466.html
!
! Contributed by Paul Thomas  <pault@gcc.gnu.org>
!
program assumed_size_test_1
  implicit none
  real a(2, 4)

  a = 1.0
  call foo (a)

contains
  subroutine foo(m)
    real, target :: m(1:2, *)
    real x(2,2,2)
    real, external :: bar
    real, pointer :: p(:,:), q(:,:)
    allocate (q(2,2))

! PR25029
    p => m                     ! { dg-error "upper bound in the last dimension" }
    q = m                      ! { dg-error "upper bound in the last dimension" }

! PR21256( and PR25060)
    m = 1                      ! { dg-error "upper bound in the last dimension" }

    m(1,1) = 2.0
    x = bar (m)
    x = fcn (m)                ! { dg-error "upper bound in the last dimension" }
    m(:, 1:2) = fcn (q)
    call sub (m, x)            ! { dg-error "upper bound in the last dimension" }
    call sub (m(1:2, 1:2), x)
    print *, p

    call DHSEQR(x)

  end subroutine foo

  elemental function fcn (a) result (b)
    real, intent(in) :: a
    real :: b
    b = 2.0 * a
  end function fcn

  elemental subroutine sub (a, b)
    real, intent(inout) :: a, b
    b = 2.0 * a
  end subroutine sub
  
  SUBROUTINE DHSEQR( WORK )
    REAL WORK( * )
    EXTERNAL           DLARFX
    INTRINSIC          MIN
    WORK( 1 ) = 1.0
    CALL DLARFX( MIN( 1, 8 ), WORK )
  END SUBROUTINE DHSEQR

end program assumed_size_test_1

!==================assumed_size_refs_1.f90==================
! { dg-do compile }
! Test the fix for PR20868 & PR20870 in which references to
! assumed size arrays without an upper bound to the last
! dimension were generating no error.
!
! Contributed by Paul Thomas  <pault@gcc.gnu.org>
!
program assumed_size_test_2
  implicit none
  real a(2, 4)

  a = 1.0
  call foo (a)

contains
  subroutine foo(m)
    real, target :: m(1:2, *)
    real x(2,2,2)
    real, pointer :: q(:,:)
    integer :: i
    allocate (q(2,2))

    i = 2

    q = cos (1.0 + abs(m))     ! { dg-error "upper bound in the last dimension" }

    x = reshape (m, (/2,2,2/)) ! { dg-error "upper bound in the last dimension" }

! PR20868
    print *, ubound (m)        ! { dg-error "upper bound in the last dimension" }
    print *, lbound (m)

! PR20870
    print *, size (m)          ! { dg-error "upper bound in the last dimension" }

! Check non-array valued intrinsics
    print *, ubound (m, 1)
    print *, ubound (m, 2)     ! { dg-error "not a valid dimension index" }
    
    print *, size (m, i)

  end subroutine foo

end program assumed_size_test_2