diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index cf840a58cc32..6e5584a01a40 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,17 @@ +2006-10-03 Paul Thomas + + PR fortran/29284 + PR fortran/29321 + PR fortran/29322 + * trans-expr.c (gfc_conv_function_call): Check the expression + and the formal symbol are present when testing the actual + argument. + + PR fortran/25091 + PR fortran/25092 + * resolve.c (resolve_entries): It is an error if the entries + of an array-valued function do not have the same shape. + 2006-10-03 Francois-Xavier Coudert PR middle-end/27478 diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index c9af0c01b745..854d3b438450 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -419,23 +419,33 @@ resolve_entries (gfc_namespace * ns) { gfc_symbol *sym; gfc_typespec *ts, *fts; - + gfc_array_spec *as, *fas; gfc_add_function (&proc->attr, proc->name, NULL); proc->result = proc; + fas = ns->entries->sym->as; + fas = fas ? fas : ns->entries->sym->result->as; fts = &ns->entries->sym->result->ts; if (fts->type == BT_UNKNOWN) fts = gfc_get_default_type (ns->entries->sym->result, NULL); for (el = ns->entries->next; el; el = el->next) { ts = &el->sym->result->ts; + as = el->sym->as; + as = as ? as : el->sym->result->as; if (ts->type == BT_UNKNOWN) ts = gfc_get_default_type (el->sym->result, NULL); + if (! gfc_compare_types (ts, fts) || (el->sym->result->attr.dimension != ns->entries->sym->result->attr.dimension) || (el->sym->result->attr.pointer != ns->entries->sym->result->attr.pointer)) break; + + else if (as && fas && gfc_compare_array_spec (as, fas) == 0) + gfc_error ("Procedure %s at %L has entries with mismatched " + "array specifications", ns->entries->sym->name, + &ns->entries->sym->declared_at); } if (el == NULL) diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index e477f9c06123..4bce65e47ff2 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -2006,39 +2006,50 @@ gfc_conv_function_call (gfc_se * se, gfc_symbol * sym, } } - /* If an optional argument is itself an optional dummy argument, - check its presence and substitute a null if absent. */ - if (e && e->expr_type == EXPR_VARIABLE - && e->symtree->n.sym->attr.optional - && fsym && fsym->attr.optional) - gfc_conv_missing_dummy (&parmse, e, fsym->ts); + if (fsym) + { + if (e) + { + /* If an optional argument is itself an optional dummy + argument, check its presence and substitute a null + if absent. */ + if (e->expr_type == EXPR_VARIABLE + && e->symtree->n.sym->attr.optional + && fsym->attr.optional) + gfc_conv_missing_dummy (&parmse, e, fsym->ts); - if (fsym && need_interface_mapping) - gfc_add_interface_mapping (&mapping, fsym, &parmse); + /* If an INTENT(OUT) dummy of derived type has a default + initializer, it must be (re)initialized here. */ + if (fsym->attr.intent == INTENT_OUT + && fsym->ts.type == BT_DERIVED + && fsym->value) + { + gcc_assert (!fsym->attr.allocatable); + tmp = gfc_trans_assignment (e, fsym->value); + gfc_add_expr_to_block (&se->pre, tmp); + } + + /* Obtain the character length of an assumed character + length procedure from the typespec. */ + if (fsym->ts.type == BT_CHARACTER + && parmse.string_length == NULL_TREE + && e->ts.type == BT_PROCEDURE + && e->symtree->n.sym->ts.type == BT_CHARACTER + && e->symtree->n.sym->ts.cl->length != NULL) + { + gfc_conv_const_charlen (e->symtree->n.sym->ts.cl); + parmse.string_length + = e->symtree->n.sym->ts.cl->backend_decl; + } + } + + if (need_interface_mapping) + gfc_add_interface_mapping (&mapping, fsym, &parmse); + } gfc_add_block_to_block (&se->pre, &parmse.pre); gfc_add_block_to_block (&post, &parmse.post); - /* If an INTENT(OUT) dummy of derived type has a default - initializer, it must be (re)initialized here. */ - if (fsym && fsym->attr.intent == INTENT_OUT && fsym->ts.type == BT_DERIVED - && fsym->value) - { - gcc_assert (!fsym->attr.allocatable); - tmp = gfc_trans_assignment (e, fsym->value); - gfc_add_expr_to_block (&se->pre, tmp); - } - - if (fsym && fsym->ts.type == BT_CHARACTER - && parmse.string_length == NULL_TREE - && e->ts.type == BT_PROCEDURE - && e->symtree->n.sym->ts.type == BT_CHARACTER - && e->symtree->n.sym->ts.cl->length != NULL) - { - gfc_conv_const_charlen (e->symtree->n.sym->ts.cl); - parmse.string_length = e->symtree->n.sym->ts.cl->backend_decl; - } - /* Character strings are passed as two parameters, a length and a pointer. */ if (parmse.string_length != NULL_TREE) diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 8615b8167672..5e3a75be5195 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,16 @@ +2006-10-03 Paul Thomas + + PR fortran/29284 + * gfortran.dg/optional_assumed_charlen_1.f90: New test. + + PR fortran/29321 + PR fortran/29322 + * gfortran.dg/missing_optional_dummy_2.f90: New test. + + PR fortran/25091 + PR fortran/25092 + * gfortran.dg/entry_array_specs_1.f90: New test. + 2006-10-03 Steven G. Kargl * gfortran.dg/nearest_1.f90: Add -O0 because -ffloat-store is diff --git a/gcc/testsuite/gfortran.dg/entry_array_specs_1.f90 b/gcc/testsuite/gfortran.dg/entry_array_specs_1.f90 new file mode 100644 index 000000000000..5e6e5f676500 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/entry_array_specs_1.f90 @@ -0,0 +1,39 @@ +! { dg-do compile } +! Tests the fix for PR25091 and PR25092 in which mismatched array +! specifications between entries of the same procedure were not diagnosed. + +! Contributed by Joost VandeVondele + +! This was PR25091 - no diagnostic given on error + FUNCTION F1() RESULT(RES_F1) ! { dg-error "mismatched array specifications" } + INTEGER RES_F1(2,2) + INTEGER RES_E1(4) + ENTRY E1() RESULT(RES_E1) + END FUNCTION + +! This was PR25092 - no diagnostic given on error + FUNCTION F2() RESULT(RES_F2) ! { dg-error "mismatched array specifications" } + INTEGER :: RES_F2(4) + INTEGER :: RES_E2(3) + ENTRY E2() RESULT(RES_E2) + END FUNCTION + +! Check that the versions without explicit results give the error + FUNCTION F3() ! { dg-error "mismatched array specifications" } + INTEGER :: F3(4) + INTEGER :: E3(2,2) + ENTRY E3() + END FUNCTION + + FUNCTION F4() ! { dg-error "mismatched array specifications" } + INTEGER :: F4(4) + INTEGER :: E4(3) + ENTRY E4() + END FUNCTION + +! Check that conforming entries are OK. + FUNCTION F5() + INTEGER :: F5(4,5,6) + INTEGER :: E5(4,5,6) + ENTRY E5() + END FUNCTION diff --git a/gcc/testsuite/gfortran.dg/missing_optional_dummy_2.f90 b/gcc/testsuite/gfortran.dg/missing_optional_dummy_2.f90 new file mode 100644 index 000000000000..100784d8704e --- /dev/null +++ b/gcc/testsuite/gfortran.dg/missing_optional_dummy_2.f90 @@ -0,0 +1,40 @@ +! { dg-do compile } +! Tests the fix for PR29321 and PR29322, in which ICEs occurred for the +! lack of proper attention to checking pointers in gfc_conv_function_call. +! +! Contributed by Olav Vahtras +! and Francois-Xavier Coudert +! +MODULE myint + TYPE NUM + INTEGER :: R = 0 + END TYPE NUM + CONTAINS + FUNCTION FUNC(A,B) RESULT(E) + IMPLICIT NONE + TYPE(NUM) A,B,E + INTENT(IN) :: A,B + OPTIONAL B + E%R=A%R + CALL SUB(A,E) + END FUNCTION FUNC + + SUBROUTINE SUB(A,E,B,C) + IMPLICIT NONE + TYPE(NUM) A,E,B,C + INTENT(IN) A,B + INTENT(OUT) E,C + OPTIONAL B,C + E%R=A%R + END SUBROUTINE SUB +END MODULE myint + + if (isscan () /= 0) call abort +contains + integer function isscan (substr) + character(*), optional :: substr + if (.not.present(substr)) isscan = myscan ("foo", "over") + end function isscan +end +! { dg-final { cleanup-modules "myint" } } + diff --git a/gcc/testsuite/gfortran.dg/optional_assumed_charlen_1.f90 b/gcc/testsuite/gfortran.dg/optional_assumed_charlen_1.f90 new file mode 100644 index 000000000000..90631aa616e5 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/optional_assumed_charlen_1.f90 @@ -0,0 +1,20 @@ +! { dg-do compile } +! Tests the fix for PR29284 in which an ICE would occur in converting +! the call to a suboutine with an assumed character length, optional +! dummy that is not present. +! +! Contributed by Rakuen Himawari +! + MODULE foo + CONTAINS + SUBROUTINE sub1(a) + CHARACTER (LEN=*), OPTIONAL :: a + WRITE(*,*) 'foo bar' + END SUBROUTINE sub1 + + SUBROUTINE sub2 + CALL sub1() + END SUBROUTINE sub2 + + END MODULE foo +! { dg-final { cleanup-modules "foo" } }