re PR fortran/29284 (ICE for optional subroutine argument)

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

	PR fortran/29284
	PR fortran/29321
	PR fortran/29322
	* trans-expr.c (gfc_conv_function_call): Check the expression
	and the formal symbol are present when testing the actual
	argument.

	PR fortran/25091
	PR fortran/25092
	* resolve.c (resolve_entries): It is an error if the entries
	of an array-valued function do not have the same shape.

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

	PR fortran/29284
	* gfortran.dg/optional_assumed_charlen_1.f90: New test.

	PR fortran/29321
	PR fortran/29322
	* gfortran.dg/missing_optional_dummy_2.f90: New test.

	PR fortran/25091
	PR fortran/25092
	* gfortran.dg/entry_array_specs_1.f90: New test.

From-SVN: r117413

7 files changed, 176 insertions, 29 deletions

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index cf840a5..6e5584a 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,17 @@
+2006-10-03  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/29284
+	PR fortran/29321
+	PR fortran/29322
+	* trans-expr.c (gfc_conv_function_call): Check the expression
+	and the formal symbol are present when testing the actual
+	argument.
+
+	PR fortran/25091
+	PR fortran/25092
+	* resolve.c (resolve_entries): It is an error if the entries
+	of an array-valued function do not have the same shape.
+
 2006-10-03  Francois-Xavier Coudert  <coudert@clipper.ens.fr>
 
 	PR middle-end/27478
diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index c9af0c0..854d3b4 100644
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -419,23 +419,33 @@ resolve_entries (gfc_namespace * ns)
     {
       gfc_symbol *sym;
       gfc_typespec *ts, *fts;
-
+      gfc_array_spec *as, *fas;
       gfc_add_function (&proc->attr, proc->name, NULL);
       proc->result = proc;
+      fas = ns->entries->sym->as;
+      fas = fas ? fas : ns->entries->sym->result->as;
       fts = &ns->entries->sym->result->ts;
       if (fts->type == BT_UNKNOWN)
 	fts = gfc_get_default_type (ns->entries->sym->result, NULL);
       for (el = ns->entries->next; el; el = el->next)
 	{
 	  ts = &el->sym->result->ts;
+	  as = el->sym->as;
+	  as = as ? as : el->sym->result->as;
 	  if (ts->type == BT_UNKNOWN)
 	    ts = gfc_get_default_type (el->sym->result, NULL);
+
 	  if (! gfc_compare_types (ts, fts)
 	      || (el->sym->result->attr.dimension
 		  != ns->entries->sym->result->attr.dimension)
 	      || (el->sym->result->attr.pointer
 		  != ns->entries->sym->result->attr.pointer))
 	    break;
+
+	  else if (as && fas && gfc_compare_array_spec (as, fas) == 0)
+	    gfc_error ("Procedure %s at %L has entries with mismatched "
+		       "array specifications", ns->entries->sym->name,
+		       &ns->entries->sym->declared_at);
 	}
 
       if (el == NULL)
diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index e477f9c..4bce65e 100644
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -2006,38 +2006,49 @@ gfc_conv_function_call (gfc_se * se, gfc_symbol * sym,
 	    } 
 	}
 
