re PR fortran/34665 (Cannot pass scalar to array argument 'a')

2008-01-13  Tobias Burnus  <burnus@net-b.de>

        PR fortran/34665
        * resolve.c (resolve_actual_arglist): For expressions,
        also check for assume-sized arrays.
        * interface.c (compare_parameter): Move F2003 character checks
        here, print error messages here, reject elements of
        assumed-shape array as argument to dummy arrays.
        (compare_actual_formal): Update for the changes above.

2008-01-13  Tobias Burnus  <burnus@net-b.de>

        PR fortran/34665
        * gfortran.dg/argument_checking_11.f90: New.
        * gfortran.dg/argument_checking_12.f90: New.
        * gfortran.dg/used_dummy_types_4.f90: Update dg-error.
        * gfortran.dg/c_assoc_2.f03: Update dg-error.
        * gfortran.dg/argument_checking_3.f90: Ditto.
        * gfortran.dg/pointer_intent_2.f90: Ditto.
        * gfortran.dg/import2.f90: Ditto.
        * gfortran.dg/assumed_shape_ranks_1.f90: Ditto.
        * gfortran.dg/implicit_actual.f90: Ditto.
        * gfortran.dg/used_dummy_types_3.f90: Ditto.
        * gfortran.dg/derived_comp_array_ref_6.f90: Ditto.

From-SVN: r131513

gcc/fortran/ChangeLog

 2008-01-13  Tobias Burnus  <burnus@net-b.de>
 
+	PR fortran/34665
+	* resolve.c (resolve_actual_arglist): For expressions,
+	also check for assume-sized arrays.
+	* interface.c (compare_parameter): Move F2003 character checks
+	here, print error messages here, reject elements of
+	assumed-shape array as argument to dummy arrays.
+	(compare_actual_formal): Update for the changes above.
+
+2008-01-13  Tobias Burnus  <burnus@net-b.de>
+
 	PR fortran/34763
 	* decl.c (contained_procedure): Only check directly preceeding state.
 

gcc/fortran/interface.c

@@ -1420,9 +1420,10 @@ compare_pointer (gfc_symbol *formal, gfc_expr *actual)
 
 static int
 compare_parameter (gfc_symbol *formal, gfc_expr *actual,
-		   int ranks_must_agree, int is_elemental)
+		   int ranks_must_agree, int is_elemental, locus *where)
 {
   gfc_ref *ref;
+  bool rank_check;
 
   /* If the formal arg has type BT_VOID, it's to one of the iso_c_binding
      procs c_f_pointer or c_f_procpointer, and we need to accept most
@@ -1439,51 +1440,119 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual,
   if (actual->ts.type == BT_PROCEDURE)
     {
       if (formal->attr.flavor != FL_PROCEDURE)
-	return 0;
+	goto proc_fail;
 
       if (formal->attr.function
 	  && !compare_type_rank (formal, actual->symtree->n.sym))
-	return 0;
+	goto proc_fail;
 
       if (formal->attr.if_source == IFSRC_UNKNOWN
 	  || actual->symtree->n.sym->attr.external)
 	return 1;		/* Assume match.  */
 
       if (actual->symtree->n.sym->attr.intrinsic)
-	return compare_intr_interfaces (formal, actual->symtree->n.sym);
-      else
-	return compare_interfaces (formal, actual->symtree->n.sym, 0);
+	{
+	 if (!compare_intr_interfaces (formal, actual->symtree->n.sym))
+	   goto proc_fail;
+	}
+      else if (!compare_interfaces (formal, actual->symtree->n.sym, 0))
+	goto proc_fail;
+
+      return 1;
+
+      proc_fail:
+	if (where)
+	  gfc_error ("Type/rank mismatch in argument '%s' at %L",
+		     formal->name, &actual->where);
+      return 0;
     }
 
   if ((actual->expr_type != EXPR_NULL || actual->ts.type != BT_UNKNOWN)
       && !gfc_compare_types (&formal->ts, &actual->ts))
