From 67170043e9a7e6fe293e9c20d7ecc25587d125d3 Mon Sep 17 00:00:00 2001 From: burnus Date: Sun, 13 Jan 2008 21:35:33 +0000 Subject: [PATCH] 2008-01-13 Tobias Burnus 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 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. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@131513 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/ChangeLog | 10 + gcc/fortran/interface.c | 146 +++++++---- gcc/fortran/resolve.c | 9 + gcc/testsuite/ChangeLog | 15 ++ gcc/testsuite/gfortran.dg/argument_checking_11.f90 | 285 +++++++++++++++++++++ gcc/testsuite/gfortran.dg/argument_checking_12.f90 | 59 +++++ gcc/testsuite/gfortran.dg/argument_checking_3.f90 | 6 +- .../gfortran.dg/assumed_shape_ranks_1.f90 | 4 +- gcc/testsuite/gfortran.dg/c_assoc_2.f03 | 2 +- .../gfortran.dg/derived_comp_array_ref_6.f90 | 2 +- gcc/testsuite/gfortran.dg/implicit_actual.f90 | 2 +- gcc/testsuite/gfortran.dg/import2.f90 | 4 +- gcc/testsuite/gfortran.dg/pointer_intent_2.f90 | 2 +- gcc/testsuite/gfortran.dg/used_dummy_types_3.f90 | 2 +- gcc/testsuite/gfortran.dg/used_dummy_types_4.f90 | 2 +- 15 files changed, 486 insertions(+), 64 deletions(-) create mode 100644 gcc/testsuite/gfortran.dg/argument_checking_11.f90 create mode 100644 gcc/testsuite/gfortran.dg/argument_checking_12.f90 diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 683d66bbf91..9c2cc465e7f 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,5 +1,15 @@ 2008-01-13 Tobias Burnus + 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 + 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 8088fc65432..9057ef93285 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 0f96cd6eb75..0c4946e67bd 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 09b233e0644..180d9559063 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,5 +1,20 @@ 2008-01-13 Tobias Burnus + 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 + 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 00000000000..7c70c37ee47 --- /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 00000000000..dc5b5268ad6 --- /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 e59a039564b..1e01c1f3326 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 a22a45c109d..e24414ad355 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 9bb2f1b6abc..4b3b7963af9 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 b8a2a819b51..36a30672e32 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 2a6dd66c565..750d3f38501 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 e597cfc30b9..4a0128a0bf1 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 88e9a0823b0..692570339a3 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 5bc4523dd8d..a308c0e374a 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 4bc7c386895..fb36fa7bfbd 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 -- 2.11.0