diff mbox

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

Message ID 20130915181524.GA15828@physik.fu-berlin.de
State New
Headers show

Commit Message

Tobias Burnus Sept. 15, 2013, 6:15 p.m. UTC 
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.

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
diff mbox

Patch

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()