diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index c76ffcbb3e1..7f1bdc04be1 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,10 @@ +2020-01-03 Tobias Burnus + + PR fortran/92994 + * primary.c (gfc_match_rvalue): Add some flavor checks + gfc_matching_procptr_assignment. + * resolve.c (resolve_assoc_var): Add more checks for invalid targets. + 2020-01-02 Tobias Burnus PR fortran/68020 diff --git a/gcc/fortran/primary.c b/gcc/fortran/primary.c index 189b904527e..e2b6fcb2106 100644 --- a/gcc/fortran/primary.c +++ b/gcc/fortran/primary.c @@ -3447,7 +3447,19 @@ gfc_match_rvalue (gfc_expr **result) } if (gfc_matching_procptr_assignment) - goto procptr0; + { + /* It can be a procedure or a derived-type procedure or a not-yet-known + type. */ + if (sym->attr.flavor != FL_UNKNOWN + && sym->attr.flavor != FL_PROCEDURE + && sym->attr.flavor != FL_PARAMETER + && sym->attr.flavor != FL_VARIABLE) + { + gfc_error ("Symbol at %C is not appropriate for an expression"); + return MATCH_ERROR; + } + goto procptr0; + } if (sym->attr.function || sym->attr.external || sym->attr.intrinsic) goto function0; diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index 4aa5f1b568a..6f2a4c4d65a 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -8836,9 +8836,20 @@ resolve_assoc_var (gfc_symbol* sym, bool resolve_target) gcc_assert (target->symtree); tsym = target->symtree->n.sym; - if (tsym->attr.flavor == FL_PROGRAM) + + if (tsym->attr.subroutine + || tsym->attr.external + || (tsym->attr.function + && (tsym->result != tsym || tsym->attr.recursive))) { - gfc_error ("Associating entity %qs at %L is a PROGRAM", + gfc_error ("Associating entity %qs at %L is a procedure name", + tsym->name, &target->where); + return; + } + + if (gfc_expr_attr (target).proc_pointer) + { + gfc_error ("Associating entity %qs at %L is a procedure pointer", tsym->name, &target->where); return; } @@ -8851,6 +8862,12 @@ resolve_assoc_var (gfc_symbol* sym, bool resolve_target) if (is_subref_array (target)) sym->attr.subref_array_pointer = 1; } + else if (target->ts.type == BT_PROCEDURE) + { + gfc_error ("Associating selector-expression at %L yields a procedure", + &target->where); + return; + } if (target->expr_type == EXPR_NULL) { diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 07947c15d5e..2a3a45e4689 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,9 @@ +2020-01-03 Tobias Burnus + + PR fortran/92994 + * gfortran.dg/associate_50.f90: Update dg-error. + * gfortran.dg/associate_51.f90: New. + 2020-01-03 Jakub Jelinek PR fortran/68020 diff --git a/gcc/testsuite/gfortran.dg/associate_50.f90 b/gcc/testsuite/gfortran.dg/associate_50.f90 index d759db59b29..990ec58bffe 100644 --- a/gcc/testsuite/gfortran.dg/associate_50.f90 +++ b/gcc/testsuite/gfortran.dg/associate_50.f90 @@ -3,6 +3,6 @@ ! Test case by Gerhard Steinmetz. program p - associate (y => p) ! { dg-error "is a PROGRAM" } - end associate + associate (y => p) ! { dg-error "Invalid association target" } + end associate ! { dg-error "Expecting END PROGRAM statement" } end program p diff --git a/gcc/testsuite/gfortran.dg/associate_51.f90 b/gcc/testsuite/gfortran.dg/associate_51.f90 new file mode 100644 index 00000000000..7b3edc44990 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/associate_51.f90 @@ -0,0 +1,54 @@ +! { dg-do compile } +! +! PR fortran/92994 +! +! Contributed by G. Steinmetz +! +recursive function f() result(z) + associate (y1 => f()) + end associate + associate (y2 => f) ! { dg-error "is a procedure name" } + end associate +end + +recursive function f2() + associate (y1 => f2()) ! { dg-error "Invalid association target" } + end associate ! { dg-error "Expecting END FUNCTION statement" } + associate (y2 => f2) ! { dg-error "is a procedure name" } + end associate +end + +subroutine p2 + type t + end type + type(t) :: z = t() + associate (y => t) + end associate +end + +subroutine p3 + procedure() :: g + associate (y => g) ! { dg-error "is a procedure name" } + end associate +end + +subroutine p4 + external :: g + associate (y => g) ! { dg-error "is a procedure name" } + end associate +end + +recursive subroutine s + associate (y => s) ! { dg-error "is a procedure name" } + end associate +end + +recursive subroutine s2 + associate (y => (s2)) ! { dg-error "Associating selector-expression at .1. yields a procedure" } + end associate +end + +program p + associate (y => (p)) ! { dg-error "Invalid association target" } + end associate ! { dg-error "Expecting END PROGRAM statement" } +end