re PR fortran/59143 ([OOP] Bogus warning with array-valued type-bound procedure)

2013-11-25  Janus Weil  <janus@gcc.gnu.org>

	PR fortran/59143
	* interface.c (get_expr_storage_size): Handle array-valued type-bound
	procedures.

2013-11-25  Janus Weil  <janus@gcc.gnu.org>

	PR fortran/59143
	* gfortran.dg/typebound_proc_30.f90: New.

From-SVN: r205345

gcc/fortran/ChangeLog

+2013-11-25  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/59143
+	* interface.c (get_expr_storage_size): Handle array-valued type-bound
+	procedures.
+
 2013-11-24  Francois-Xavier Coudert  <fxcoudert@gcc.gnu.org>
 
 	* scanner.c (gfc_open_intrinsic_module): Remove function.

gcc/fortran/interface.c

@@ -2426,6 +2426,24 @@ get_expr_storage_size (gfc_expr *e)
 			- mpz_get_si (ref->u.ar.as->lower[i]->value.integer));
 	    }
         }
+      else if (ref->type == REF_COMPONENT && ref->u.c.component->attr.function
+	       && ref->u.c.component->attr.proc_pointer
+	       && ref->u.c.component->attr.dimension)
+	{
+	  /* Array-valued procedure-pointer components.  */
+	  gfc_array_spec *as = ref->u.c.component->as;
+	  for (i = 0; i < as->rank; i++)
+	    {
+	      if (!as->upper[i] || !as->lower[i]
+		  || as->upper[i]->expr_type != EXPR_CONSTANT
+		  || as->lower[i]->expr_type != EXPR_CONSTANT)
+		return 0;
+
+	      elements = elements
+			 * (mpz_get_si (as->upper[i]->value.integer)
+			    - mpz_get_si (as->lower[i]->value.integer) + 1L);
+	    }
+	}
     }
 
   if (substrlen)

gcc/testsuite/ChangeLog

+2013-11-25  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/59143
+	* gfortran.dg/typebound_proc_30.f90: New.
+
 2013-11-25  Paolo Carlini  <paolo.carlini@oracle.com>
 
 	PR c++/59080

gcc/testsuite/gfortran.dg/typebound_proc_30.f90

+! { dg-do compile }
+!
+! PR 59143: [OOP] Bogus warning with array-valued type-bound procedure
+!
+! Contributed by Jürgen Reuter <juergen.reuter@desy.de>
+
+module phs_single
+
+  type :: phs_single_t
+   contains
+     procedure, nopass :: d1, d2
+  end type
+  
+contains
+
+  subroutine evaluate (phs)
+    class(phs_single_t) :: phs
+    call func1 (phs%d1 ())
+    call func1 (phs%d2 (2))
+  end subroutine
+
+  subroutine func1 (p)
+    real :: p(2)
+  end subroutine
+  
+  function d1 ()
+    real :: d1(2)
+    d1 = 1.
+  end function
+
+  function d2 (n)
+    real :: d2(n)
+    d2 = 1.
+  end function
+
+end module
+
+! { dg-final { cleanup-modules "phs_single" } }