This is the mail archive of the
gcc-patches@gcc.gnu.org
mailing list for the GCC project.
[Patch, Fortran] PR34665: Fix array actual/dummy conformance checks
- From: Tobias Burnus <burnus at net-b dot de>
- To: "'fortran at gcc dot gnu dot org'" <fortran at gcc dot gnu dot org>, gcc-patches <gcc-patches at gcc dot gnu dot org>
- Date: Sun, 13 Jan 2008 18:39:06 +0100
- Subject: [Patch, Fortran] PR34665: Fix array actual/dummy conformance checks
The following patch does:
- Reject passing an element of an assumed-shaped array to an array dummy
- Reject expressions as actual arguments, which involve assume-shaped
arrays (unknown upper bound; for assignment etc. it was rejected before).
- Do some other fixes; at least the "Fortran 2003" warning for passing
character strings to arrays was partially wrong before; valid F95 was
claimed as being F2003 only and invalid F95 was accepted with -std=f95.
- The error message are now a preciser instead of previous "Type/Rank
mismatch"
See 12.4.1.1 in F95 and 12.4.1.2 in F2003 (beginning of that section and
about one page later in "If the actual argument is scalar").
Build and regression tested on x86-64-linux.
OK for the trunk?
Tobias
PS: I solved my stupid problem about the array type. Using sym->ts.type
is not the same as sym->as->type; one gives you always the BT_ type and
the other the AS_ I was looking for.
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.
Index: gcc/fortran/resolve.c
===================================================================
--- gcc/fortran/resolve.c (Revision 131501)
+++ gcc/fortran/resolve.c (Arbeitskopie)
@@ -1013,6 +1013,7 @@ resolve_actual_arglist (gfc_actual_argli
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_argli
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_argli
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
Index: gcc/fortran/interface.c
===================================================================
--- gcc/fortran/interface.c (Revision 131501)
+++ gcc/fortran/interface.c (Arbeitskopie)
@@ -1420,9 +1420,10 @@ compare_pointer (gfc_symbol *formal, gfc
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, g
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;
-
- for (ref = actual->ref; ref; ref = ref->next)
- if (ref->type == REF_SUBSTRING)
+ rank_check = where != NULL && !is_elemental && formal->as
+ && (formal->as->type == AS_ASSUMED_SHAPE
+ || formal->as->type == AS_DEFERRED);
+
+ 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_arglis
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_arglis
"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
Index: gcc/testsuite/gfortran.dg/used_dummy_types_4.f90
===================================================================
--- gcc/testsuite/gfortran.dg/used_dummy_types_4.f90 (Revision 131501)
+++ gcc/testsuite/gfortran.dg/used_dummy_types_4.f90 (Arbeitskopie)
@@ -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
Index: gcc/testsuite/gfortran.dg/c_assoc_2.f03
===================================================================
--- gcc/testsuite/gfortran.dg/c_assoc_2.f03 (Revision 131501)
+++ gcc/testsuite/gfortran.dg/c_assoc_2.f03 (Arbeitskopie)
@@ -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
Index: gcc/testsuite/gfortran.dg/argument_checking_3.f90
===================================================================
--- gcc/testsuite/gfortran.dg/argument_checking_3.f90 (Revision 131501)
+++ gcc/testsuite/gfortran.dg/argument_checking_3.f90 (Arbeitskopie)
@@ -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" }
Index: gcc/testsuite/gfortran.dg/pointer_intent_2.f90
===================================================================
--- gcc/testsuite/gfortran.dg/pointer_intent_2.f90 (Revision 131501)
+++ gcc/testsuite/gfortran.dg/pointer_intent_2.f90 (Arbeitskopie)
@@ -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" }
Index: gcc/testsuite/gfortran.dg/import2.f90
===================================================================
--- gcc/testsuite/gfortran.dg/import2.f90 (Revision 131501)
+++ gcc/testsuite/gfortran.dg/import2.f90 (Arbeitskopie)
@@ -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" } }
Index: gcc/testsuite/gfortran.dg/assumed_shape_ranks_1.f90
===================================================================
--- gcc/testsuite/gfortran.dg/assumed_shape_ranks_1.f90 (Revision 131501)
+++ gcc/testsuite/gfortran.dg/assumed_shape_ranks_1.f90 (Arbeitskopie)
@@ -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(:)
Index: gcc/testsuite/gfortran.dg/implicit_actual.f90
===================================================================
--- gcc/testsuite/gfortran.dg/implicit_actual.f90 (Revision 131501)
+++ gcc/testsuite/gfortran.dg/implicit_actual.f90 (Arbeitskopie)
@@ -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
Index: gcc/testsuite/gfortran.dg/argument_checking_11.f90
===================================================================
--- gcc/testsuite/gfortran.dg/argument_checking_11.f90 (Revision 0)
+++ gcc/testsuite/gfortran.dg/argument_checking_11.f90 (Revision 0)
@@ -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
Index: gcc/testsuite/gfortran.dg/argument_checking_12.f90
===================================================================
--- gcc/testsuite/gfortran.dg/argument_checking_12.f90 (Revision 0)
+++ gcc/testsuite/gfortran.dg/argument_checking_12.f90 (Revision 0)
@@ -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
+
Index: gcc/testsuite/gfortran.dg/used_dummy_types_3.f90
===================================================================
--- gcc/testsuite/gfortran.dg/used_dummy_types_3.f90 (Revision 131501)
+++ gcc/testsuite/gfortran.dg/used_dummy_types_3.f90 (Arbeitskopie)
@@ -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" } }
Index: gcc/testsuite/gfortran.dg/derived_comp_array_ref_6.f90
===================================================================
--- gcc/testsuite/gfortran.dg/derived_comp_array_ref_6.f90 (Revision 131501)
+++ gcc/testsuite/gfortran.dg/derived_comp_array_ref_6.f90 (Arbeitskopie)
@@ -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