+    {
+      if (where && actual->ts.type == BT_DERIVED
+	  && formal->ts.type == BT_DERIVED)
+	gfc_error ("Type mismatch in argument '%s' at %L; passed type(%s) to "
+		   "type(%s)", formal->name, &actual->where,
+		   actual->ts.derived->name, formal->ts.derived->name);
+      else if (where)
+	gfc_error ("Type mismatch in argument '%s' at %L; passed %s to %s",
+		   formal->name, &actual->where,
+		   actual->ts.type == BT_DERIVED ? "derived type"
+				     : gfc_basic_typename (actual->ts.type),
+		   formal->ts.type == BT_DERIVED ? "derived type"
+				     : gfc_basic_typename (formal->ts.type));
       return 0;
+    }
 
   if (symbol_rank (formal) == actual->rank)
     return 1;
 
-  /* At this point the ranks didn't agree.  */
-  if (ranks_must_agree || formal->attr.pointer)
-    return 0;
-
-  if (actual->rank != 0)
-    return is_elemental || formal->attr.dimension;
+  rank_check = where != NULL && !is_elemental && formal->as
+	       && (formal->as->type == AS_ASSUMED_SHAPE
+		   || formal->as->type == AS_DEFERRED);
 
-  /* At this point, we are considering a scalar passed to an array.
-     This is legal if the scalar is an array element of the right sort.  */
-  if (formal->as->type == AS_ASSUMED_SHAPE)
+  if (rank_check || ranks_must_agree || formal->attr.pointer
+      || (actual->rank != 0 && !(is_elemental || formal->attr.dimension))
+      || (actual->rank == 0 && formal->as->type == AS_ASSUMED_SHAPE))
+    {
+      if (where)
+	gfc_error ("Rank mismatch in argument '%s' at %L (%d and %d)",
+		   formal->name, &actual->where, symbol_rank (formal),
+		   actual->rank);
       return 0;
+    }
+  else if (actual->rank != 0 && (is_elemental || formal->attr.dimension))
+    return 1;
 
-  for (ref = actual->ref; ref; ref = ref->next)
-    if (ref->type == REF_SUBSTRING)
-      return 0;
+  /* At this point, we are considering a scalar passed to an array.   This
+     is valid (cf. F95 12.4.1.1; F2003 12.4.1.2),
+     - if the actual argument is (a substring of) an element of a
+       non-assumed-shape/non-pointer array;
+     - (F2003) if the actual argument is of type character.  */
 
   for (ref = actual->ref; ref; ref = ref->next)
     if (ref->type == REF_ARRAY && ref->u.ar.type == AR_ELEMENT)
       break;
 
-  if (ref == NULL)
-    return 0;			/* Not an array element.  */
+  /* Not an array element.  */
+  if (formal->ts.type == BT_CHARACTER
+      && (ref == NULL
+          || (actual->expr_type == EXPR_VARIABLE
+	      && (actual->symtree->n.sym->as->type == AS_ASSUMED_SHAPE
+		  || actual->symtree->n.sym->as->type == AS_DEFERRED))))
+    {
+      if (where && (gfc_option.allow_std & GFC_STD_F2003) == 0)
+	{
+	  gfc_error ("Fortran 2003: Scalar CHARACTER actual argument with "
+		     "array dummy argument '%s' at %L",
+		     formal->name, &actual->where);
+	  return 0;
+	}
+      else if ((gfc_option.allow_std & GFC_STD_F2003) == 0)
+	return 0;
+      else
+	return 1;
+    }
+  else if (ref == NULL)
+    {
+      if (where)
+	gfc_error ("Rank mismatch in argument '%s' at %L (%d and %d)",
+		   formal->name, &actual->where, symbol_rank (formal),
+		   actual->rank);
+      return 0;
+    }
+
+  if (actual->expr_type == EXPR_VARIABLE
+      && actual->symtree->n.sym->as
+      && (actual->symtree->n.sym->as->type == AS_ASSUMED_SHAPE
+	  || actual->symtree->n.sym->as->type == AS_DEFERRED))
+    {
+      if (where)
+	gfc_error ("Element of assumed-shaped array passed to dummy "
+		   "argument '%s' at %L", formal->name, &actual->where);
+      return 0;
+    }
 
   return 1;
 }
