re PR fortran/26716 (gfortran: incorrect choice of overloaded function)

2006-03-19  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/26716
	*expr.c (external_spec_function): Permit elemental functions.

	PR fortran/26716
	*interface.c (compare_actual_formal): Detect call for procedure
	usage and require rank checking, in this case, for assumed shape
	and deferred shape arrays.
	(gfc_procedure_use): Revert to pre-PR25070 call to
	compare_actual_formal that does not require rank checking..

2006-03-19  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/26716
	* gfortran.dg/elemental_initializer_1.f90: New test.

	PR fortran/26716
	* gfortran.dg/assumed_shape_ranks_2: New test.

From-SVN: r112210

6 files changed, 108 insertions, 9 deletions

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 61bbcfd..e56a6e7 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,15 @@
+2006-03-19  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/26716
+	*expr.c (external_spec_function): Permit elemental functions.
+
+	PR fortran/26716
+	*interface.c (compare_actual_formal): Detect call for procedure
+	usage and require rank checking, in this case, for assumed shape
+	and deferred shape arrays.
+	(gfc_procedure_use): Revert to pre-PR25070 call to
+	compare_actual_formal that does not require rank checking..
+
 2006-03-16  Roger Sayle  <roger@eyesopen.com>
 
 	* gfortran.h (gfc_equiv_info): Add length field.
diff --git a/gcc/fortran/expr.c b/gcc/fortran/expr.c
index 6db1c6b..8362f53 100644
--- a/gcc/fortran/expr.c
+++ b/gcc/fortran/expr.c
@@ -1636,7 +1636,7 @@ external_spec_function (gfc_expr * e)
       return FAILURE;
     }
 
-  if (!f->attr.pure)
+  if (!f->attr.pure && !f->attr.elemental)
     {
       gfc_error ("Specification function '%s' at %L must be PURE", f->name,
 		 &e->where);
diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c
index f4e522a..060da05 100644
--- a/gcc/fortran/interface.c
+++ b/gcc/fortran/interface.c
@@ -1178,6 +1178,7 @@ compare_actual_formal (gfc_actual_arglist ** ap,
   gfc_actual_arglist **new, *a, *actual, temp;
   gfc_formal_arglist *f;
   int i, n, na;
+  bool rank_check;
 
   actual = *ap;
 
@@ -1260,11 +1261,14 @@ compare_actual_formal (gfc_actual_arglist ** ap,
 	  return 0;
 	}
 
+      rank_check = where != NULL
+		     && !is_elemental
+		     && f->sym->as
+		     && (f->sym->as->type == AS_ASSUMED_SHAPE
+			   || f->sym->as->type == AS_DEFERRED);
+
       if (!compare_parameter
-	  (f->sym, a->expr,
-	   ranks_must_agree && f->sym->as
-	     && f->sym->as->type == AS_ASSUMED_SHAPE,
-	   is_elemental))
+	  (f->sym, a->expr, ranks_must_agree || rank_check, is_elemental))
 	{
 	  if (where)
 	    gfc_error ("Type/rank mismatch in argument '%s' at %L",
@@ -1595,9 +1599,6 @@ check_intents (gfc_formal_arglist * f, gfc_actual_arglist * a)
 void
 gfc_procedure_use (gfc_symbol * sym, gfc_actual_arglist ** ap, locus * where)
 {
-  int ranks_must_agree;
-  ranks_must_agree = !sym->attr.elemental && (sym->attr.contained
-			|| sym->attr.if_source == IFSRC_IFBODY);
 
   /* Warn about calls with an implicit interface.  */
   if (gfc_option.warn_implicit_interface
@@ -1606,7 +1607,7 @@ gfc_procedure_use (gfc_symbol * sym, gfc_actual_arglist ** ap, locus * where)
                  sym->name, where);
 
   if (sym->attr.if_source == IFSRC_UNKNOWN
-      || !compare_actual_formal (ap, sym->formal, ranks_must_agree,
+      || !compare_actual_formal (ap, sym->formal, 0,
 				 sym->attr.elemental, where))
     return;
 
diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index 4dbc9a4..9fa8de7 100644
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,11 @@
+2006-03-19  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/26716
+	* gfortran.dg/elemental_initializer_1.f90: New test.
+
+	PR fortran/26716
+	* gfortran.dg/assumed_shape_ranks_2: New test.
+
 2006-03-18  Joseph S. Myers  <joseph@codesourcery.com>
 
 	* gcc.dg/980523-1.c, gcc.dg/980526-1.c, gcc.dg/switch-1.c: Use
diff --git a/gcc/testsuite/gfortran.dg/assumed_shape_ranks_2.f90 b/gcc/testsuite/gfortran.dg/assumed_shape_ranks_2.f90
new file mode 100644
index 0000000..641d3d9
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/assumed_shape_ranks_2.f90
@@ -0,0 +1,45 @@
+! { dg-do run }
+! Tests the fix for the regression PR26716.
+! Test contributed by Martin Reinecke  <martin@mpa-garching.mpg.de>
+!
+module mod1
+  implicit none
+
+  interface foo
+     module procedure foo1, foo2
+  end interface
+
+contains
+
+  subroutine foo1(bar, i)
+    real bar
+    integer i
+    i = 1
+   end subroutine
+
+  subroutine foo2(bar, i)
+    real bar(3)
+    integer i
+    i = 2
+  end subroutine
+
+end module mod1
+
+  use mod1
+  implicit none
+
+  real bar(3)
+  integer i
+
+  i = 0
+  call foo (1e0, i)
+  if (i .ne. 1) call abort ()
+
+  i = 0
+  call foo (bar(1), i)
+  if (i .ne. 1) call abort ()
+
+  i = 0
+  call foo (bar, i)
+  if (i .ne. 2) call abort ()
+end
diff --git a/gcc/testsuite/gfortran.dg/elemental_initializer_1.f90 b/gcc/testsuite/gfortran.dg/elemental_initializer_1.f90
new file mode 100644
index 0000000..7280e25
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/elemental_initializer_1.f90
@@ -0,0 +1,33 @@
+! { dg-do compile }
+! Tests the fix for elemental functions not being allowed in
+! specification expressions in pure procedures.
+!
+! Testcase from iso_varying_string by Rich Townsend <rhdt@star.ucl.ac.uk>
+! The allocatable component has been changed to a pointer for this testcase.
+!
+module iso_varying_string
+
+  type varying_string
+     private
+     character(LEN=1), dimension(:), pointer :: chars
+  end type varying_string
+
+  interface len
+     module procedure len_
+  end interface len
+
+contains
+
+  pure function char_auto (string) result (char_string)
+    type(varying_string), intent(in) :: string
+    character(LEN=len(string))       :: char_string ! Error was here
+    char_string = ""
+  end function char_auto
+
+  elemental function len_ (string) result (length)
+    type(varying_string), intent(in) :: string
+    integer                          :: length
+    length = 1
+  end function len_
+
+end module iso_varying_string