-      /* If an optional argument is itself an optional dummy argument,
-	 check its presence and substitute a null if absent.  */
-      if (e && e->expr_type == EXPR_VARIABLE
-	    && e->symtree->n.sym->attr.optional
-	    && fsym && fsym->attr.optional)
-	gfc_conv_missing_dummy (&parmse, e, fsym->ts);
-
-      if (fsym && need_interface_mapping)
-	gfc_add_interface_mapping (&mapping, fsym, &parmse);
+      if (fsym)
+	{
+	  if (e)
+	    {
+	      /* If an optional argument is itself an optional dummy
+		 argument, check its presence and substitute a null
+		 if absent.  */
+	      if (e->expr_type == EXPR_VARIABLE
+		    && e->symtree->n.sym->attr.optional
+		    && fsym->attr.optional)
+		gfc_conv_missing_dummy (&parmse, e, fsym->ts);
+
+	      /* If an INTENT(OUT) dummy of derived type has a default
+		 initializer, it must be (re)initialized here.  */
+	      if (fsym->attr.intent == INTENT_OUT
+		    && fsym->ts.type == BT_DERIVED
+		    && fsym->value)
+		{
+		  gcc_assert (!fsym->attr.allocatable);
+		  tmp = gfc_trans_assignment (e, fsym->value);
+		  gfc_add_expr_to_block (&se->pre, tmp);
+		}
 
-      gfc_add_block_to_block (&se->pre, &parmse.pre);
-      gfc_add_block_to_block (&post, &parmse.post);
+	      /* Obtain the character length of an assumed character
+		 length procedure from the typespec.  */
+	      if (fsym->ts.type == BT_CHARACTER
+		    && parmse.string_length == NULL_TREE
+		    && e->ts.type == BT_PROCEDURE
+		    && e->symtree->n.sym->ts.type == BT_CHARACTER
+		    && e->symtree->n.sym->ts.cl->length != NULL)
+		{
+		  gfc_conv_const_charlen (e->symtree->n.sym->ts.cl);
+		  parmse.string_length
+			= e->symtree->n.sym->ts.cl->backend_decl;
+		}
+	    }
 
-      /* If an INTENT(OUT) dummy of derived type has a default
-	 initializer, it must be (re)initialized here.  */
-      if (fsym && fsym->attr.intent == INTENT_OUT && fsym->ts.type == BT_DERIVED
-          && fsym->value)
-	{
-	  gcc_assert (!fsym->attr.allocatable);
-	  tmp = gfc_trans_assignment (e, fsym->value);
-	  gfc_add_expr_to_block (&se->pre, tmp);
+	  if (need_interface_mapping)
+	    gfc_add_interface_mapping (&mapping, fsym, &parmse);
 	}
 
-      if (fsym && fsym->ts.type == BT_CHARACTER
-	     && parmse.string_length == NULL_TREE
-	     && e->ts.type == BT_PROCEDURE
-	     && e->symtree->n.sym->ts.type == BT_CHARACTER
-	     && e->symtree->n.sym->ts.cl->length != NULL)
-	{
-	  gfc_conv_const_charlen (e->symtree->n.sym->ts.cl);
-	  parmse.string_length = e->symtree->n.sym->ts.cl->backend_decl;
-	}
+      gfc_add_block_to_block (&se->pre, &parmse.pre);
+      gfc_add_block_to_block (&post, &parmse.post);
 
       /* Character strings are passed as two parameters, a length and a
          pointer.  */
diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index 8615b81..5e3a75b 100644
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,16 @@
+2006-10-03  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/29284
+	* gfortran.dg/optional_assumed_charlen_1.f90: New test.
+
+	PR fortran/29321
+	PR fortran/29322
+	* gfortran.dg/missing_optional_dummy_2.f90: New test.
+
+	PR fortran/25091
+	PR fortran/25092
+	* gfortran.dg/entry_array_specs_1.f90: New test.
+
 2006-10-03  Steven G. Kargl  <kargl@gcc.gnu.org>
 
 	* gfortran.dg/nearest_1.f90: Add -O0 because -ffloat-store is
diff --git a/gcc/testsuite/gfortran.dg/entry_array_specs_1.f90 b/gcc/testsuite/gfortran.dg/entry_array_specs_1.f90
new file mode 100644
index 0000000..5e6e5f6
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/entry_array_specs_1.f90
@@ -0,0 +1,39 @@
+! { dg-do compile }
+! Tests the fix for PR25091 and PR25092 in which mismatched array
+! specifications between entries of the same procedure were not diagnosed.
+
+! Contributed by Joost VandeVondele  <jv244@cam.ac.uk> 
+
+! This was PR25091 - no diagnostic given on error
+ FUNCTION F1() RESULT(RES_F1) ! { dg-error "mismatched array specifications" }
+ INTEGER RES_F1(2,2)
+ INTEGER RES_E1(4)
+ ENTRY E1() RESULT(RES_E1)
+ END FUNCTION
+
+! This was PR25092 - no diagnostic given on error
+ FUNCTION F2() RESULT(RES_F2) ! { dg-error "mismatched array specifications" }
+ INTEGER :: RES_F2(4)
+ INTEGER :: RES_E2(3)
+ ENTRY E2() RESULT(RES_E2)
+ END FUNCTION
+
+! Check that the versions without explicit results give the error
+ FUNCTION F3() ! { dg-error "mismatched array specifications" }
+ INTEGER :: F3(4)
+ INTEGER :: E3(2,2)
+ ENTRY E3()
+ END FUNCTION
+
+ FUNCTION F4() ! { dg-error "mismatched array specifications" }
+ INTEGER :: F4(4)
+ INTEGER :: E4(3)
+ ENTRY E4()
+ END FUNCTION
+
+! Check that conforming entries are OK.
+ FUNCTION F5()
+ INTEGER :: F5(4,5,6)
+ INTEGER :: E5(4,5,6)
+ ENTRY E5()
+ END FUNCTION
diff --git a/gcc/testsuite/gfortran.dg/missing_optional_dummy_2.f90 b/gcc/testsuite/gfortran.dg/missing_optional_dummy_2.f90
new file mode 100644
index 0000000..100784d
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/missing_optional_dummy_2.f90
@@ -0,0 +1,40 @@
+! { dg-do compile }
+! Tests the fix for PR29321 and PR29322, in which ICEs occurred for the
+! lack of proper attention to checking pointers in gfc_conv_function_call.
+!
+! Contributed by Olav Vahtras  <vahtras@pdc.kth.se>
+! and Francois-Xavier Coudert  <fxcoudert@gcc.gnu.org>
+!
+MODULE myint
+   TYPE NUM
+      INTEGER :: R = 0
+   END TYPE NUM
+   CONTAINS 
+      FUNCTION FUNC(A,B) RESULT(E)
+      IMPLICIT NONE
+      TYPE(NUM)  A,B,E
+      INTENT(IN) ::  A,B
+      OPTIONAL B
+      E%R=A%R
+      CALL SUB(A,E)
+      END FUNCTION FUNC
+
+      SUBROUTINE SUB(A,E,B,C)
+      IMPLICIT NONE
+      TYPE(NUM) A,E,B,C
+      INTENT(IN)   A,B
+      INTENT(OUT)  E,C
+      OPTIONAL B,C
+      E%R=A%R
+      END SUBROUTINE SUB
+END MODULE myint
+
+  if (isscan () /= 0) call abort
+contains
+  integer function isscan (substr)
+    character(*), optional :: substr
+    if (.not.present(substr)) isscan = myscan ("foo", "over")
+  end function isscan
+end
+! { dg-final { cleanup-modules "myint" } }
+
diff --git a/gcc/testsuite/gfortran.dg/optional_assumed_charlen_1.f90 b/gcc/testsuite/gfortran.dg/optional_assumed_charlen_1.f90
new file mode 100644
index 0000000..90631aa
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/optional_assumed_charlen_1.f90
@@ -0,0 +1,20 @@
+! { dg-do compile }
+! Tests the fix for PR29284 in which an ICE would occur in converting
+! the call to a suboutine with an assumed character length, optional
+! dummy that is not present.
+!
+! Contributed by Rakuen Himawari  <rakuen_himawari@yahoo.co.jp>
+!
+      MODULE foo
+      CONTAINS
+        SUBROUTINE sub1(a)
+          CHARACTER (LEN=*), OPTIONAL :: a
+          WRITE(*,*) 'foo bar'
+        END SUBROUTINE sub1
+
+      SUBROUTINE sub2
+        CALL sub1()
+      END SUBROUTINE sub2
+
+     END MODULE foo
+! { dg-final { cleanup-modules "foo" } }