@@ -1708,7 +1777,6 @@ compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal,
   gfc_actual_arglist **new, *a, *actual, temp;
   gfc_formal_arglist *f;
   int i, n, na;
-  bool rank_check;
   unsigned long actual_size, formal_size;
 
   actual = *ap;
@@ -1789,33 +1857,9 @@ compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal,
 	  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 (f->sym->ts.type == BT_CHARACTER && a->expr->ts.type == BT_CHARACTER
-	  && a->expr->rank == 0 && !ranks_must_agree
-	  && f->sym->as && f->sym->as->type != AS_ASSUMED_SHAPE)
-	{
-	  if (where && (gfc_option.allow_std & GFC_STD_F2003) == 0)
-	    {
-	      gfc_error ("Fortran 2003: Scalar CHARACTER actual argument "
-			 "with array dummy argument '%s' at %L",
-			 f->sym->name, &a->expr->where);
-	      return 0;
-	    }
-	  else if ((gfc_option.allow_std & GFC_STD_F2003) == 0)
-	    return 0;
-
-	}
-      else if (!compare_parameter (f->sym, a->expr,
-				   ranks_must_agree || rank_check, is_elemental))
-	{
-	  if (where)
-	    gfc_error ("Type/rank mismatch in argument '%s' at %L",
-		       f->sym->name, &a->expr->where);
+      if (!compare_parameter (f->sym, a->expr, ranks_must_agree,
+			      is_elemental, where))
 	return 0;
-	}
 
       if (a->expr->ts.type == BT_CHARACTER
 	   && a->expr->ts.cl && a->expr->ts.cl->length

gcc/fortran/resolve.c

@@ -1013,6 +1013,7 @@ resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype)
   gfc_symbol *sym;
   gfc_symtree *parent_st;
   gfc_expr *e;
+  int save_need_full_assumed_size;
 
   for (; arg; arg = arg->next)
     {
@@ -1041,8 +1042,12 @@ resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype)
 
       if (e->ts.type != BT_PROCEDURE)
 	{
+	  save_need_full_assumed_size = need_full_assumed_size;
+	  if (e->expr_type != FL_VARIABLE)
+	    need_full_assumed_size = 0;
 	  if (gfc_resolve_expr (e) != SUCCESS)
 	    return FAILURE;
+	  need_full_assumed_size = save_need_full_assumed_size;
 	  goto argument_list;
 	}
 
@@ -1181,8 +1186,12 @@ resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype)
 	 primary.c (match_actual_arg). If above code determines that it
 	 is a  variable instead, it needs to be resolved as it was not
 	 done at the beginning of this function.  */
+      save_need_full_assumed_size = need_full_assumed_size;
+      if (e->expr_type != FL_VARIABLE)
+	need_full_assumed_size = 0;
       if (gfc_resolve_expr (e) != SUCCESS)
 	return FAILURE;
