From f9ea46d946887a05d7ecbca5aeeb99fd868f6e70 Mon Sep 17 00:00:00 2001 From: "Steven G. Kargl" Date: Fri, 18 Apr 2025 18:05:10 -0700 Subject: Fortran: Fix checking for IMPURE in DO CONCURRENT. PR fortran/119836 gcc/fortran/ChangeLog: * resolve.cc (check_pure_function): Fix checking for an impure subprogram within a DO CONCURRENT construct. (pure_subroutine): Ditto. gcc/testsuite/ChangeLog: * gfortran.dg/do_concurrent_all_clauses.f90: Remove invalid dg-error test. * gfortran.dg/pr119836_1.f90: New test. * gfortran.dg/pr119836_2.f90: New test. * gfortran.dg/pr119836_3.f90: New test. * gfortran.dg/pr119836_4.f90: New test. --- gcc/fortran/resolve.cc | 49 +++++++++++++++++++++++++++++++++++++++---------- 1 file changed, 39 insertions(+), 10 deletions(-) (limited to 'gcc/fortran/resolve.cc') diff --git a/gcc/fortran/resolve.cc b/gcc/fortran/resolve.cc index 2ecbd50..f03708e 100644 --- a/gcc/fortran/resolve.cc +++ b/gcc/fortran/resolve.cc @@ -3260,14 +3260,30 @@ static bool check_pure_function (gfc_expr *e) gfc_do_concurrent_flag = 0 when the check for an impure function occurs. Check the stack to see if the source code has a nested BLOCK construct. */ + for (stack = cs_base; stack; stack = stack->prev) { - if (stack->current->op == EXEC_BLOCK) saw_block = true; + if (!saw_block && stack->current->op == EXEC_BLOCK) + { + saw_block = true; + continue; + } + if (saw_block && stack->current->op == EXEC_DO_CONCURRENT) { - gfc_error ("Reference to impure function at %L inside a " - "DO CONCURRENT", &e->where); - return false; + bool is_pure; + is_pure = (e->value.function.isym + && (e->value.function.isym->pure + || e->value.function.isym->elemental)) + || (e->value.function.esym + && (e->value.function.esym->attr.pure + || e->value.function.esym->attr.elemental)); + if (!is_pure) + { + gfc_error ("Reference to impure function at %L inside a " + "DO CONCURRENT", &e->where); + return false; + } } } @@ -3663,16 +3679,29 @@ pure_subroutine (gfc_symbol *sym, const char *name, locus *loc) /* A BLOCK construct within a DO CONCURRENT construct leads to gfc_do_concurrent_flag = 0 when the check for an impure subroutine - occurs. Check the stack to see if the source code has a nested - BLOCK construct. */ + occurs. Walk up the stack to see if the source code has a nested + construct. */ + for (stack = cs_base; stack; stack = stack->prev) { - if (stack->current->op == EXEC_BLOCK) saw_block = true; + if (stack->current->op == EXEC_BLOCK) + { + saw_block = true; + continue; + } + if (saw_block && stack->current->op == EXEC_DO_CONCURRENT) { - gfc_error ("Subroutine call at %L in a DO CONCURRENT block " - "is not PURE", loc); - return false; + + bool is_pure = true; + is_pure = sym->attr.pure || sym->attr.elemental; + + if (!is_pure) + { + gfc_error ("Subroutine call at %L in a DO CONCURRENT block " + "is not PURE", loc); + return false; + } } } -- cgit v1.1