From 27eac9ee6137a6b5ae693b54cafa22bdc0cbcd5a Mon Sep 17 00:00:00 2001 From: Thomas Koenig Date: Wed, 5 Aug 2020 18:37:32 +0200 Subject: [PATCH] Static analysis for definition of DO index variables in contained procedures. When encountering a procedure call in a DO loop, this patch checks if the call is to a contained procedure, and if it is, check for changes in the index variable. gcc/fortran/ChangeLog: PR fortran/96469 * frontend-passes.c (doloop_contained_function_call): New function. (doloop_contained_procedure_code): New function. (CHECK_INQ): Macro for inquire checks. (doloop_code): Invoke doloop_contained_procedure_code and doloop_contained_function_call if appropriate. (do_intent): Likewise. gcc/testsuite/ChangeLog: PR fortran/96469 * gfortran.dg/do_check_4.f90: Hide change in index variable from compile-time analysis. * gfortran.dg/do_check_13.f90: New test. --- gcc/fortran/frontend-passes.c | 258 +++++++++++++++++++++- gcc/testsuite/gfortran.dg/do_check_13.f90 | 86 ++++++++ gcc/testsuite/gfortran.dg/do_check_4.f90 | 24 +- 3 files changed, 357 insertions(+), 11 deletions(-) create mode 100644 gcc/testsuite/gfortran.dg/do_check_13.f90 diff --git a/gcc/fortran/frontend-passes.c b/gcc/fortran/frontend-passes.c index cdeed8943b0..6bcb1f06b1c 100644 --- a/gcc/fortran/frontend-passes.c +++ b/gcc/fortran/frontend-passes.c @@ -2305,6 +2305,212 @@ optimize_minmaxloc (gfc_expr **e) mpz_set_ui (a->expr->value.integer, 1); } +/* Data package to hand down for DO loop checks in a contained + procedure. */ +typedef struct contained_info +{ + gfc_symbol *do_var; + gfc_symbol *procedure; + locus where_do; +} contained_info; + +static enum gfc_exec_op last_io_op; + +/* Callback function to check for INTENT(OUT) and INTENT(INOUT) in a + contained function call. */ + +static int +doloop_contained_function_call (gfc_expr **e, + int *walk_subtrees ATTRIBUTE_UNUSED, void *data) +{ + gfc_expr *expr = *e; + gfc_formal_arglist *f; + gfc_actual_arglist *a; + gfc_symbol *sym, *do_var; + contained_info *info; + + if (expr->expr_type != EXPR_FUNCTION || expr->value.function.isym) + return 0; + + sym = expr->value.function.esym; + f = gfc_sym_get_dummy_args (sym); + if (f == NULL) + return 0; + + info = (contained_info *) data; + do_var = info->do_var; + a = expr->value.function.actual; + + while (a && f) + { + if (a->expr && a->expr->symtree && a->expr->symtree->n.sym == do_var) + { + if (f->sym->attr.intent == INTENT_OUT) + { + gfc_error_now ("Index variable %qs set to undefined as " + "INTENT(OUT) argument at %L in procedure %qs " + "called from within DO loop at %L", do_var->name, + &a->expr->where, info->procedure->name, + &info->where_do); + return 1; + } + else if (f->sym->attr.intent == INTENT_INOUT) + { + gfc_error_now ("Index variable %qs not definable as " + "INTENT(INOUT) argument at %L in procedure %qs " + "called from within DO loop at %L", do_var->name, + &a->expr->where, info->procedure->name, + &info->where_do); + return 1; + } + } + a = a->next; + f = f->next; + } + return 0; +} + +/* Callback function that goes through the code in a contained + procedure to make sure it does not change a variable in a DO + loop. */ + +static int +doloop_contained_procedure_code (gfc_code **c, + int *walk_subtrees ATTRIBUTE_UNUSED, + void *data) +{ + gfc_code *co = *c; + contained_info *info = (contained_info *) data; + gfc_symbol *do_var = info->do_var; + const char *errmsg = _("Index variable %qs redefined at %L in procedure %qs " + "called from within DO loop at %L"); + static enum gfc_exec_op saved_io_op; + + switch (co->op) + { + case EXEC_ASSIGN: + if (co->expr1->symtree->n.sym == do_var) + gfc_error_now (errmsg, do_var->name, &co->loc, info->procedure->name, + &info->where_do); + break; + + case EXEC_DO: + if (co->ext.iterator && co->ext.iterator->var + && co->ext.iterator->var->symtree->n.sym == do_var) + gfc_error (errmsg, do_var->name, &co->loc, info->procedure->name, + &info->where_do); + break; + + case EXEC_READ: + case EXEC_WRITE: + case EXEC_INQUIRE: + saved_io_op = last_io_op; + last_io_op = co->op; + break; + + case EXEC_OPEN: + if (co->ext.open->iostat + && co->ext.open->iostat->symtree->n.sym == do_var) + gfc_error_now (errmsg, do_var->name, &co->ext.open->iostat->where, + info->procedure->name, &info->where_do); + break; + + case EXEC_CLOSE: + if (co->ext.close->iostat + && co->ext.close->iostat->symtree->n.sym == do_var) + gfc_error_now (errmsg, do_var->name, &co->ext.close->iostat->where, + info->procedure->name, &info->where_do); + break; + + case EXEC_TRANSFER: + switch (last_io_op) + { + + case EXEC_INQUIRE: +#define CHECK_INQ(a) do { if (co->ext.inquire->a && \ + co->ext.inquire->a->symtree->n.sym == do_var) \ + gfc_error_now (errmsg, do_var->name, \ + &co->ext.inquire->a->where, \ + info->procedure->name, \ + &info->where_do); \ + } while (0) + + CHECK_INQ(iostat); + CHECK_INQ(number); + CHECK_INQ(position); + CHECK_INQ(recl); + CHECK_INQ(position); + CHECK_INQ(iolength); + CHECK_INQ(strm_pos); + break; +#undef CHECK_INQ + + case EXEC_READ: + if (co->expr1 && co->expr1->symtree->n.sym == do_var) + gfc_error_now (errmsg, do_var->name, &co->expr1->where, + info->procedure->name, &info->where_do); + + /* Fallthrough. */ + + case EXEC_WRITE: + if (co->ext.dt->iostat + && co->ext.dt->iostat->symtree->n.sym == do_var) + gfc_error_now (errmsg, do_var->name, &co->ext.dt->iostat->where, + info->procedure->name, &info->where_do); + break; + + default: + gcc_unreachable (); + } + break; + + case EXEC_DT_END: + last_io_op = saved_io_op; + break; + + case EXEC_CALL: + gfc_formal_arglist *f; + gfc_actual_arglist *a; + + f = gfc_sym_get_dummy_args (co->resolved_sym); + if (f == NULL) + break; + a = co->ext.actual; + /* Slightly different error message here. If there is an error, + return 1 to avoid an infinite loop. */ + while (a && f) + { + if (a->expr && a->expr->symtree && a->expr->symtree->n.sym == do_var) + { + if (f->sym->attr.intent == INTENT_OUT) + { + gfc_error_now ("Index variable %qs set to undefined as " + "INTENT(OUT) argument at %L in subroutine %qs " + "called from within DO loop at %L", + do_var->name, &a->expr->where, + info->procedure->name, &info->where_do); + return 1; + } + else if (f->sym->attr.intent == INTENT_INOUT) + { + gfc_error_now ("Index variable %qs not definable as " + "INTENT(INOUT) argument at %L in subroutine %qs " + "called from within DO loop at %L", do_var->name, + &a->expr->where, info->procedure->name, + &info->where_do); + return 1; + } + } + a = a->next; + f = f->next; + } + break; + default: + break; + } + return 0; +} + /* Callback function for code checking that we do not pass a DO variable to an INTENT(OUT) or INTENT(INOUT) dummy variable. */ @@ -2389,10 +2595,32 @@ doloop_code (gfc_code **c, int *walk_subtrees ATTRIBUTE_UNUSED, break; case EXEC_CALL: - if (co->resolved_sym == NULL) break; + /* Test if somebody stealthily changes the DO variable from + under us by changing it in a host-associated procedure. */ + if (co->resolved_sym->attr.contained) + { + FOR_EACH_VEC_ELT (doloop_list, i, lp) + { + gfc_symbol *sym = co->resolved_sym; + contained_info info; + gfc_namespace *ns; + + cl = lp->c; + info.do_var = cl->ext.iterator->var->symtree->n.sym; + info.procedure = co->resolved_sym; /* sym? */ + info.where_do = co->loc; + /* Look contained procedures under the namespace of the + variable. */ + for (ns = info.do_var->ns->contained; ns; ns = ns->sibling) + if (ns->proc_name && ns->proc_name == sym) + gfc_code_walker (&ns->code, doloop_contained_procedure_code, + doloop_contained_function_call, &info); + } + } + f = gfc_sym_get_dummy_args (co->resolved_sym); /* Withot a formal arglist, there is only unknown INTENT, @@ -2436,6 +2664,7 @@ doloop_code (gfc_code **c, int *walk_subtrees ATTRIBUTE_UNUSED, a = a->next; f = f->next; } + break; default: @@ -2737,6 +2966,7 @@ do_intent (gfc_expr **e) gfc_code *dl; do_t *lp; int i; + gfc_symbol *sym; expr = *e; if (expr->expr_type != EXPR_FUNCTION) @@ -2747,7 +2977,31 @@ do_intent (gfc_expr **e) if (expr->value.function.isym) return 0; - f = gfc_sym_get_dummy_args (expr->symtree->n.sym); + sym = expr->value.function.esym; + if (sym == NULL) + return 0; + + if (sym->attr.contained) + { + FOR_EACH_VEC_ELT (doloop_list, i, lp) + { + contained_info info; + gfc_namespace *ns; + + dl = lp->c; + info.do_var = dl->ext.iterator->var->symtree->n.sym; + info.procedure = sym; + info.where_do = expr->where; + /* Look contained procedures under the namespace of the + variable. */ + for (ns = info.do_var->ns->contained; ns; ns = ns->sibling) + if (ns->proc_name && ns->proc_name == sym) + gfc_code_walker (&ns->code, doloop_contained_procedure_code, + dummy_expr_callback, &info); + } + } + + f = gfc_sym_get_dummy_args (sym); /* Without a formal arglist, there is only unknown INTENT, which we don't check for. */ diff --git a/gcc/testsuite/gfortran.dg/do_check_13.f90 b/gcc/testsuite/gfortran.dg/do_check_13.f90 new file mode 100644 index 00000000000..5ff7cdb4bb4 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/do_check_13.f90 @@ -0,0 +1,86 @@ +program main + implicit none + integer :: i1, i2, i3, i4, i5, i6, i7 + integer :: j + do i1=1,10 + call sub1 ! { dg-error "Index variable 'i1' redefined" } + end do + do i2=1,10 + call sub2 ! { dg-error "Index variable 'i2' redefined" } + end do + do i3=1,10 + j = fcn3() ! { dg-error "Index variable 'i3' redefined" } + end do + do i4=1,10 + j = fcn4() ! { dg-error "Index variable 'i4' redefined" } + end do + do i5=1,10 + call sub5 ! { dg-error "Index variable 'i5' set to undefined" } + end do + + call sub6 + + do i7=1,10 + call sub7 ! { dg-error "Index variable 'i7' not definable" } + end do +contains + subroutine sub1 + i1 = 5 ! { dg-error "Index variable 'i1' redefined" } + end subroutine sub1 + + subroutine sub2 + do i2=1,5 ! { dg-error "Index variable 'i2' redefined" } + end do + end subroutine sub2 + + integer function fcn3() + i3 = 1 ! { dg-error "Index variable 'i3' redefined" } + fcn3 = i3 + end function fcn3 + + integer function fcn4() + open (10,file="foo.dat", iostat=i4) ! { dg-error "Index variable 'i4' redefined" } + fcn4 = 12 + end function fcn4 + + subroutine sub5 + integer :: k + k = intentout(i5) ! { dg-error "Index variable 'i5' set to undefined" } + end subroutine sub5 + + subroutine sub6 + do i6=1,10 + call sub6a ! { dg-error "Index variable 'i6' redefined" } + end do + end subroutine sub6 + + subroutine sub6a + i6 = 5 ! { dg-error "Index variable 'i6' redefined" } + end subroutine sub6a + + subroutine sub7 + integer :: k + k = intentinout (i7) ! { dg-error "Index variable 'i7' not definable" } + end subroutine sub7 + + integer function intentout(i) + integer, intent(out) :: i + end function intentout + + integer function intentinout(i) + integer, intent(inout) :: i + end function intentinout +end program main + +module foo + integer :: j1 +contains + subroutine mod_sub_1 + do j1=1,10 + call aux ! { dg-error "Index variable 'j1' redefined" } + end do + end subroutine mod_sub_1 + subroutine aux + j1 = 3 ! { dg-error "Index variable 'j1' redefined" } + end subroutine aux +end module foo diff --git a/gcc/testsuite/gfortran.dg/do_check_4.f90 b/gcc/testsuite/gfortran.dg/do_check_4.f90 index 65bc92c7e1a..5b087e4dde3 100644 --- a/gcc/testsuite/gfortran.dg/do_check_4.f90 +++ b/gcc/testsuite/gfortran.dg/do_check_4.f90 @@ -5,17 +5,23 @@ ! PR fortran/34656 ! Run-time check for modifing loop variables ! + +module x + integer :: i +contains + SUBROUTINE do_something() + IMPLICIT NONE + DO i=1,10 + ENDDO + END SUBROUTINE do_something +end module x + PROGRAM test + use x IMPLICIT NONE - INTEGER :: i DO i=1,100 - CALL do_something() + CALL do_something() ENDDO -CONTAINS - SUBROUTINE do_something() - IMPLICIT NONE - DO i=1,10 - ENDDO - END SUBROUTINE do_something -END PROGRAM test +end PROGRAM test + ! { dg-output "Fortran runtime error: Loop variable has been modified" } -- 2.30.2