From 8aeca7fda07b3e505cab58c650ba46f352dc6f73 Mon Sep 17 00:00:00 2001 From: Richard Sandiford Date: Thu, 8 Sep 2005 09:20:07 +0000 Subject: [PATCH] re PR fortran/23373 ([4.0 only] Functions returning pointers with pointer argument) PR fortran/23373 * trans-expr.c (gfc_trans_pointer_assignment): Assign to a temporary descriptor if the rhs is not a null pointer or variable. From-SVN: r104029 --- gcc/fortran/ChangeLog | 6 ++++ gcc/fortran/trans-expr.c | 31 +++++++++++++++---- gcc/testsuite/ChangeLog | 6 ++++ .../execute/pr23373-1.f90 | 15 +++++++++ .../execute/pr23373-2.f90 | 15 +++++++++ 5 files changed, 67 insertions(+), 6 deletions(-) create mode 100644 gcc/testsuite/gfortran.fortran-torture/execute/pr23373-1.f90 create mode 100644 gcc/testsuite/gfortran.fortran-torture/execute/pr23373-2.f90 diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index f52bac38c55..e2afd7c55f0 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,9 @@ +2005-09-07 Richard Sandiford + + PR fortran/23373 + * trans-expr.c (gfc_trans_pointer_assignment): Assign to a temporary + descriptor if the rhs is not a null pointer or variable. + 2005-09-07 Thomas Koenig PR fortran/20848 diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index 69b24109443..0d3cb69bf9e 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -2041,6 +2041,8 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2) gfc_ss *lss; gfc_ss *rss; stmtblock_t block; + tree desc; + tree tmp; gfc_start_block (&block); @@ -2068,13 +2070,30 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2) { /* Array pointer. */ gfc_conv_expr_descriptor (&lse, expr1, lss); - /* Implement Nullify. */ - if (expr2->expr_type == EXPR_NULL) - gfc_conv_descriptor_data_set (&block, lse.expr, null_pointer_node); - else - { + switch (expr2->expr_type) + { + case EXPR_NULL: + /* Just set the data pointer to null. */ + gfc_conv_descriptor_data_set (&block, lse.expr, null_pointer_node); + break; + + case EXPR_VARIABLE: + /* Assign directly to the pointer's descriptor. */ lse.direct_byref = 1; - gfc_conv_expr_descriptor (&lse, expr2, rss); + gfc_conv_expr_descriptor (&lse, expr2, rss); + break; + + default: + /* Assign to a temporary descriptor and then copy that + temporary to the pointer. */ + desc = lse.expr; + tmp = gfc_create_var (TREE_TYPE (desc), "ptrtemp"); + + lse.expr = tmp; + lse.direct_byref = 1; + gfc_conv_expr_descriptor (&lse, expr2, rss); + gfc_add_modify_expr (&lse.pre, desc, tmp); + break; } gfc_add_block_to_block (&block, &lse.pre); gfc_add_block_to_block (&block, &lse.post); diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 95522e8cf80..c68a2aebd71 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,9 @@ +2005-09-07 Richard Sandiford + + PR fortran/23373 + * gfortran.fortran-torture/execute/pr23373-1.f90, + * gfortran.fortran-torture/execute/pr23373-1.f90: New tests. + 2005-09-07 Jerry DeLisle PR libfortran/23760 diff --git a/gcc/testsuite/gfortran.fortran-torture/execute/pr23373-1.f90 b/gcc/testsuite/gfortran.fortran-torture/execute/pr23373-1.f90 new file mode 100644 index 00000000000..8d5ee658df5 --- /dev/null +++ b/gcc/testsuite/gfortran.fortran-torture/execute/pr23373-1.f90 @@ -0,0 +1,15 @@ +program main + implicit none + real, dimension (:), pointer :: x + x => null () + x => test (x) + if (.not. associated (x)) call abort + if (size (x) .ne. 10) call abort +contains + function test (p) + real, dimension (:), pointer :: p, test + if (associated (p)) call abort + allocate (test (10)) + if (associated (p)) call abort + end function test +end program main diff --git a/gcc/testsuite/gfortran.fortran-torture/execute/pr23373-2.f90 b/gcc/testsuite/gfortran.fortran-torture/execute/pr23373-2.f90 new file mode 100644 index 00000000000..c91b270321e --- /dev/null +++ b/gcc/testsuite/gfortran.fortran-torture/execute/pr23373-2.f90 @@ -0,0 +1,15 @@ +program main + implicit none + real, dimension (:), pointer :: x + x => null () + x => test () + if (.not. associated (x)) call abort + if (size (x) .ne. 10) call abort +contains + function test + real, dimension (:), pointer :: test + if (associated (x)) call abort + allocate (test (10)) + if (associated (x)) call abort + end function test +end program main -- 2.30.2