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.

git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@104029 138bc75d-0d04-0410-961f-82ee72b054a4

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index f52bac3..e2afd7c 100644 (file)
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,9 @@
+2005-09-07  Richard Sandiford  <richard@codesourcery.com>
+
+       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  <Thomas.Koenig@online.de>
 
        PR fortran/20848

diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index 69b2410..0d3cb69 100644 (file)
--- 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 95522e8..c68a2ae 100644 (file)
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,9 @@
+2005-09-07  Richard Sandiford  <richard@codesourcery.com>
+
+       PR fortran/23373
+       * gfortran.fortran-torture/execute/pr23373-1.f90,
+       * gfortran.fortran-torture/execute/pr23373-1.f90: New tests.
+
 2005-09-07  Jerry DeLisle  <jvdelisle@verizon.net>
 
        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 (file)
index 0000000..8d5ee65
--- /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 (file)
index 0000000..c91b270
--- /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