From bcf20dd19c8c508acde8aa4d90e614c88968f8d9 Mon Sep 17 00:00:00 2001 From: burnus Date: Sun, 13 Feb 2011 19:26:24 +0000 Subject: [PATCH] 2011-02-13 Tobias Burnus PR fortran/47569 * interface.c (compare_parameter): Avoid ICE with character components. 2011-02-13 Tobias Burnus * gfortran.dg/argument_checking_13.f90: Update dg-error. * gfortran.dg/argument_checking_17.f90: New. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@170110 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/ChangeLog | 6 ++ gcc/fortran/interface.c | 73 ++++++++++++++-------- gcc/testsuite/ChangeLog | 5 ++ gcc/testsuite/gfortran.dg/argument_checking_13.f90 | 6 +- gcc/testsuite/gfortran.dg/argument_checking_17.f90 | 26 ++++++++ 5 files changed, 88 insertions(+), 28 deletions(-) create mode 100644 gcc/testsuite/gfortran.dg/argument_checking_17.f90 diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index e3b545f904d..1f63accb159 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,9 @@ +2011-02-13 Tobias Burnus + + PR fortran/47569 + * interface.c (compare_parameter): Avoid ICE with + character components. + 2011-02-12 Janus Weil * class.c (gfc_build_class_symbol): Reject polymorphic arrays. diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c index 1e5df61b545..a03bbebb674 100644 --- a/gcc/fortran/interface.c +++ b/gcc/fortran/interface.c @@ -1461,7 +1461,7 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual, int ranks_must_agree, int is_elemental, locus *where) { gfc_ref *ref; - bool rank_check; + bool rank_check, is_pointer; /* 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 @@ -1672,23 +1672,56 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual, 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), + is valid (cf. F95 12.4.1.1, F2003 12.4.1.2, and F2008 12.5.2.4), - 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. */ + non-assumed-shape/non-pointer/non-polymorphic array; or + - (F2003) if the actual argument is of type character of default/c_char + kind. */ + + is_pointer = actual->expr_type == EXPR_VARIABLE + ? actual->symtree->n.sym->attr.pointer : false; for (ref = actual->ref; ref; ref = ref->next) - if (ref->type == REF_ARRAY && ref->u.ar.type == AR_ELEMENT - && ref->u.ar.dimen > 0) - break; + { + if (ref->type == REF_COMPONENT) + is_pointer = ref->u.c.component->attr.pointer; + else if (ref->type == REF_ARRAY && ref->u.ar.type == AR_ELEMENT + && ref->u.ar.dimen > 0 + && (!ref->next + || (ref->next->type == REF_SUBSTRING && !ref->next->next))) + break; + } + + if (actual->ts.type == BT_CLASS && actual->expr_type != EXPR_NULL) + { + if (where) + gfc_error ("Polymorphic scalar passed to array dummy argument '%s' " + "at %L", formal->name, &actual->where); + return 0; + } - /* 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->attr.pointer)))) + if (actual->expr_type != EXPR_NULL && ref && actual->ts.type != BT_CHARACTER + && (is_pointer || ref->u.ar.as->type == AS_ASSUMED_SHAPE)) { + if (where) + gfc_error ("Element of assumed-shaped or pointer " + "array passed to array dummy argument '%s' at %L", + formal->name, &actual->where); + return 0; + } + + if (actual->ts.type == BT_CHARACTER && actual->expr_type != EXPR_NULL + && (!ref || is_pointer || ref->u.ar.as->type == AS_ASSUMED_SHAPE)) + { + if (formal->ts.kind != 1 && (gfc_option.allow_std & GFC_STD_GNU) == 0) + { + if (where) + gfc_error ("Extension: Scalar non-default-kind, non-C_CHAR-kind " + "CHARACTER actual argument with array dummy argument " + "'%s' at %L", formal->name, &actual->where); + return 0; + } + if (where && (gfc_option.allow_std & GFC_STD_F2003) == 0) { gfc_error ("Fortran 2003: Scalar CHARACTER actual argument with " @@ -1701,7 +1734,8 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual, else return 1; } - else if (ref == NULL && actual->expr_type != EXPR_NULL) + + if (ref == NULL && actual->expr_type != EXPR_NULL) { if (where) argument_rank_mismatch (formal->name, &actual->where, @@ -1709,17 +1743,6 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual, 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->attr.pointer)) - { - if (where) - gfc_error ("Element of assumed-shaped array passed to dummy " - "argument '%s' at %L", formal->name, &actual->where); - return 0; - } - return 1; } diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index db4c7acf564..fb27e998890 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,8 @@ +2011-02-13 Tobias Burnus + + * gfortran.dg/argument_checking_13.f90: Update dg-error. + * gfortran.dg/argument_checking_17.f90: New. + 2011-02-12 Janus Weil * gfortran.dg/allocate_derived_1.f90: Modified as polymorphic arrays diff --git a/gcc/testsuite/gfortran.dg/argument_checking_13.f90 b/gcc/testsuite/gfortran.dg/argument_checking_13.f90 index ae3fd22b443..b94bbc7ec75 100644 --- a/gcc/testsuite/gfortran.dg/argument_checking_13.f90 +++ b/gcc/testsuite/gfortran.dg/argument_checking_13.f90 @@ -26,9 +26,9 @@ real, pointer :: pointer_dummy(:,:,:) real, allocatable :: deferred(:,:,:) real, pointer :: ptr(:,:,:) call rlv1(deferred(1,1,1)) ! valid since contiguous -call rlv1(ptr(1,1,1)) ! { dg-error "Element of assumed-shaped array" } -call rlv1(assumed_sh_dummy(1,1,1)) ! { dg-error "Element of assumed-shaped array" } -call rlv1(pointer_dummy(1,1,1)) ! { dg-error "Element of assumed-shaped array" } +call rlv1(ptr(1,1,1)) ! { dg-error "Element of assumed-shaped or pointer array" } +call rlv1(assumed_sh_dummy(1,1,1)) ! { dg-error "Element of assumed-shaped or pointer array" } +call rlv1(pointer_dummy(1,1,1)) ! { dg-error "Element of assumed-shaped or pointer array" } end subroutine test2(assumed_sh_dummy, pointer_dummy) diff --git a/gcc/testsuite/gfortran.dg/argument_checking_17.f90 b/gcc/testsuite/gfortran.dg/argument_checking_17.f90 new file mode 100644 index 00000000000..df8296ba511 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/argument_checking_17.f90 @@ -0,0 +1,26 @@ +! { dg-do compile } +! +! PR fortran/47569 +! +! Contributed by Jos de Kloe +! +module teststr + implicit none + integer, parameter :: GRH_SIZE = 20, NMAX = 41624 + type strtype + integer :: size + character :: mdr(NMAX) + end type strtype +contains + subroutine sub2(string,str_size) + integer,intent(in) :: str_size + character,intent(out) :: string(str_size) + string(:) = 'a' + end subroutine sub2 + subroutine sub1(a) + type(strtype),intent(inout) :: a + call sub2(a%mdr(GRH_SIZE+1),a%size-GRH_SIZE) + end subroutine sub1 +end module teststr + +! { dg-final { cleanup-modules "teststr" } } -- 2.11.4.GIT