}
-/* 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;
-
- gname = NULL;
+ gfc_expr *lhs, *rhs, *tb_base;
+ gfc_symbol *sym = NULL;
+ const char *gname = NULL;
+ gfc_typebound_proc* tbo;
lhs = c->expr1;
rhs = c->expr2;
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);
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;
}
--- /dev/null
+! { 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" } }
projects / gcc.git / commitdiff