diff options
Diffstat (limited to 'gcc')
| -rw-r--r-- | gcc/fortran/ChangeLog | 8 | ||||
| -rw-r--r-- | gcc/fortran/expr.c | 7 | ||||
| -rw-r--r-- | gcc/fortran/interface.c | 34 | ||||
| -rw-r--r-- | gcc/testsuite/ChangeLog | 7 | ||||
| -rw-r--r-- | gcc/testsuite/gfortran.dg/pointer_assign_13.f90 | 47 |
5 files changed, 100 insertions, 3 deletions
diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 9d06c2e..2274ce0 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,11 @@ +2020-04-23 Thomas Koenig <tkoenig@gcc.gnu.org> + + PR fortran/93956 + * expr.c (gfc_check_pointer_assign): Also set subref_array_pointer + when a function returns a pointer. + * interface.c (gfc_set_subref_array_pointer_arg): New function. + (gfc_procedure_use): Call it. + 2020-04-22 Fritz Reese <foreese@gcc.gnu.org> * trigd_fe.inc: Use mpfr to compute cosd(30) rather than a host- diff --git a/gcc/fortran/expr.c b/gcc/fortran/expr.c index a9fa03a..618c98a 100644 --- a/gcc/fortran/expr.c +++ b/gcc/fortran/expr.c @@ -4242,8 +4242,11 @@ gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue, if (rvalue->expr_type == EXPR_NULL) return true; - if (rvalue->expr_type == EXPR_VARIABLE && is_subref_array (rvalue)) - lvalue->symtree->n.sym->attr.subref_array_pointer = 1; + /* A function may also return subref arrray pointer. */ + + if ((rvalue->expr_type == EXPR_VARIABLE && is_subref_array (rvalue)) + || rvalue->expr_type == EXPR_FUNCTION) + lvalue->symtree->n.sym->attr.subref_array_pointer = 1; attr = gfc_expr_attr (rvalue); diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c index ba1c8bc..58b7abf 100644 --- a/gcc/fortran/interface.c +++ b/gcc/fortran/interface.c @@ -3788,6 +3788,36 @@ check_intents (gfc_formal_arglist *f, gfc_actual_arglist *a) return true; } +/* Go through the argument list of a procedure and look for + pointers which may be set, possibly introducing a span. */ + +static void +gfc_set_subref_array_pointer_arg (gfc_formal_arglist *dummy_args, + gfc_actual_arglist *actual_args) +{ + gfc_formal_arglist *f; + gfc_actual_arglist *a; + gfc_symbol *a_sym; + for (f = dummy_args, a = actual_args; f && a ; f = f->next, a = a->next) + { + + if (f->sym == NULL) + continue; + + if (!f->sym->attr.pointer || f->sym->attr.intent == INTENT_IN) + continue; + + if (a->expr == NULL || a->expr->expr_type != EXPR_VARIABLE) + continue; + a_sym = a->expr->symtree->n.sym; + + if (!a_sym->attr.pointer) + continue; + + a_sym->attr.subref_array_pointer = 1; + } + return; +} /* Check how a procedure is used against its interface. If all goes well, the actual argument list will also end up being properly @@ -3968,6 +3998,10 @@ gfc_procedure_use (gfc_symbol *sym, gfc_actual_arglist **ap, locus *where) if (warn_aliasing) check_some_aliasing (dummy_args, *ap); + /* Set the subref_array_pointer_arg if needed. */ + if (dummy_args) + gfc_set_subref_array_pointer_arg (dummy_args, *ap); + return true; } diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index cb21f55..25515c9 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,4 +1,9 @@ -2020-04-23 Iain Sandoe <iain@sandoe.co.uk> +2020-04-23 Thomas Koenig <tkoenig@gcc.gnu.org> + + PR fortran/93956 + * gfortran.dg/pointer_assign_13.f90: New test. + + 2020-04-23 Iain Sandoe <iain@sandoe.co.uk> * g++.dg/coroutines/coro-bad-alloc-00-bad-op-new.C: Adjust for changed inline namespace. diff --git a/gcc/testsuite/gfortran.dg/pointer_assign_13.f90 b/gcc/testsuite/gfortran.dg/pointer_assign_13.f90 new file mode 100644 index 0000000..b3f2cd9 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pointer_assign_13.f90 @@ -0,0 +1,47 @@ +! { dg-do run } +! PR 93956 - span was set incorrectly, leading to wrong code. +! Original test case by "martin". +program array_temps + implicit none + + type :: tt + integer :: u = 1 + integer :: v = 2 + end type tt + + type(tt), dimension(:), pointer :: r + integer :: n + integer, dimension(:), pointer :: p, q, u + + n = 10 + allocate(r(1:n)) + call foo(r%v,n) + p => get(r(:)) + call foo(p, n) + call get2(r,u) + call foo(u,n) + q => r%v + call foo(q, n) + +deallocate(r) + +contains + + subroutine foo(a, n) + integer, dimension(:), intent(in) :: a + integer, intent(in) :: n + if (sum(a(1:n)) /= 2*n) stop 1 + end subroutine foo + + function get(x) result(q) + type(tt), dimension(:), target, intent(in) :: x + integer, dimension(:), pointer :: q + q => x(:)%v + end function get + + subroutine get2(x,q) + type(tt), dimension(:), target, intent(in) :: x + integer, dimension(:), pointer, intent(out) :: q + q => x(:)%v + end subroutine get2 +end program array_temps |