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

15 files changed, 486 insertions, 64 deletions

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 683d66b..9c2cc465 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,5 +1,15 @@
 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.
 
diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c
index 8088fc6..9057ef9 100644
--- a/gcc/fortran/interface.c
+++ b/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))
-    return 0;
+    {
+      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;
-
-  /* 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)
-    return 0;
+  rank_check = where != NULL && !is_elemental && formal->as
+	       && (formal->as->type == AS_ASSUMED_SHAPE
+		   || formal->as->type == AS_DEFERRED);
 
-  for (ref = actual->ref; ref; ref = ref->next)
-    if (ref->type == REF_SUBSTRING)
+  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;
+
+  /* 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;
@@ -1788,34 +1856,10 @@ compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal,
 		       "call at %L", where);
 	  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);
-	  return 0;
-	}
+      
+      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
diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index 0f96cd6..0c4946e 100644
--- a/gcc/fortran/resolve.c
+++ b/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
diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index 09b233e..180d955 100644
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,5 +1,20 @@
 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.
 
diff --git a/gcc/testsuite/gfortran.dg/argument_checking_11.f90 b/gcc/testsuite/gfortran.dg/argument_checking_11.f90
new file mode 100644
index 0000000..7c70c37
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/argument_checking_11.f90
@@ -0,0 +1,285 @@
+! { dg-do compile }
+! { dg-options "-std=f95 -fmax-errors=100" }
+!
+! PR fortran/34665
+!
+! Test argument checking
+!
+! TODO: Check also expressions, e.g. "(a(1))" instead of "a(1)
+! for strings; check also "string" and [ "string" ]
+!
+implicit none
+CONTAINS
+SUBROUTINE test1(a,b,c,d,e)
+ integer, dimension(:) :: a
+ integer, pointer, dimension(:) :: b
+ integer, dimension(*) :: c
+ integer, dimension(5) :: d
+ integer               :: e
+
+ call as_size(a)
+ call as_size(b)
+ call as_size(c)
+ call as_size(d)
+ call as_size(e) ! { dg-error "Rank mismatch" }
+ call as_size(1) ! { dg-error "Rank mismatch" }
+ call as_size( (/ 1 /) )
+ call as_size( (a) )
+ call as_size( (b) )
+ call as_size( (c) ) ! { dg-error "The upper bound in the last dimension must appear in the reference to the assumed size array" }
+ call as_size( (d) )
+ call as_size( (e) ) ! { dg-error "Rank mismatch" }
+ call as_size(a(1)) ! { dg-error "Element of assumed-shaped" }
+ call as_size(b(1)) ! { dg-error "Element of assumed-shaped" }
+ call as_size(c(1))
+ call as_size(d(1))
+ call as_size( (a(1)) ) ! { dg-error "Rank mismatch" }
+ call as_size( (b(1)) ) ! { dg-error "Rank mismatch" }
+ call as_size( (c(1)) ) ! { dg-error "Rank mismatch" }
+ call as_size( (d(1)) ) ! { dg-error "Rank mismatch" }
+ call as_size(a(1:2))
+ call as_size(b(1:2))
+ call as_size(c(1:2))
+ call as_size(d(1:2))
+ call as_size( (a(1:2)) )
+ call as_size( (b(1:2)) )
+ call as_size( (c(1:2)) )
+ call as_size( (d(1:2)) )
+
+ call as_shape(a)
+ call as_shape(b)
+ call as_shape(c) ! { dg-error "cannot be an assumed-size array" }
+ call as_shape(d)
+ call as_shape(e) ! { dg-error "Rank mismatch" }
+ call as_shape( 1 ) ! { dg-error "Rank mismatch" }
+ call as_shape( (/ 1 /) )
+ call as_shape( (a) )
+ call as_shape( (b) )
+ call as_shape( (c) ) ! { dg-error "The upper bound in the last dimension must appear in the reference to the assumed size array" }
+ call as_shape( (d) )
+ call as_shape( (e) ) ! { dg-error "Rank mismatch" }
+ call as_shape( (1) ) ! { dg-error "Rank mismatch" }
+ call as_shape( ((/ 1 /)) )
+ call as_shape(a(1)) ! { dg-error "Rank mismatch" }
+ call as_shape(b(1)) ! { dg-error "Rank mismatch" }
+ call as_shape(c(1)) ! { dg-error "Rank mismatch" }
+ call as_shape(d(1)) ! { dg-error "Rank mismatch" }
+ call as_shape( (a(1)) ) ! { dg-error "Rank mismatch" }
+ call as_shape( (b(1)) ) ! { dg-error "Rank mismatch" }
+ call as_shape( (c(1)) ) ! { dg-error "Rank mismatch" }
+ call as_shape( (d(1)) ) ! { dg-error "Rank mismatch" }
+ call as_shape(a(1:2))
+ call as_shape(b(1:2))
+ call as_shape(c(1:2))
+ call as_shape(d(1:2))
+ call as_shape( (a(1:2)) )
+ call as_shape( (b(1:2)) )
+ call as_shape( (c(1:2)) )
+ call as_shape( (d(1:2)) )
+
+ call as_expl(a)
+ call as_expl(b)
+ call as_expl(c)
+ call as_expl(d)
+ call as_expl(e) ! { dg-error "Rank mismatch" }
+ call as_expl( 1 ) ! { dg-error "Rank mismatch" }
+ call as_expl( (/ 1, 2, 3 /) )
+ call as_expl( (a) )
+ call as_expl( (b) )
+ call as_expl( (c) ) ! { dg-error "The upper bound in the last dimension must appear in the reference to the assumed size array" }
+ call as_expl( (d) )
+ call as_expl( (e) ) ! { dg-error "Rank mismatch" }
+ call as_expl(a(1)) ! { dg-error "Element of assumed-shaped" }
+ call as_expl(b(1)) ! { dg-error "Element of assumed-shaped" }
+ call as_expl(c(1))
+ call as_expl(d(1))
+ call as_expl( (a(1)) ) ! { dg-error "Rank mismatch" }
+ call as_expl( (b(1)) ) ! { dg-error "Rank mismatch" }
+ call as_expl( (c(1)) ) ! { dg-error "Rank mismatch" }
+ call as_expl( (d(1)) )  ! { dg-error "Rank mismatch" }
+ call as_expl(a(1:3))
+ call as_expl(b(1:3))
+ call as_expl(c(1:3))
+ call as_expl(d(1:3))
+ call as_expl( (a(1:3)) )
+ call as_expl( (b(1:3)) )
+ call as_expl( (c(1:3)) )
+ call as_expl( (d(1:3)) )
+END SUBROUTINE test1
+
+SUBROUTINE as_size(a)
+ integer, dimension(*) :: a
+END SUBROUTINE as_size
+
+SUBROUTINE as_shape(a)
+ integer, dimension(:) :: a
+END SUBROUTINE as_shape
+
+SUBROUTINE as_expl(a)
+ integer, dimension(3) :: a
+END SUBROUTINE as_expl
+
+
+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(a)
+ call cas_size(b)
+ call cas_size(c)
+ call cas_size(d)
+ call cas_size(e) ! { dg-error "Fortran 2003: Scalar CHARACTER" }
+ call cas_size("abc") ! { dg-error "Fortran 2003: Scalar CHARACTER" }
+ call cas_size( (/"abc"/) )
+ call cas_size(a//"a")
+ call cas_size(b//"a")
+ call cas_size(c//"a")  ! { dg-error "The upper bound in the last dimension must appear in the reference to the assumed size array" }
+ call cas_size(d//"a")
+ call cas_size(e//"a") ! { dg-error "Fortran 2003: Scalar CHARACTER" }
+ call cas_size(("abc")) ! { dg-error "Fortran 2003: Scalar CHARACTER" }
+ call cas_size( ((/"abc"/)) )
+ call cas_size(a(1)) ! { dg-error "Fortran 2003: Scalar CHARACTER" }
+ call cas_size(b(1)) ! { dg-error "Fortran 2003: Scalar CHARACTER" }
+ call cas_size(c(1)) ! OK in F95
+ call cas_size(d(1)) ! OK in F95
+ call cas_size((a(1)//"a")) ! { dg-error "Fortran 2003: Scalar CHARACTER" } 
+ call cas_size((b(1)//"a")) ! { dg-error "Fortran 2003: Scalar CHARACTER" }
+ call cas_size((c(1)//"a")) ! { dg-error "Fortran 2003: Scalar CHARACTER" } 
+ call cas_size((d(1)//"a")) ! { dg-error "Fortran 2003: Scalar CHARACTER" }
+ call cas_size(a(1:2))
+ call cas_size(b(1:2))
+ call cas_size(c(1:2))
+ call cas_size(d(1:2))
+ call cas_size((a(1:2)//"a"))
+ call cas_size((b(1:2)//"a"))
+ call cas_size((c(1:2)//"a"))
+ call cas_size((d(1:2)//"a"))
+ call cas_size(a(:)(1:3))
+ call cas_size(b(:)(1:3))
+ call cas_size(d(:)(1:3))
+ call cas_size((a(:)(1:3)//"a"))
+ call cas_size((b(:)(1:3)//"a"))
+ call cas_size((d(:)(1:3)//"a"))
+ call cas_size(a(1:2)(1:3))
+ call cas_size(b(1:2)(1:3))
+ call cas_size(c(1:2)(1:3))
+ call cas_size(d(1:2)(1:3))
+ call cas_size((a(1:2)(1:3)//"a"))
+ call cas_size((b(1:2)(1:3)//"a"))
+ call cas_size((c(1:2)(1:3)//"a"))
+ call cas_size((d(1:2)(1:3)//"a"))
+ call cas_size(e(1:3)) ! { dg-error "Fortran 2003: Scalar CHARACTER" } 
+ call cas_size("abcd"(1:3)) ! { dg-error "Fortran 2003: Scalar CHARACTER" } 
+ call cas_size((e(1:3))) ! { dg-error "Fortran 2003: Scalar CHARACTER" } 
+ call cas_size(("abcd"(1:3)//"a")) ! { dg-error "Fortran 2003: Scalar CHARACTER" } 
+
+ call cas_shape(a)
+ call cas_shape(b)
+ call cas_shape(c) ! { dg-error "cannot be an assumed-size array" }
+ call cas_shape(d)
+ call cas_shape(e) ! { dg-error "Rank mismatch" }
+ call cas_shape("abc") ! { dg-error "Rank mismatch" }
+ call cas_shape( (/"abc"/) )
+ call cas_shape(a//"c")
+ call cas_shape(b//"c")
+ call cas_shape(c//"c") ! { dg-error "The upper bound in the last dimension must appear in the reference to the assumed size array" }
+ call cas_shape(d//"c")
+ call cas_shape(e//"c") ! { dg-error "Rank mismatch" }
+ call cas_shape(("abc")) ! { dg-error "Rank mismatch" }
+ call cas_shape( ((/"abc"/)) )
+ call cas_shape(a(1)) ! { dg-error "Rank mismatch" }
+ call cas_shape(b(1)) ! { dg-error "Rank mismatch" }
+ call cas_shape(c(1)) ! { dg-error "Rank mismatch" }
+ call cas_shape(d(1)) ! { dg-error "Rank mismatch" }
+ call cas_shape(a(1:2))
+ call cas_shape(b(1:2))
+ call cas_shape(c(1:2))
+ call cas_shape(d(1:2))
+ call cas_shape((a(1:2)//"a"))
+ call cas_shape((b(1:2)//"a"))
+ call cas_shape((c(1:2)//"a"))
+ call cas_shape((d(1:2)//"a"))
+ call cas_shape(a(:)(1:3))
+ call cas_shape(b(:)(1:3))
+ call cas_shape(d(:)(1:3))
+ call cas_shape((a(:)(1:3)//"a"))
+ call cas_shape((b(:)(1:3)//"a"))
+ call cas_shape((d(:)(1:3)//"a"))
+ call cas_shape(a(1:2)(1:3))
+ call cas_shape(b(1:2)(1:3))
+ call cas_shape(c(1:2)(1:3))
+ call cas_shape(d(1:2)(1:3))
+ call cas_shape((a(1:2)(1:3)//"a"))
+ call cas_shape((b(1:2)(1:3)//"a"))
+ call cas_shape((c(1:2)(1:3)//"a"))
+ call cas_shape((d(1:2)(1:3)//"a"))
+ call cas_size(e(1:3)) ! { dg-error "Fortran 2003: Scalar CHARACTER" }
+ call cas_size("abcd"(1:3)) ! { dg-error "Fortran 2003: Scalar CHARACTER" }
+ call cas_size((e(1:3))) ! { dg-error "Fortran 2003: Scalar CHARACTER" }
+ call cas_size(("abcd"(1:3)//"a")) ! { dg-error "Fortran 2003: Scalar CHARACTER" }
+
+ call cas_expl(a)
+ call cas_expl(b)
+ call cas_expl(c)
+ call cas_expl(d)
+ call cas_expl(e) ! { dg-error "Fortran 2003: Scalar CHARACTER" }
+ call cas_expl("abc") ! { dg-error "Fortran 2003: Scalar CHARACTER" }
+ call cas_expl((/"a","b","c"/))
+ call cas_expl(a//"a")
+ call cas_expl(b//"a")
+ call cas_expl(c//"a")  ! { dg-error "The upper bound in the last dimension must appear in the reference to the assumed size array" }
+ call cas_expl(d//"a")
+ call cas_expl(e//"a") ! { dg-error "Fortran 2003: Scalar CHARACTER" }
+ call cas_expl(("abc")) ! { dg-error "Fortran 2003: Scalar CHARACTER" }
+ call cas_expl(((/"a","b","c"/)))
+ call cas_expl(a(1)) ! { dg-error "Fortran 2003: Scalar CHARACTER" }
+ call cas_expl(b(1)) ! { dg-error "Fortran 2003: Scalar CHARACTER" }
+ call cas_expl(c(1)) ! OK in F95
+ call cas_expl(d(1)) ! OK in F95
+ call cas_expl((a(1)//"a")) ! { dg-error "Fortran 2003: Scalar CHARACTER" }
+ call cas_expl((b(1)//"a")) ! { dg-error "Fortran 2003: Scalar CHARACTER" }
+ call cas_expl((c(1)//"a")) ! { dg-error "Fortran 2003: Scalar CHARACTER" }
+ call cas_expl((d(1)//"a")) ! { dg-error "Fortran 2003: Scalar CHARACTER" }
+ call cas_expl(a(1:3))
+ call cas_expl(b(1:3))
+ call cas_expl(c(1:3))
+ call cas_expl(d(1:3))
+ call cas_expl((a(1:3)//"a"))
+ call cas_expl((b(1:3)//"a"))
+ call cas_expl((c(1:3)//"a"))
+ call cas_expl((d(1:3)//"a"))
+ call cas_expl(a(:)(1:3))
+ call cas_expl(b(:)(1:3))
+ call cas_expl(d(:)(1:3))
+ call cas_expl((a(:)(1:3)))
+ call cas_expl((b(:)(1:3)))
+ call cas_expl((d(:)(1:3)))
+ call cas_expl(a(1:2)(1:3))
+ call cas_expl(b(1:2)(1:3))
+ call cas_expl(c(1:2)(1:3))
+ call cas_expl(d(1:2)(1:3))
+ call cas_expl((a(1:2)(1:3)//"a"))
+ call cas_expl((b(1:2)(1:3)//"a"))
+ call cas_expl((c(1:2)(1:3)//"a"))
+ call cas_expl((d(1:2)(1:3)//"a"))
+ call cas_expl(e(1:3)) ! { dg-error "Fortran 2003: Scalar CHARACTER" }
+ call cas_expl("abcd"(1:3)) ! { dg-error "Fortran 2003: Scalar CHARACTER" }
+ call cas_expl((e(1:3))) ! { dg-error "Fortran 2003: Scalar CHARACTER" }
+ call cas_expl(("abcd"(1:3)//"a")) ! { dg-error "Fortran 2003: Scalar CHARACTER" }
+END SUBROUTINE test2
+
+SUBROUTINE cas_size(a)
+ character(len=*), dimension(*) :: a
+END SUBROUTINE cas_size
+
+SUBROUTINE cas_shape(a)
+ character(len=*), dimension(:) :: a
+END SUBROUTINE cas_shape
+
+SUBROUTINE cas_expl(a)
+ character(len=*), dimension(3) :: a
+END SUBROUTINE cas_expl
+END
diff --git a/gcc/testsuite/gfortran.dg/argument_checking_12.f90 b/gcc/testsuite/gfortran.dg/argument_checking_12.f90
new file mode 100644
index 0000000..dc5b526
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/argument_checking_12.f90
@@ -0,0 +1,59 @@
+! { 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
+
diff --git a/gcc/testsuite/gfortran.dg/argument_checking_3.f90 b/gcc/testsuite/gfortran.dg/argument_checking_3.f90
index e59a039..1e01c1f 100644
--- a/gcc/testsuite/gfortran.dg/argument_checking_3.f90
+++ b/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" }
diff --git a/gcc/testsuite/gfortran.dg/assumed_shape_ranks_1.f90 b/gcc/testsuite/gfortran.dg/assumed_shape_ranks_1.f90
index a22a45c..e24414a 100644
--- a/gcc/testsuite/gfortran.dg/assumed_shape_ranks_1.f90
+++ b/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(:)
diff --git a/gcc/testsuite/gfortran.dg/c_assoc_2.f03 b/gcc/testsuite/gfortran.dg/c_assoc_2.f03
index 9bb2f1b..4b3b796 100644
--- a/gcc/testsuite/gfortran.dg/c_assoc_2.f03
+++ b/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
diff --git a/gcc/testsuite/gfortran.dg/derived_comp_array_ref_6.f90 b/gcc/testsuite/gfortran.dg/derived_comp_array_ref_6.f90
index b8a2a81..36a3067 100644
--- a/gcc/testsuite/gfortran.dg/derived_comp_array_ref_6.f90
+++ b/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
 
diff --git a/gcc/testsuite/gfortran.dg/implicit_actual.f90 b/gcc/testsuite/gfortran.dg/implicit_actual.f90
index 2a6dd66..750d3f3 100644
--- a/gcc/testsuite/gfortran.dg/implicit_actual.f90
+++ b/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
 
diff --git a/gcc/testsuite/gfortran.dg/import2.f90 b/gcc/testsuite/gfortran.dg/import2.f90
index e597cfc..4a0128a 100644
--- a/gcc/testsuite/gfortran.dg/import2.f90
+++ b/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" } }
diff --git a/gcc/testsuite/gfortran.dg/pointer_intent_2.f90 b/gcc/testsuite/gfortran.dg/pointer_intent_2.f90
index 88e9a08..6925703 100644
--- a/gcc/testsuite/gfortran.dg/pointer_intent_2.f90
+++ b/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" }
diff --git a/gcc/testsuite/gfortran.dg/used_dummy_types_3.f90 b/gcc/testsuite/gfortran.dg/used_dummy_types_3.f90
index 5bc4523..a308c0e 100644
--- a/gcc/testsuite/gfortran.dg/used_dummy_types_3.f90
+++ b/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" } }
diff --git a/gcc/testsuite/gfortran.dg/used_dummy_types_4.f90 b/gcc/testsuite/gfortran.dg/used_dummy_types_4.f90
index 4bc7c38..fb36fa7 100644
--- a/gcc/testsuite/gfortran.dg/used_dummy_types_4.f90
+++ b/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