This is the mail archive of the gcc-patches@gcc.gnu.org mailing list for the GCC project.


Index Nav: [Date Index] [Subject Index] [Author Index] [Thread Index]
Message Nav: [Date Prev] [Date Next] [Thread Prev] [Thread Next]
Other format: [Raw text]

Fwd: Re: [Patch, Fortran] PR57697 - Fix an issue with defined assignment [fwd: burnus at net-b dot de]


Yet another try to send this email - this time from a different
server. For completeness:
* The original email didn't made it, nor a repost. But the mail
  server didn't bounce back.
* For another email, only the reply made it - but not the original
  email: http://gcc.gnu.org/ml/fortran/2013-09/msg00025.html
Locally, it works as I BCC'ed myself to the emails. 
--- Begin Message ---

--- Begin Message --- Re-sent as it didn't show up in the archive. (I wonder why this and another email didn't made it, but the follow-up to that email did.)

Tobias Burnus wrote:
Hi Thomas, hello all,

As it turned out, my patch wasn't working for the real-world code. I created a follow-up patch. See below.

* * *

Thomas Koenig wrote:
the patch is OK, also for 4.8.  Thanks a lot for fixing this.

Thanks for the review!

Just a couple of nits:
- You may want to remove the output from the test case.

Done. (Well, I missed one print line.)

- The two consecutive ifs in

       if (left != 0B)
         {
           if (_F.DA0 != 0B) goto L.2;
           _F.DA0 = (struct parent *) __builtin_malloc (4);
           L.2:;
           *_F.DA0 = *left;
         }
       L.1:;
       if (left != 0B) goto L.4;
are a little bit inelegant.  It is not really important, because
they will be merged on optimization, but if you find an easy
way to do this in the FE code, you might want to consider doing
so.  I would advise against spending a lot of work on this, though :-)

That's a bit difficult - part of the "if"s are generated at resolution time (resolve.c, like my patch) others are generated in trans-expr.c for realloc on assignment. I don't see a simple way to avoid the two conditions, unfortunately.

Committed to the trunk as Rev. 202601. (By the way, the automatic addition of the committal to the PR now works again :-)

* * *

As testing showed, it didn't fix the real-world code: ForTrilinos's ForTrilinos_ADT_3D_Burgers_6th_Pade did still fail as it has:

         *_F.DA65 = matrix_diff_x (&parm.621);
       _F.DA66 = ax->epetra_rowmatrix.universal; // Deref of "ax"!

The reason for the failure is that ax == NULL but only "ax" is allocatable while universal isn't. That's now fixed by the attached patch. With that patch, ForTrilions's ForTrilinos_ADT_3D_Burgers_6th_Pade and ForTrilinos_concrete_burgers_solver now pass (instead of segfault). Additionally, I changed ISYM_ASSOCIATED to ISYM_ALLOCATED which matches the internal name and is a bit more consistent. As either one boils down to a null-pointer check, it shouldn't lead to any code-gen difference on tree level.

Build and regtested on x86-64-gnu-linux.
OK?

Tobias
2013-09-15  Tobias Burnus  <burnus@net-b.de>

	PR fortran/57697
	* resolve.c (generate_component_assignments): Correctly handle the
	case that the LHS is not allocated.

2013-09-15  Tobias Burnus  <burnus@net-b.de>

	PR fortran/57697
	* gfortran.dg/defined_assignment_10.f90: Comment print statement.

diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index f2892e2..fbd9a6a 100644
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -9547,17 +9547,20 @@ generate_component_assignments (gfc_code **code, gfc_namespace *ns)
 						t1, (*code)->expr1,
 				NULL, NULL, (*code)->loc);
 
-		  /* For allocatable LHS, check whether it is allocated.  */
-		  if (gfc_expr_attr((*code)->expr1).allocatable)
+		  /* For allocatable LHS, check whether it is allocated.  Note
+		     that allocatable components with defined assignment are
+		     not yet support.  See PR 57696.  */
+		  if ((*code)->expr1->symtree->n.sym->attr.allocatable)
 		    {
 		      gfc_code *block;
+		      gfc_expr *e =
+			gfc_lval_expr_from_sym ((*code)->expr1->symtree->n.sym);
 		      block = gfc_get_code (EXEC_IF);
 		      block->block = gfc_get_code (EXEC_IF);
 		      block->block->expr1
 			  = gfc_build_intrinsic_call (ns,
-				    GFC_ISYM_ASSOCIATED, "allocated",
-				    (*code)->loc, 2,
-				    gfc_copy_expr ((*code)->expr1), NULL);
+				    GFC_ISYM_ALLOCATED, "allocated",
+				    (*code)->loc, 1, e);
 		      block->block->next = temp_code;
 		      temp_code = block;
 		    }
@@ -9570,9 +9573,11 @@ generate_component_assignments (gfc_code **code, gfc_namespace *ns)
 	      this_code->ext.actual->expr = gfc_copy_expr (t1);
 	      add_comp_ref (this_code->ext.actual->expr, comp1);
 
-	      /* If the LHS is not allocated, we pointer-assign the LHS address
-		 to the temporary - after the LHS has been allocated.  */
-	      if (gfc_expr_attr((*code)->expr1).allocatable)
+	      /* If the LHS variable is allocatable and wasn't allocated and
+                 the temporary is allocatable, pointer assign the address of
+                 the freshly allocated LHS to the temporary.  */
+	      if ((*code)->expr1->symtree->n.sym->attr.allocatable
+		  && gfc_expr_attr ((*code)->expr1).allocatable)
 		{
 		  gfc_code *block;
                   gfc_expr *cond;
@@ -9583,9 +9588,8 @@ generate_component_assignments (gfc_code **code, gfc_namespace *ns)
 		  cond->where = (*code)->loc;
 		  cond->value.op.op = INTRINSIC_NOT;
 		  cond->value.op.op1 = gfc_build_intrinsic_call (ns,
-					  GFC_ISYM_ASSOCIATED, "allocated",
-					  (*code)->loc, 2,
-					  gfc_copy_expr (t1), NULL);
+					  GFC_ISYM_ALLOCATED, "allocated",
+					  (*code)->loc, 1, gfc_copy_expr (t1));
 		  block = gfc_get_code (EXEC_IF);
 		  block->block = gfc_get_code (EXEC_IF);
 		  block->block->expr1 = cond;
diff --git a/gcc/testsuite/gfortran.dg/defined_assignment_10.f90 b/gcc/testsuite/gfortran.dg/defined_assignment_10.f90
index 03f92c6..4385925 100644
--- a/gcc/testsuite/gfortran.dg/defined_assignment_10.f90
+++ b/gcc/testsuite/gfortran.dg/defined_assignment_10.f90
@@ -28,7 +28,7 @@ program main
   implicit none
   type(parent), allocatable :: left
   type(parent) :: right
-  print *, right%foo
+!  print *, right%foo
   left = right
 !  print *, left%foo
   if (left%foo%i /= 20) call abort()

--- End Message ---

--- End Message ---

Index Nav: [Date Index] [Subject Index] [Author Index] [Thread Index]
Message Nav: [Date Prev] [Date Next] [Thread Prev] [Thread Next]