+      need_full_assumed_size = save_need_full_assumed_size;
 
     argument_list:
       /* Check argument list functions %VAL, %LOC and %REF.  There is

gcc/testsuite/ChangeLog

 2008-01-13  Tobias Burnus  <burnus@net-b.de>
 
+	PR fortran/34665
+	* gfortran.dg/argument_checking_11.f90: New.
+	* gfortran.dg/argument_checking_12.f90: New.
+	* gfortran.dg/used_dummy_types_4.f90: Update dg-error.
+	* gfortran.dg/c_assoc_2.f03: Update dg-error.
+	* gfortran.dg/argument_checking_3.f90: Ditto.
+	* gfortran.dg/pointer_intent_2.f90: Ditto.
+	* gfortran.dg/import2.f90: Ditto.
+	* gfortran.dg/assumed_shape_ranks_1.f90: Ditto.
+	* gfortran.dg/implicit_actual.f90: Ditto.
+	* gfortran.dg/used_dummy_types_3.f90: Ditto.
+	* gfortran.dg/derived_comp_array_ref_6.f90: Ditto.
+
+2008-01-13  Tobias Burnus  <burnus@net-b.de>
+
 	PR fortran/34763
 	* gfortran.dg/interface_proc_end.f90: New.
 

gcc/testsuite/gfortran.dg/argument_checking_12.f90

+! { dg-do compile }
+! { dg-options "-std=f2003" }
+!
+! PR fortran/34665
+!
+! Test argument checking
+!
+implicit none
+CONTAINS
+SUBROUTINE test2(a,b,c,d,e)
+ character(len=*), dimension(:) :: a
+ character(len=*), pointer, dimension(:) :: b
+ character(len=*), dimension(*) :: c
+ character(len=*), dimension(5) :: d
+ character(len=*)               :: e
+
+ call cas_size(e) 
+ call cas_size("abc") 
+ call cas_size(e//"a") 
+ call cas_size(("abc")) 
+ call cas_size(a(1)) 
+ call cas_size(b(1)) 
+ call cas_size((a(1)//"a")) 
+ call cas_size((b(1)//"a")) 
+ call cas_size((c(1)//"a")) 
+ call cas_size((d(1)//"a")) 
+ call cas_size(e(1:3)) 
+ call cas_size("abcd"(1:3)) 
+ call cas_size((e(1:3))) 
+ call cas_size(("abcd"(1:3)//"a")) 
+ call cas_size(e(1:3)) 
+ call cas_size("abcd"(1:3)) 
+ call cas_size((e(1:3))) 
+ call cas_size(("abcd"(1:3)//"a")) 
+ call cas_expl(e) 
+ call cas_expl("abc") 
+ call cas_expl(e//"a") 
+ call cas_expl(("abc")) 
+ call cas_expl(a(1)) 
+ call cas_expl(b(1)) 
+ call cas_expl((a(1)//"a")) 
+ call cas_expl((b(1)//"a")) 
+ call cas_expl((c(1)//"a")) 
+ call cas_expl((d(1)//"a")) 
+ call cas_expl(e(1:3)) 
+ call cas_expl("abcd"(1:3)) 
+ call cas_expl((e(1:3))) 
+ call cas_expl(("abcd"(1:3)//"a")) 
+END SUBROUTINE test2
+
+SUBROUTINE cas_size(a)
+ character(len=*), dimension(*) :: a
+END SUBROUTINE cas_size
+
+SUBROUTINE cas_expl(a)
+ character(len=*), dimension(5) :: a
+END SUBROUTINE cas_expl
+END
+

gcc/testsuite/gfortran.dg/argument_checking_3.f90

@@ -22,9 +22,9 @@ end interface
   len2 = '12'
   len4 = '1234'
 
-  call foo(len2) ! { dg-warning "Type/rank mismatch in argument" }
-  call foo("ca") ! { dg-warning "Type/rank mismatch in argument" }
-  call bar("ca") ! { dg-warning "Type/rank mismatch in argument" }
+  call foo(len2) ! { dg-warning "Rank mismatch in argument" }
+  call foo("ca") ! { dg-warning "Rank mismatch in argument" }
+  call bar("ca") ! { dg-warning "Rank mismatch in argument" }
   call foobar(len2) ! { dg-warning "contains too few elements" }
   call foobar(len4)
   call foobar("bar") ! { dg-warning "contains too few elements" }

gcc/testsuite/gfortran.dg/assumed_shape_ranks_1.f90

@@ -14,8 +14,8 @@ end module addon
   use addon
   INTEGER :: I(2,2)
   I=RESHAPE((/1,2,3,4/),(/2,2/))
-  CALL TST(I)   ! { dg-error "Type/rank mismatch in argument" }
-  i = foo (i)   ! { dg-error "Type/rank mismatch|Incompatible ranks" }
+  CALL TST(I)   ! { dg-error "Rank mismatch in argument" }
+  i = foo (i)   ! { dg-error "Rank mismatch|Incompatible ranks" }
 CONTAINS
   SUBROUTINE TST(I)
     INTEGER :: I(:)

gcc/testsuite/gfortran.dg/c_assoc_2.f03

@@ -28,7 +28,7 @@ contains
        call abort()
     end if
 
-    if(.not. c_associated(my_integer)) then ! { dg-error "Type/rank mismatch" }
+    if(.not. c_associated(my_integer)) then ! { dg-error "Type mismatch" }
        call abort()
     end if
   end subroutine sub0

gcc/testsuite/gfortran.dg/derived_comp_array_ref_6.f90

@@ -20,7 +20,7 @@
         USE cdf_aux_mod
         INTEGER :: which
           which = 1
-          CALL set_bound(the_beta%parameters(1:which)) ! { dg-error "Type/rank mismatch" }
+          CALL set_bound(the_beta%parameters(1:which)) ! { dg-error "Rank mismatch" }
       END SUBROUTINE cdf_beta
     END MODULE cdf_beta_mod
 

gcc/testsuite/gfortran.dg/implicit_actual.f90

@@ -16,7 +16,7 @@ program snafu
 !  use global
   implicit type (t3) (z)
 
-  call foo (zin) ! { dg-error "defined|Type/rank" }
+  call foo (zin) ! { dg-error "defined|Type mismatch" }
 
 contains
 

gcc/testsuite/gfortran.dg/import2.f90

@@ -71,10 +71,10 @@ program foo
   integer(dp) :: i8
   y%i = 2
   i8 = 8
-  call bar(y,i8) ! { dg-error "Type/rank mismatch in argument" }
+  call bar(y,i8) ! { dg-error "Type mismatch in argument" }
   if(y%i /= 5 .or. i8/= 42) call abort()
   z%i = 7
-  call test(z) ! { dg-error "Type/rank mismatch in argument" }
+  call test(z) ! { dg-error "Type mismatch in argument" }
   if(z%i /= 1) call abort()
 end program foo
 ! { dg-final { cleanup-modules "testmod" } }

gcc/testsuite/gfortran.dg/pointer_intent_2.f90

@@ -11,7 +11,7 @@ program test
  integer, pointer :: p
  allocate(p)
  p = 33
- call a(p) ! { dg-error "Type/rank mismatch in argument" }
+ call a(p) ! { dg-error "Type mismatch in argument" }
 contains
   subroutine a(p)! { dg-error "has no IMPLICIT type" }
     integer, pointer,intent(in) :: p ! { dg-error "POINTER attribute with INTENT attribute" }

gcc/testsuite/gfortran.dg/used_dummy_types_3.f90

@@ -31,7 +31,7 @@
     USE T1
     USE T2 , ONLY : TEST
     TYPE(data_type) :: x
-    CALL TEST(x)         ! { dg-error "Type/rank mismatch in argument" }
+    CALL TEST(x)         ! { dg-error "Type mismatch in argument" }
   END
 
 ! { dg-final { cleanup-modules "T1 T2" } }

gcc/testsuite/gfortran.dg/used_dummy_types_4.f90

@@ -47,7 +47,7 @@ end module global
 ! These are different.
   st1 = dt                ! { dg-error "convert REAL" }
 
-  call foo (st1)          ! { dg-error "Type/rank mismatch in argument" }
+  call foo (st1)          ! { dg-error "Type mismatch in argument" }
 
 contains