intrinsic.c (compare_actual_formal)

[Daniel Franke <franke dot daniel at gmail dot com>]

Hi all.

I'm looking at intrinsic.c (compare_actual_formal). It appears that most, if 
not all, error messages are protected with 

	if (where)
	  gfc_error(...)

whether 'where' is actually used in the message or not.

A particular example is given in PR34805. There, the error shown is somewhat 
cryptic, although a proper message is available in compare_actual_formal. 
Removing 'if (where)', 'where' is set to NULL in gfc_arglist_matches_symbol(), 
gives the proper message.

If all 'if (where)' checks are removed where 'where' is not used, a bunch of 
regressions shows up, all but one are related to the same specific messages. 
The last testcase contains a TODO "wrong error message here" -- the correct 
error is given without the 'if (where)'.

Is this some sort of "it's everywhere, put it here as well" pasto -- it's even 
at the coarray-related checks recently introduced -- or is there a deeper 
reason to this?

Thanks.

	Daniel

Index: fortran/interface.c
===================================================================
--- fortran/interface.c	(revision 158958)
+++ fortran/interface.c	(working copy)
@@ -1898,7 +1898,6 @@ compare_actual_formal (gfc_actual_arglis
 
 	  if (new_arg[i] != NULL)
 	    {
-	      if (where)
 		gfc_error ("Keyword argument '%s' at %L is already associated "
 			   "with another actual argument", a->name,
 			   &a->expr->where);
@@ -1951,14 +1950,14 @@ compare_actual_formal (gfc_actual_arglis
 	   && (mpz_cmp (a->expr->ts.u.cl->length->value.integer,
 			f->sym->ts.u.cl->length->value.integer) != 0))
 	 {
-	   if (where && (f->sym->attr.pointer || f->sym->attr.allocatable))
+	   if (f->sym->attr.pointer || f->sym->attr.allocatable)
 	     gfc_warning ("Character length mismatch (%ld/%ld) between actual "
 			  "argument and pointer or allocatable dummy argument "
 			  "'%s' at %L",
 			  mpz_get_si (a->expr->ts.u.cl->length->value.integer),
 			  mpz_get_si (f->sym->ts.u.cl->length->value.integer),
 			  f->sym->name, &a->expr->where);
-	   else if (where)
+	   else
 	     gfc_warning ("Character length mismatch (%ld/%ld) between actual "
 			  "argument and assumed-shape dummy argument '%s' "
 			  "at %L",
@@ -1974,12 +1973,12 @@ compare_actual_formal (gfc_actual_arglis
 	    && actual_size < formal_size
 	    && a->expr->ts.type != BT_PROCEDURE)
 	{
-	  if (a->expr->ts.type == BT_CHARACTER && !f->sym->as && where)
+	  if (a->expr->ts.type == BT_CHARACTER && !f->sym->as)
 	    gfc_warning ("Character length of actual argument shorter "
 			"than of dummy argument '%s' (%lu/%lu) at %L",
 			f->sym->name, actual_size, formal_size,
 			&a->expr->where);
-          else if (where)
+          else
 	    gfc_warning ("Actual argument contains too few "
 			"elements for dummy argument '%s' (%lu/%lu) at %L",
 			f->sym->name, actual_size, formal_size,
@@ -1996,7 +1995,6 @@ compare_actual_formal (gfc_actual_arglis
 		   && a->expr->symtree->n.sym->result->attr.proc_pointer)
 	       || gfc_is_proc_ptr_comp (a->expr, NULL)))
 	{
-	  if (where)
 	    gfc_error ("Expected a procedure pointer for argument '%s' at %L",
 		       f->sym->name, &a->expr->where);
 	  return 0;
@@ -2008,7 +2006,6 @@ compare_actual_formal (gfc_actual_arglis
 	  && a->expr->expr_type == EXPR_VARIABLE
 	  && f->sym->attr.flavor == FL_PROCEDURE)
 	{
-	  if (where)
 	    gfc_error ("Expected a procedure for argument '%s' at %L",
 		       f->sym->name, &a->expr->where);
 	  return 0;
@@ -2018,7 +2015,6 @@ compare_actual_formal (gfc_actual_arglis
 	  && a->expr->ts.type == BT_PROCEDURE
 	  && !a->expr->symtree->n.sym->attr.pure)
 	{
-	  if (where)
 	    gfc_error ("Expected a PURE procedure for argument '%s' at %L",
 		       f->sym->name, &a->expr->where);
 	  return 0;
@@ -2041,7 +2037,6 @@ compare_actual_formal (gfc_actual_arglis
       if (a->expr->expr_type != EXPR_NULL
 	  && compare_pointer (f->sym, a->expr) == 0)
 	{
-	  if (where)
 	    gfc_error ("Actual argument for '%s' must be a pointer at %L",
 		       f->sym->name, &a->expr->where);
 	  return 0;
@@ -2050,7 +2045,6 @@ compare_actual_formal (gfc_actual_arglis
       /* Fortran 2008, C1242.  */
       if (f->sym->attr.pointer && gfc_is_coindexed (a->expr))
 	{
-	  if (where)
 	    gfc_error ("Coindexed actual argument at %L to pointer "
 		       "dummy '%s'",
 		       &a->expr->where, f->sym->name);
@@ -2063,7 +2057,6 @@ compare_actual_formal (gfc_actual_arglis
 	  && f->sym->attr.allocatable
 	  && gfc_is_coindexed (a->expr))
 	{
-	  if (where)
 	    gfc_error ("Coindexed actual argument at %L to allocatable "
 		       "dummy '%s' requires INTENT(IN)",
 		       &a->expr->where, f->sym->name);
@@ -2077,7 +2070,6 @@ compare_actual_formal (gfc_actual_arglis
 	  && (a->expr->symtree->n.sym->attr.volatile_
 	      || a->expr->symtree->n.sym->attr.asynchronous))
 	{
-	  if (where)
 	    gfc_error ("Coindexed ASYNCHRONOUS or VOLATILE actual argument at "
 		       "at %L requires that dummy %s' has neither "
 		       "ASYNCHRONOUS nor VOLATILE", &a->expr->where,
@@ -2091,7 +2083,6 @@ compare_actual_formal (gfc_actual_arglis
 	  && gfc_is_coindexed (a->expr)
 	  && gfc_has_ultimate_allocatable (a->expr))
 	{
-	  if (where)
 	    gfc_error ("Coindexed actual argument at %L with allocatable "
 		       "ultimate component to dummy '%s' requires either VALUE "
 		       "or INTENT(IN)", &a->expr->where, f->sym->name);
@@ -2101,7 +2092,6 @@ compare_actual_formal (gfc_actual_arglis
       if (a->expr->expr_type != EXPR_NULL
 	  && compare_allocatable (f->sym, a->expr) == 0)
 	{
-	  if (where)
 	    gfc_error ("Actual argument for '%s' must be ALLOCATABLE at %L",
 		       f->sym->name, &a->expr->where);
 	  return 0;
@@ -2123,7 +2113,6 @@ compare_actual_formal (gfc_actual_arglis
 
       if (!compare_parameter_protected(f->sym, a->expr))
 	{
-	  if (where)
 	    gfc_error ("Actual argument at %L is use-associated with "
 		       "PROTECTED attribute and dummy argument '%s' is "
 		       "INTENT = OUT/INOUT",
@@ -2136,7 +2125,6 @@ compare_actual_formal (gfc_actual_arglis
 	   || f->sym->attr.volatile_)
           && has_vector_subscript (a->expr))
 	{
-	  if (where)
 	    gfc_error ("Array-section actual argument with vector subscripts "
 		       "at %L is incompatible with INTENT(OUT), INTENT(INOUT) "
 		       "or VOLATILE attribute of the dummy argument '%s'",
@@ -2153,7 +2141,6 @@ compare_actual_formal (gfc_actual_arglis
 	  && a->expr->symtree->n.sym->as->type == AS_ASSUMED_SHAPE
 	  && !(f->sym->as && f->sym->as->type == AS_ASSUMED_SHAPE))
 	{
-	  if (where)
 	    gfc_error ("Assumed-shape actual argument at %L is "
 		       "incompatible with the non-assumed-shape "
 		       "dummy argument '%s' due to VOLATILE attribute",
@@ -2165,7 +2152,6 @@ compare_actual_formal (gfc_actual_arglis
 	  && a->expr->ref && a->expr->ref->u.ar.type == AR_SECTION
 	  && !(f->sym->as && f->sym->as->type == AS_ASSUMED_SHAPE))
 	{
-	  if (where)
 	    gfc_error ("Array-section actual argument at %L is "
 		       "incompatible with the non-assumed-shape "
 		       "dummy argument '%s' due to VOLATILE attribute",
@@ -2184,7 +2170,6 @@ compare_actual_formal (gfc_actual_arglis
 	       && (f->sym->as->type == AS_ASSUMED_SHAPE
 		   || f->sym->attr.pointer)))
 	{
-	  if (where)
 	    gfc_error ("Pointer-array actual argument at %L requires "
 		       "an assumed-shape or pointer-array dummy "
 		       "argument '%s' due to VOLATILE attribute",
Index: testsuite/gfortran.dg/assignment_2.f90
===================================================================
--- testsuite/gfortran.dg/assignment_2.f90	(revision 158958)
+++ testsuite/gfortran.dg/assignment_2.f90	(working copy)
@@ -30,9 +30,7 @@ contains
   subroutine test1()
           REAL,POINTER :: p(:,:),q(:)
           CALL s(p,q) ! { dg-error "requires an assumed-shape or pointer-array dummy" }
-!TODO: The following is rightly rejected but the error message is misleading.
-! The actual reason is the mismatch between pointer array and VOLATILE
-          p = q ! { dg-error "Incompatible ranks" }
+          p = q ! { dg-error "requires an assumed-shape or pointer-array dummy"|"Incompatible ranks" }
   end subroutine test1
 end module m2