[Patch, Fortran, OOP] PR 57843: Type-bound assignment is resolved to non-polymorphic procedure call

[Patch, Fortran, OOP] PR 57843: Type-bound assignment is resolved to non-polymorphic procedure call

[Janus Weil]

[-- Attachment #1: Type: text/plain, Size: 747 bytes --]

Hi all,

here is a wrong-code fix for type-bound assignments, which makes sure
that these are resolved to polymorphic procedure calls. This was not
always the case, because we used the wrong ordering when checking for
defined-assignment procedures (looking for non-typebound ones first,
and for typebound ones only afterwards). See in particular comment 3 -
5 in the PR.

The patch was regtested on x86_64-unknown-linux-gnu. Ok for trunk?

Cheers,
Janus


2013-08-22  Janus Weil  <janus@gcc.gnu.org>

    PR fortran/57843
    * interface.c (gfc_extend_assign): Look for type-bound assignment
    procedure before non-typebound.


2013-08-22  Janus Weil  <janus@gcc.gnu.org>

    PR fortran/57843
    * gfortran.dg/typebound_assignment_7.f90: New.

[-- Attachment #2: pr57843.diff --]
[-- Type: application/octet-stream, Size: 3366 bytes --]

Index: gcc/fortran/interface.c
===================================================================
--- gcc/fortran/interface.c	(revision 201871)
+++ gcc/fortran/interface.c	(working copy)
@@ -3754,21 +3754,19 @@
 }
 
 
-/* Tries to replace an assignment code node with a subroutine call to
-   the subroutine associated with the assignment operator.  Return
-   true if the node was replaced.  On false, no error is
-   generated.  */
+/* Tries to replace an assignment code node with a subroutine call to the
+   subroutine associated with the assignment operator. Return true if the node
+   was replaced. On false, no error is generated.  */
 
 bool
 gfc_extend_assign (gfc_code *c, gfc_namespace *ns)
 {
   gfc_actual_arglist *actual;
-  gfc_expr *lhs, *rhs;
-  gfc_symbol *sym;
-  const char *gname;
+  gfc_expr *lhs, *rhs, *tb_base;
+  gfc_symbol *sym = NULL;
+  const char *gname = NULL;
+  gfc_typebound_proc* tbo;
 
-  gname = NULL;
-
   lhs = c->expr1;
   rhs = c->expr2;
 
@@ -3785,8 +3783,26 @@
   actual->next = gfc_get_actual_arglist ();
   actual->next->expr = rhs;
 
-  sym = NULL;
+  /* TODO: Ambiguity-check, see above for gfc_extend_expr.  */
 
+  /* See if we find a matching type-bound assignment.  */
+  tbo = matching_typebound_op (&tb_base, actual, INTRINSIC_ASSIGN,
+			       NULL, &gname);
+
+  if (tbo)
+    {
+      /* Success: Replace the expression with a type-bound call.  */
+      gcc_assert (tb_base);
+      c->expr1 = gfc_get_expr ();
+      build_compcall_for_operator (c->expr1, actual, tb_base, tbo, gname);
+      c->expr1->value.compcall.assign = 1;
+      c->expr1->where = c->loc;
+      c->expr2 = NULL;
+      c->op = EXEC_COMPCALL;
+      return true;
+    }
+
+  /* See if we find an 'ordinary' (non-typebound) assignment procedure.  */
   for (; ns; ns = ns->parent)
     {
       sym = gfc_search_interface (ns->op[INTRINSIC_ASSIGN], 1, &actual);
@@ -3794,47 +3810,21 @@
 	break;
     }
 
-  /* TODO: Ambiguity-check, see above for gfc_extend_expr.  */
-
-  if (sym == NULL)
+  if (sym)
     {
-      gfc_typebound_proc* tbo;
-      gfc_expr* tb_base;
-
-      /* See if we find a matching type-bound assignment.  */
-      tbo = matching_typebound_op (&tb_base, actual,
-				   INTRINSIC_ASSIGN, NULL, &gname);
-
-      /* If there is one, replace the expression with a call to it and
-	 succeed.  */
-      if (tbo)
-	{
-	  gcc_assert (tb_base);
-	  c->expr1 = gfc_get_expr ();
-	  build_compcall_for_operator (c->expr1, actual, tb_base, tbo, gname);
-	  c->expr1->value.compcall.assign = 1;
-	  c->expr1->where = c->loc;
-	  c->expr2 = NULL;
-	  c->op = EXEC_COMPCALL;
-
-	  /* c is resolved from the caller, so no need to do it here.  */
-
-	  return true;
-	}
-
-      free (actual->next);
-      free (actual);
-      return false;
+      /* Success: Replace the assignment with the call.  */
+      c->op = EXEC_ASSIGN_CALL;
+      c->symtree = gfc_find_sym_in_symtree (sym);
+      c->expr1 = NULL;
+      c->expr2 = NULL;
+      c->ext.actual = actual;
+      return true;
     }
 
-  /* Replace the assignment with the call.  */
-  c->op = EXEC_ASSIGN_CALL;
-  c->symtree = gfc_find_sym_in_symtree (sym);
-  c->expr1 = NULL;
-  c->expr2 = NULL;
-  c->ext.actual = actual;
-
-  return true;
+  /* Failure: No assignment procedure found.  */
+  free (actual->next);
+  free (actual);
+  return false;
 }
 
 

[-- Attachment #3: typebound_assignment_7.f90 --]
[-- Type: application/octet-stream, Size: 1348 bytes --]

! { dg-do run }
!
! PR 57843: [OOP] Type-bound assignment is resolved to non-polymorphic procedure call
!
! Contributed by John <jwmwalrus@gmail.com>

module mod1
  implicit none
  type :: itemType
  contains
    procedure :: the_assignment => assign_itemType
    generic :: assignment(=) => the_assignment
  end type
contains
  subroutine assign_itemType(left, right)
    class(itemType), intent(OUT) :: left
    class(itemType), intent(IN) :: right
  end subroutine
end module

module mod2
  use mod1
  implicit none
  type, extends(itemType) :: myItem
    character(3) :: name = ''
  contains
    procedure :: the_assignment => assign_myItem
  end type
contains
  subroutine assign_myItem(left, right)
    class(myItem), intent(OUT) :: left
    class(itemType), intent(IN) :: right
    select type (right)
    type is (myItem)
      left%name = right%name
    end select
  end subroutine
end module


program test_assign

  use mod2
  implicit none

  class(itemType), allocatable :: item1, item2

  allocate (myItem :: item1)
  select type (item1)
    type is (myItem)
      item1%name = 'abc'
  end select

  allocate (myItem :: item2)
  item2 = item1

  select type (item2)
    type is (myItem)
      if (item2%name /= 'abc') call abort()
    class default
      call abort()
  end select

end

! { dg-final { cleanup-modules "mod1 mod2" } }

Re: [Patch, Fortran, OOP] PR 57843: Type-bound assignment is resolved to non-polymorphic procedure call

[Mikael Morin]

Le 22/08/2013 17:41, Janus Weil a écrit :
> Hi all,
> 
> here is a wrong-code fix for type-bound assignments, which makes sure
> that these are resolved to polymorphic procedure calls. This was not
> always the case, because we used the wrong ordering when checking for
> defined-assignment procedures (looking for non-typebound ones first,
> and for typebound ones only afterwards). See in particular comment 3 -
> 5 in the PR.
> 
> The patch was regtested on x86_64-unknown-linux-gnu. Ok for trunk?
> 
OK.  Thanks.

Mikael

Re: [Patch, Fortran, OOP] PR 57843: Type-bound assignment is resolved to non-polymorphic procedure call

[Janus Weil]

2013/8/22 Mikael Morin <mikael.morin@sfr.fr>:
> Le 22/08/2013 17:41, Janus Weil a écrit :
>> Hi all,
>>
>> here is a wrong-code fix for type-bound assignments, which makes sure
>> that these are resolved to polymorphic procedure calls. This was not
>> always the case, because we used the wrong ordering when checking for
>> defined-assignment procedures (looking for non-typebound ones first,
>> and for typebound ones only afterwards). See in particular comment 3 -
>> 5 in the PR.
>>
>> The patch was regtested on x86_64-unknown-linux-gnu. Ok for trunk?
>>
> OK.  Thanks.

Thanks, committed as r201946.

Cheers,
Janus