diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index d21a2bf502c..96fbeab5ff5 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,10 +1,33 @@ +2006-07-16 Paul Thomas + + PR fortran/28384 + * trans-common.c (translate_common): If common_segment is NULL + emit error that common block does not exist. + + PR fortran/20844 + * io.c (check_io_constraints): It is an error if an ADVANCE + specifier appears without an explicit format. + + PR fortran/28201 + * resolve.c (resolve_generic_s): For a use_associated function, + do not search for an alternative symbol in the parent name + space. + + PR fortran/20893 + * resolve.c (resolve_elemental_actual): New function t combine + all the checks of elemental procedure actual arguments. In + addition, check of array valued optional args(this PR) has + been added. + (resolve_function, resolve_call): Remove parts that treated + elemental procedure actual arguments and call the above. + 2006-07-14 Steven G. Kargl * trans-expr.c (gfc_trans_string_copy): Evaluate the string lengths 006-07-13 Paul Thomas - PR fortran/28174 + PR fortran/28353 * trans-expr.c (gfc_conv_aliased_arg): Missing formal arg means that intent is INOUT (fixes regression). diff --git a/gcc/fortran/io.c b/gcc/fortran/io.c index 725e2da6655..6cf74ee69f7 100644 --- a/gcc/fortran/io.c +++ b/gcc/fortran/io.c @@ -2340,6 +2340,12 @@ if (condition) \ "List directed format(*) is not allowed with a " "ADVANCE=specifier at %L.", &expr->where); + io_constraint (dt->format_expr == NULL + && dt->format_label == NULL + && dt->namelist == NULL, + "the ADVANCE=specifier at %L must appear with an " + "explicit format expression", &expr->where); + if (expr->expr_type == EXPR_CONSTANT && expr->ts.type == BT_CHARACTER) { const char * advance = expr->value.character.string; diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index c3aaf87c0c9..aee04eccd6c 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -910,6 +910,147 @@ resolve_actual_arglist (gfc_actual_arglist * arg) } +/* Do the checks of the actual argument list that are specific to elemental + procedures. If called with c == NULL, we have a function, otherwise if + expr == NULL, we have a subroutine. */ +static try +resolve_elemental_actual (gfc_expr *expr, gfc_code *c) +{ + gfc_actual_arglist *arg0; + gfc_actual_arglist *arg; + gfc_symbol *esym = NULL; + gfc_intrinsic_sym *isym = NULL; + gfc_expr *e = NULL; + gfc_intrinsic_arg *iformal = NULL; + gfc_formal_arglist *eformal = NULL; + bool formal_optional = false; + bool set_by_optional = false; + int i; + int rank = 0; + + /* Is this an elemental procedure? */ + if (expr && expr->value.function.actual != NULL) + { + if (expr->value.function.esym != NULL + && expr->value.function.esym->attr.elemental) + { + arg0 = expr->value.function.actual; + esym = expr->value.function.esym; + } + else if (expr->value.function.isym != NULL + && expr->value.function.isym->elemental) + { + arg0 = expr->value.function.actual; + isym = expr->value.function.isym; + } + else + return SUCCESS; + } + else if (c && c->ext.actual != NULL + && c->symtree->n.sym->attr.elemental) + { + arg0 = c->ext.actual; + esym = c->symtree->n.sym; + } + else + return SUCCESS; + + /* The rank of an elemental is the rank of its array argument(s). */ + for (arg = arg0; arg; arg = arg->next) + { + if (arg->expr != NULL && arg->expr->rank > 0) + { + rank = arg->expr->rank; + if (arg->expr->expr_type == EXPR_VARIABLE + && arg->expr->symtree->n.sym->attr.optional) + set_by_optional = true; + + /* Function specific; set the result rank and shape. */ + if (expr) + { + expr->rank = rank; + if (!expr->shape && arg->expr->shape) + { + expr->shape = gfc_get_shape (rank); + for (i = 0; i < rank; i++) + mpz_init_set (expr->shape[i], arg->expr->shape[i]); + } + } + break; + } + } + + /* If it is an array, it shall not be supplied as an actual argument + to an elemental procedure unless an array of the same rank is supplied + as an actual argument corresponding to a nonoptional dummy argument of + that elemental procedure(12.4.1.5). */ + formal_optional = false; + if (isym) + iformal = isym->formal; + else + eformal = esym->formal; + + for (arg = arg0; arg; arg = arg->next) + { + if (eformal) + { + if (eformal->sym && eformal->sym->attr.optional) + formal_optional = true; + eformal = eformal->next; + } + else if (isym && iformal) + { + if (iformal->optional) + formal_optional = true; + iformal = iformal->next; + } + else if (isym) + formal_optional = true; + + if (arg->expr != NULL + && arg->expr->expr_type == EXPR_VARIABLE + && arg->expr->symtree->n.sym->attr.optional + && formal_optional + && arg->expr->rank + && (set_by_optional || arg->expr->rank != rank)) + { + gfc_error ("'%s' at %L is an array and OPTIONAL; it cannot " + "therefore be an actual argument of an ELEMENTAL " + "procedure unless there is a non-optional argument " + "with the same rank (12.4.1.5)", + arg->expr->symtree->n.sym->name, &arg->expr->where); + return FAILURE; + } + } + + for (arg = arg0; arg; arg = arg->next) + { + if (arg->expr == NULL || arg->expr->rank == 0) + continue; + + /* Being elemental, the last upper bound of an assumed size array + argument must be present. */ + if (resolve_assumed_size_actual (arg->expr)) + return FAILURE; + + if (expr) + continue; + + /* Elemental subroutine array actual arguments must conform. */ + if (e != NULL) + { + if (gfc_check_conformance ("elemental subroutine", arg->expr, e) + == FAILURE) + return FAILURE; + } + else + e = arg->expr; + } + + return SUCCESS; +} + + /* Go through each actual argument in ACTUAL and see if it can be implemented as an inlined, non-copying intrinsic. FNSYM is the function being called, or NULL if not known. */ @@ -1237,7 +1378,6 @@ resolve_function (gfc_expr * expr) const char *name; try t; int temp; - int i; sym = NULL; if (expr->symtree) @@ -1313,38 +1453,9 @@ resolve_function (gfc_expr * expr) temp = need_full_assumed_size; need_full_assumed_size = 0; - if (expr->value.function.actual != NULL - && ((expr->value.function.esym != NULL - && expr->value.function.esym->attr.elemental) - || (expr->value.function.isym != NULL - && expr->value.function.isym->elemental))) - { - /* The rank of an elemental is the rank of its array argument(s). */ - for (arg = expr->value.function.actual; arg; arg = arg->next) - { - if (arg->expr != NULL && arg->expr->rank > 0) - { - expr->rank = arg->expr->rank; - if (!expr->shape && arg->expr->shape) - { - expr->shape = gfc_get_shape (expr->rank); - for (i = 0; i < expr->rank; i++) - mpz_init_set (expr->shape[i], arg->expr->shape[i]); - } - break; - } - } + if (resolve_elemental_actual (expr, NULL) == FAILURE) + return FAILURE; - /* Being elemental, the last upper bound of an assumed size array - argument must be present. */ - for (arg = expr->value.function.actual; arg; arg = arg->next) - { - if (arg->expr != NULL - && arg->expr->rank > 0 - && resolve_assumed_size_actual (arg->expr)) - return FAILURE; - } - } if (omp_workshare_flag && expr->value.function.esym && ! gfc_elemental (expr->value.function.esym)) @@ -1500,7 +1611,7 @@ resolve_generic_s (gfc_code * c) if (m == MATCH_ERROR) return FAILURE; - if (sym->ns->parent != NULL) + if (sym->ns->parent != NULL && !sym->attr.use_assoc) { gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym); if (sym != NULL) @@ -1730,35 +1841,9 @@ resolve_call (gfc_code * c) gfc_internal_error ("resolve_subroutine(): bad function type"); } - /* Some checks of elemental subroutines. */ - if (c->ext.actual != NULL - && c->symtree->n.sym->attr.elemental) - { - gfc_actual_arglist * a; - gfc_expr * e; - e = NULL; - - for (a = c->ext.actual; a; a = a->next) - { - if (a->expr == NULL || a->expr->rank == 0) - continue; - - /* The last upper bound of an assumed size array argument must - be present. */ - if (resolve_assumed_size_actual (a->expr)) - return FAILURE; - - /* Array actual arguments must conform. */ - if (e != NULL) - { - if (gfc_check_conformance ("elemental subroutine", a->expr, e) - == FAILURE) - return FAILURE; - } - else - e = a->expr; - } - } + /* Some checks of elemental subroutine actual arguments. */ + if (resolve_elemental_actual (NULL, c) == FAILURE) + return FAILURE; if (t == SUCCESS) find_noncopying_intrinsics (c->resolved_sym, c->ext.actual); diff --git a/gcc/fortran/trans-common.c b/gcc/fortran/trans-common.c index f3b0f126bc9..5350eacdef0 100644 --- a/gcc/fortran/trans-common.c +++ b/gcc/fortran/trans-common.c @@ -962,6 +962,13 @@ translate_common (gfc_common_head *common, gfc_symbol *var_list) current_offset += s->length; } + if (common_segment == NULL) + { + gfc_error ("COMMON '%s' at %L does not exist", + common->name, &common->where); + return; + } + if (common_segment->offset != 0) { gfc_warning ("COMMON '%s' at %L requires %d bytes of padding at start", diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 9e7e540c9fa..68b45a291ec 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,15 @@ +2006-07-16 Paul Thomas + + PR fortran/20844 + * gfortran.dg/io_constaints_2.f90: Add the test for ADVANCE + specifiers requiring an explicit format tag.. + + PR fortran/28201 + * gfortran.dg/generic_5: New test. + + PR fortran/20893 + * gfortran.dg/elemental_optional_args_1.f90: New test. + 2006-07-16 Olivier Hainque * gnat.dg/assert.ads: New file. diff --git a/gcc/testsuite/gfortran.dg/elemental_optional_args_1.f90 b/gcc/testsuite/gfortran.dg/elemental_optional_args_1.f90 new file mode 100644 index 00000000000..258b6b0f76a --- /dev/null +++ b/gcc/testsuite/gfortran.dg/elemental_optional_args_1.f90 @@ -0,0 +1,52 @@ +! { dg-do compile } +! Check the fix for PR20893, in which actual arguments could violate: +! "(5) If it is an array, it shall not be supplied as an actual argument to +! an elemental procedure unless an array of the same rank is supplied as an +! actual argument corresponding to a nonoptional dummy argument of that +! elemental procedure." (12.4.1.5) +! +! Contributed by Joost VandeVondele +! + CALL T1(1,2) +CONTAINS + SUBROUTINE T1(A1,A2,A3) + INTEGER :: A1,A2, A4(2) + INTEGER, OPTIONAL :: A3(2) + interface + elemental function efoo (B1,B2,B3) result(bar) + INTEGER, intent(in) :: B1, B2 + integer :: bar + INTEGER, OPTIONAL, intent(in) :: B3 + end function efoo + end interface + +! check an intrinsic function + write(6,*) MAX(A1,A2,A3) ! { dg-error "array and OPTIONAL" } + write(6,*) MAX(A1,A3,A2) + write(6,*) MAX(A1,A4,A3) +! check an internal elemental function + write(6,*) foo(A1,A2,A3) ! { dg-error "array and OPTIONAL" } + write(6,*) foo(A1,A3,A2) + write(6,*) foo(A1,A4,A3) +! check an external elemental function + write(6,*) efoo(A1,A2,A3) ! { dg-error "array and OPTIONAL" } + write(6,*) efoo(A1,A3,A2) + write(6,*) efoo(A1,A4,A3) +! check an elemental subroutine + call foobar (A1,A2,A3) ! { dg-error "array and OPTIONAL" } + call foobar (A1,A2,A4) + call foobar (A1,A4,A4) + END SUBROUTINE + elemental function foo (B1,B2,B3) result(bar) + INTEGER, intent(in) :: B1, B2 + integer :: bar + INTEGER, OPTIONAL, intent(in) :: B3 + bar = 1 + end function foo + elemental subroutine foobar (B1,B2,B3) + INTEGER, intent(OUT) :: B1 + INTEGER, optional, intent(in) :: B2, B3 + B1 = 1 + end subroutine foobar + +END \ No newline at end of file diff --git a/gcc/testsuite/gfortran.dg/generic_5.f90 b/gcc/testsuite/gfortran.dg/generic_5.f90 new file mode 100644 index 00000000000..037dba27c65 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/generic_5.f90 @@ -0,0 +1,29 @@ +! { dg-do compile } +! Tests the patch for PR28201, in which the call to ice would cause an ICE +! because resolve.c(resolve_generic_s) would try to look in the parent +! namespace to see if the subroutine was part of a legal generic interface. +! In this case, there is nothing to test, hence the ICE. +! +! Contributed by Daniel Franke +! +! +MODULE ice_gfortran + INTERFACE ice + MODULE PROCEDURE ice_i + END INTERFACE + +CONTAINS + SUBROUTINE ice_i(i) + INTEGER, INTENT(IN) :: i + ! do nothing + END SUBROUTINE +END MODULE + +MODULE provoke_ice +CONTAINS + SUBROUTINE provoke + USE ice_gfortran + CALL ice(23.0) ! { dg-error "is not an intrinsic subroutine" } + END SUBROUTINE +END MODULE + diff --git a/gcc/testsuite/gfortran.dg/io_constraints_2.f90 b/gcc/testsuite/gfortran.dg/io_constraints_2.f90 index ec0bd7a967f..c2a49e29d16 100644 --- a/gcc/testsuite/gfortran.dg/io_constraints_2.f90 +++ b/gcc/testsuite/gfortran.dg/io_constraints_2.f90 @@ -1,6 +1,7 @@ ! { dg-do compile } ! Part II of the test of the IO constraints patch, which fixes PRs: ! PRs 25053, 25063, 25064, 25066, 25067, 25068, 25069, 25307 and 20862. +! Modified2006-07-08 to check the patch for PR20844. ! ! Contributed by Paul Thomas ! @@ -52,6 +53,8 @@ end module global READ(buffer, fmt='(i6)', advance='YES') a ! { dg-error "internal file" } READ(1, NML=NL, advance='YES') ! { dg-error "NAMELIST IO is not allowed" } + READ(1, advance='YES') ! { dg-error "must appear with an explicit format" } + write(1, fmt='(i6)', advance='YES', size = c(1)) a ! { dg-error "output" } write(1, fmt='(i6)', advance='YES', eor = 100) a ! { dg-error "output" }