OpenE2K
/
gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

re PR fortran/46897 ([OOP] type-bound defined ASSIGNMENT(=) not used for derived type component in intrinsic assign) 

2012-12-01   Alessandro Fanfarillo <alessandro.fanfarillo@gmail.com>
             Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/46897
	* gfortran.h : Add bit field 'defined_assign_comp' to
	symbol_attribute structure.
	Add primitive for gfc_add_full_array_ref.
	* expr.c (gfc_add_full_array_ref): New function.
	(gfc_lval_expr_from_sym): Call new function.
	* resolve.c (add_comp_ref): New function.
	(build_assignment): New function.
	(get_temp_from_expr): New function
	(add_code_to_chain): New function
	(generate_component_assignments): New function that calls all
	the above new functions.
	(resolve_code): Call generate_component_assignments.
	(check_defined_assignments): New function.
	(resolve_fl_derived0): Call check_defined_assignments.
	(gfc_resolve): Reset component_assignment_level in case it is
	left in a bad state by errors.


	* resolve.c (is_sym_host_assoc, resolve_procedure_interface,
	resolve_contained_fntype, resolve_procedure_expression,
	resolve_elemental_actual, resolve_global_procedure,
	is_scalar_expr_ptr, gfc_iso_c_func_interface, resolve_function,
	set_name_and_label, gfc_iso_c_sub_interface,
	resolve_specific_s0, resolve_operator, compare_bound_mpz_t,
	gfc_resolve_character_operator, resolve_typebound_function,
	gfc_resolve_expr, forall_index, remove_last_array_ref,
	conformable_arrays, resolve_allocate_expr,
	resolve_allocate_deallocate, resolve_select_type,
	resolve_transfer, resolve_where,
	gfc_resolve_where_code_in_forall, gfc_resolve_forall_body,
	gfc_count_forall_iterators, resolve_values,
	resolve_bind_c_comms, resolve_bind_c_derived_types,
	gfc_verify_binding_labels, apply_default_init,
	build_default_init_expr, apply_default_init_local,
	resolve_fl_var_and_proc, resolve_fl_procedure,
	gfc_resolve_finalizers, check_generic_tbp_ambiguity,
	resolve_typebound_intrinsic_op, resolve_typebound_procedure,
	resolve_typebound_procedures, ensure_not_abstract,
	resolve_fl_derived0, resolve_fl_parameter, resolve_symbol,
	resolve_equivalence_derived): Remove trailing white space.
	* gfortran.h : Remove trailing white space.

2012-12-01   Alessandro Fanfarillo <alessandro.fanfarillo@gmail.com>
             Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/46897
	* gfortran.dg/defined_assignment_1.f90: New test.
	* gfortran.dg/defined_assignment_2.f90: New test.
	* gfortran.dg/defined_assignment_3.f90: New test.
	* gfortran.dg/defined_assignment_4.f90: New test.
	* gfortran.dg/defined_assignment_5.f90: New test.


Co-Authored-By: Paul Thomas <pault@gcc.gnu.org>

From-SVN: r194016
This commit is contained in:
Alessandro Fanfarillo 2012-12-01 08:00:22 +00:00 committed by Paul Thomas
parent 2eb342ee03
commit 4d382327d5
10 changed files with 983 additions and 148 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

46
gcc/fortran/ChangeLog
View File

@ -1,3 +1,49 @@
2012-12-01 Alessandro Fanfarillo <alessandro.fanfarillo@gmail.com>
Paul Thomas <pault@gcc.gnu.org>
PR fortran/46897
* gfortran.h : Add bit field 'defined_assign_comp' to
symbol_attribute structure.
Add primitive for gfc_add_full_array_ref.
* expr.c (gfc_add_full_array_ref): New function.
(gfc_lval_expr_from_sym): Call new function.
* resolve.c (add_comp_ref): New function.
(build_assignment): New function.
(get_temp_from_expr): New function
(add_code_to_chain): New function
(generate_component_assignments): New function that calls all
the above new functions.
(resolve_code): Call generate_component_assignments.
(check_defined_assignments): New function.
(resolve_fl_derived0): Call check_defined_assignments.
(gfc_resolve): Reset component_assignment_level in case it is
left in a bad state by errors.
* resolve.c (is_sym_host_assoc, resolve_procedure_interface,
resolve_contained_fntype, resolve_procedure_expression,
resolve_elemental_actual, resolve_global_procedure,
is_scalar_expr_ptr, gfc_iso_c_func_interface, resolve_function,
set_name_and_label, gfc_iso_c_sub_interface,
resolve_specific_s0, resolve_operator, compare_bound_mpz_t,
gfc_resolve_character_operator, resolve_typebound_function,
gfc_resolve_expr, forall_index, remove_last_array_ref,
conformable_arrays, resolve_allocate_expr,
resolve_allocate_deallocate, resolve_select_type,
resolve_transfer, resolve_where,
gfc_resolve_where_code_in_forall, gfc_resolve_forall_body,
gfc_count_forall_iterators, resolve_values,
resolve_bind_c_comms, resolve_bind_c_derived_types,
gfc_verify_binding_labels, apply_default_init,
build_default_init_expr, apply_default_init_local,
resolve_fl_var_and_proc, resolve_fl_procedure,
gfc_resolve_finalizers, check_generic_tbp_ambiguity,
resolve_typebound_intrinsic_op, resolve_typebound_procedure,
resolve_typebound_procedures, ensure_not_abstract,
resolve_fl_derived0, resolve_fl_parameter, resolve_symbol,
resolve_equivalence_derived): Remove trailing white space.
* gfortran.h : Remove trailing white space.
2012-11-28 Tobias Burnus <burnus@net-b.de>
PR fortran/52161

39
gcc/fortran/expr.c
View File

@ -3899,6 +3899,33 @@ gfc_get_variable_expr (gfc_symtree *var)
}
/* Adds a full array reference to an expression, as needed. */
void
gfc_add_full_array_ref (gfc_expr *e, gfc_array_spec *as)
{
gfc_ref *ref;
for (ref = e->ref; ref; ref = ref->next)
if (!ref->next)
break;
if (ref)
{
ref->next = gfc_get_ref ();
ref = ref->next;
}
else
{
e->ref = gfc_get_ref ();
ref = e->ref;
}
ref->type = REF_ARRAY;
ref->u.ar.type = AR_FULL;
ref->u.ar.dimen = e->rank;
ref->u.ar.where = e->where;
ref->u.ar.as = as;
}
gfc_expr *
gfc_lval_expr_from_sym (gfc_symbol *sym)
{
@ -3912,16 +3939,8 @@ gfc_lval_expr_from_sym (gfc_symbol *sym)
/* It will always be a full array. */
lval->rank = sym->as ? sym->as->rank : 0;
if (lval->rank)
{
lval->ref = gfc_get_ref ();
lval->ref->type = REF_ARRAY;
lval->ref->u.ar.type = AR_FULL;
lval->ref->u.ar.dimen = lval->rank;
lval->ref->u.ar.where = sym->declared_at;
lval->ref->u.ar.as = sym->ts.type == BT_CLASS
? CLASS_DATA (sym)->as : sym->as;
}
gfc_add_full_array_ref (lval, sym->ts.type == BT_CLASS ?
CLASS_DATA (sym)->as : sym->as);
return lval;
}

7
gcc/fortran/gfortran.h
View File

@ -786,9 +786,11 @@ typedef struct
/* The symbol is a derived type with allocatable components, pointer
components or private components, procedure pointer components,
possibly nested. zero_comp is true if the derived type has no
component at all. */
component at all. defined_assign_comp is true if the derived
type or a (sub-)component has a typebound defined assignment. */
unsigned alloc_comp:1, pointer_comp:1, proc_pointer_comp:1,
private_comp:1, zero_comp:1, coarray_comp:1, lock_comp:1;
private_comp:1, zero_comp:1, coarray_comp:1, lock_comp:1,
defined_assign_comp:1;
/* This is a temporary selector for SELECT TYPE. */
unsigned select_type_temporary:1;
@ -2761,6 +2763,7 @@ gfc_try gfc_check_assign_symbol (gfc_symbol *, gfc_expr *);
bool gfc_has_default_initializer (gfc_symbol *);
gfc_expr *gfc_default_initializer (gfc_typespec *);
gfc_expr *gfc_get_variable_expr (gfc_symtree *);
void gfc_add_full_array_ref (gfc_expr *, gfc_array_spec *);
gfc_expr * gfc_lval_expr_from_sym (gfc_symbol *);
gfc_array_spec *gfc_get_full_arrayspec_from_expr (gfc_expr *expr);

470
gcc/fortran/resolve.c
View File

@ -7622,18 +7622,12 @@ resolve_allocate_deallocate (gfc_code *code, const char *fcn)
if (pr->next && qr->next)
{
int i;
gfc_array_ref *par = &(pr->u.ar);
gfc_array_ref *qar = &(qr->u.ar);
for (i=0; i<par->dimen; i++)
{
if ((par->start[i] != NULL
|| qar->start[i] != NULL)
&& gfc_dep_compare_expr (par->start[i],
qar->start[i]) != 0)
goto break_label;
}
if ((par->start[0] != NULL || qar->start[0] != NULL)
&& gfc_dep_compare_expr (par->start[0],
qar->start[0]) != 0)
break;
}
}
else
@ -7645,8 +7639,6 @@ resolve_allocate_deallocate (gfc_code *code, const char *fcn)
pr = pr->next;
qr = qr->next;
}
break_label:
;
}
}
}
@ -9561,6 +9553,408 @@ resolve_ordinary_assign (gfc_code *code, gfc_namespace *ns)
}
/* Add a component reference onto an expression. */
static void
add_comp_ref (gfc_expr *e, gfc_component *c)
{
gfc_ref **ref;
ref = &(e->ref);
while (*ref)
ref = &((*ref)->next);
*ref = gfc_get_ref ();
(*ref)->type = REF_COMPONENT;
(*ref)->u.c.sym = e->ts.u.derived;
(*ref)->u.c.component = c;
e->ts = c->ts;
/* Add a full array ref, as necessary. */
if (c->as)
{
gfc_add_full_array_ref (e, c->as);
e->rank = c->as->rank;
}
}
/* Build an assignment. Keep the argument 'op' for future use, so that
pointer assignments can be made. */
static gfc_code *
build_assignment (gfc_exec_op op, gfc_expr *expr1, gfc_expr *expr2,
gfc_component *comp1, gfc_component *comp2, locus loc)
{
gfc_code *this_code;
this_code = gfc_get_code ();
this_code->op = op;
this_code->next = NULL;
this_code->expr1 = gfc_copy_expr (expr1);
this_code->expr2 = gfc_copy_expr (expr2);
this_code->loc = loc;
if (comp1 && comp2)
{
add_comp_ref (this_code->expr1, comp1);
add_comp_ref (this_code->expr2, comp2);
}
return this_code;
}
/* Makes a temporary variable expression based on the characteristics of
a given variable expression. */
static gfc_expr*
get_temp_from_expr (gfc_expr *e, gfc_namespace *ns)
{
static int serial = 0;
char name[GFC_MAX_SYMBOL_LEN];
gfc_symtree *tmp;
gfc_array_spec *as;
gfc_array_ref *aref;
gfc_ref *ref;
sprintf (name, "DA@%d", serial++);
gfc_get_sym_tree (name, ns, &tmp, false);
gfc_add_type (tmp->n.sym, &e->ts, NULL);
as = NULL;
ref = NULL;
aref = NULL;
/* This function could be expanded to support other expression type
but this is not needed here. */
gcc_assert (e->expr_type == EXPR_VARIABLE);
/* Obtain the arrayspec for the temporary. */
if (e->rank)
{
aref = gfc_find_array_ref (e);
if (e->expr_type == EXPR_VARIABLE
&& e->symtree->n.sym->as == aref->as)
as = aref->as;
else
{
for (ref = e->ref; ref; ref = ref->next)
if (ref->type == REF_COMPONENT
&& ref->u.c.component->as == aref->as)
{
as = aref->as;
break;
}
}
}
/* Add the attributes and the arrayspec to the temporary. */
tmp->n.sym->attr = gfc_expr_attr (e);
if (as)
{
tmp->n.sym->as = gfc_copy_array_spec (as);
if (!ref)
ref = e->ref;
if (as->type == AS_DEFERRED)
tmp->n.sym->attr.allocatable = 1;
}
else
tmp->n.sym->attr.dimension = 0;
gfc_set_sym_referenced (tmp->n.sym);
gfc_add_flavor (&tmp->n.sym->attr, FL_VARIABLE, name, NULL);
e = gfc_lval_expr_from_sym (tmp->n.sym);
/* Should the lhs be a section, use its array ref for the
temporary expression. */
if (aref && aref->type != AR_FULL)
{
gfc_free_ref_list (e->ref);
e->ref = gfc_copy_ref (ref);
}
return e;
}
/* Add one line of code to the code chain, making sure that 'head' and
'tail' are appropriately updated. */
static void
add_code_to_chain (gfc_code **this_code, gfc_code **head, gfc_code **tail)
{
gcc_assert (this_code);
if (*head == NULL)
*head = *tail = *this_code;
else
*tail = gfc_append_code (*tail, *this_code);
*this_code = NULL;
}
/* Counts the potential number of part array references that would
result from resolution of typebound defined assignments. */
static int
nonscalar_typebound_assign (gfc_symbol *derived, int depth)
{
gfc_component *c;
int c_depth = 0, t_depth;
for (c= derived->components; c; c = c->next)
{
if ((c->ts.type != BT_DERIVED
|| c->attr.pointer
|| c->attr.allocatable
|| c->attr.proc_pointer_comp
|| c->attr.class_pointer
|| c->attr.proc_pointer)
&& !c->attr.defined_assign_comp)
continue;
if (c->as && c_depth == 0)
c_depth = 1;
if (c->ts.u.derived->attr.defined_assign_comp)
t_depth = nonscalar_typebound_assign (c->ts.u.derived,
c->as ? 1 : 0);
else
t_depth = 0;
c_depth = t_depth > c_depth ? t_depth : c_depth;
}
return depth + c_depth;
}
/* Implement 7.2.1.3 of the F08 standard:
"An intrinsic assignment where the variable is of derived type is
performed as if each component of the variable were assigned from the
corresponding component of expr using pointer assignment (7.2.2) for
each pointer component, defined assignment for each nonpointer
nonallocatable component of a type that has a type-bound defined
assignment consistent with the component, intrinsic assignment for
each other nonpointer nonallocatable component, ..."
The pointer assignments are taken care of by the intrinsic
assignment of the structure itself. This function recursively adds
defined assignments where required. The recursion is accomplished
by calling resolve_code.
When the lhs in a defined assignment has intent INOUT, we need a
temporary for the lhs. In pseudo-code:
! Only call function lhs once.
if (lhs is not a constant or an variable)
temp_x = expr2
expr2 => temp_x
! Do the intrinsic assignment
expr1 = expr2
! Now do the defined assignments
do over components with typebound defined assignment [%cmp]
#if one component's assignment procedure is INOUT
t1 = expr1
#if expr2 non-variable
temp_x = expr2
expr2 => temp_x
# endif
expr1 = expr2
# for each cmp
t1%cmp {defined=} expr2%cmp
expr1%cmp = t1%cmp
#else
expr1 = expr2
# for each cmp
expr1%cmp {defined=} expr2%cmp
#endif
*/
/* The temporary assignments have to be put on top of the additional
code to avoid the result being changed by the intrinsic assignment.
*/
static int component_assignment_level = 0;
static gfc_code *tmp_head = NULL, *tmp_tail = NULL;
static void
generate_component_assignments (gfc_code **code, gfc_namespace *ns)
{
gfc_component *comp1, *comp2;
gfc_code *this_code = NULL, *head = NULL, *tail = NULL;
gfc_expr *t1;
int error_count, depth;
gfc_get_errors (NULL, &error_count);
/* Filter out continuing processing after an error. */
if (error_count
|| (*code)->expr1->ts.type != BT_DERIVED
|| (*code)->expr2->ts.type != BT_DERIVED)
return;
/* TODO: Handle more than one part array reference in assignments. */
depth = nonscalar_typebound_assign ((*code)->expr1->ts.u.derived,
(*code)->expr1->rank ? 1 : 0);
if (depth > 1)
{
gfc_warning ("TODO: type-bound defined assignment(s) at %L not "
"done because multiple part array references would "
"occur in intermediate expressions.", &(*code)->loc);
return;
}
component_assignment_level++;
/* Create a temporary so that functions get called only once. */
if ((*code)->expr2->expr_type != EXPR_VARIABLE
&& (*code)->expr2->expr_type != EXPR_CONSTANT)
{
gfc_expr *tmp_expr;
/* Assign the rhs to the temporary. */
tmp_expr = get_temp_from_expr ((*code)->expr1, ns);
this_code = build_assignment (EXEC_ASSIGN,
tmp_expr, (*code)->expr2,
NULL, NULL, (*code)->loc);
/* Add the code and substitute the rhs expression. */
add_code_to_chain (&this_code, &tmp_head, &tmp_tail);
gfc_free_expr ((*code)->expr2);
(*code)->expr2 = tmp_expr;
}
/* Do the intrinsic assignment. This is not needed if the lhs is one
of the temporaries generated here, since the intrinsic assignment
to the final result already does this. */
if ((*code)->expr1->symtree->n.sym->name[2] != '@')
{
this_code = build_assignment (EXEC_ASSIGN,
(*code)->expr1, (*code)->expr2,
NULL, NULL, (*code)->loc);
add_code_to_chain (&this_code, &head, &tail);
}
comp1 = (*code)->expr1->ts.u.derived->components;
comp2 = (*code)->expr2->ts.u.derived->components;
t1 = NULL;
for (; comp1; comp1 = comp1->next, comp2 = comp2->next)
{
bool inout = false;
/* The intrinsic assignment does the right thing for pointers
of all kinds and allocatable components. */
if (comp1->ts.type != BT_DERIVED
|| comp1->attr.pointer
|| comp1->attr.allocatable
|| comp1->attr.proc_pointer_comp
|| comp1->attr.class_pointer
|| comp1->attr.proc_pointer)
continue;
/* Make an assigment for this component. */
this_code = gfc_get_code ();
this_code = build_assignment (EXEC_ASSIGN,
(*code)->expr1, (*code)->expr2,
comp1, comp2, (*code)->loc);
/* Convert the assignment if there is a defined assignment for
this type. Otherwise, using the call from resolve_code,
recurse into its components. */
resolve_code (this_code, ns);
if (this_code->op == EXEC_ASSIGN_CALL)
{
gfc_symbol *rsym;
/* Check that there is a typebound defined assignment. If not,
then this must be a module defined assignment. We cannot
use the defined_assign_comp attribute here because it must
be this derived type that has the defined assignment and not
a parent type. */
if (!(comp1->ts.u.derived->f2k_derived
&& comp1->ts.u.derived->f2k_derived
->tb_op[INTRINSIC_ASSIGN]))
{
gfc_free_statements (this_code);
this_code = NULL;
continue;
}
/* If the first argument of the subroutine has intent INOUT
a temporary must be generated and used instead. */
rsym = this_code->resolved_sym;
if (rsym->formal
&& rsym->formal->sym->attr.intent == INTENT_INOUT)
{
gfc_code *temp_code;
inout = true;
/* Build the temporary required for the assignment and put
it at the head of the generated code. */
if (!t1)
{
t1 = get_temp_from_expr ((*code)->expr1, ns);
temp_code = build_assignment (EXEC_ASSIGN,
t1, (*code)->expr1,
NULL, NULL, (*code)->loc);
add_code_to_chain (&temp_code, &tmp_head, &tmp_tail);
}
/* Replace the first actual arg with the component of the
temporary. */
gfc_free_expr (this_code->ext.actual->expr);
this_code->ext.actual->expr = gfc_copy_expr (t1);
add_comp_ref (this_code->ext.actual->expr, comp1);
}
}
else if (this_code->op == EXEC_ASSIGN && !this_code->next)
{
/* Don't add intrinsic assignments since they are already
effected by the intrinsic assignment of the structure. */
gfc_free_statements (this_code);
this_code = NULL;
continue;
}
add_code_to_chain (&this_code, &head, &tail);
if (t1 && inout)
{
/* Transfer the value to the final result. */
this_code = build_assignment (EXEC_ASSIGN,
(*code)->expr1, t1,
comp1, comp2, (*code)->loc);
add_code_to_chain (&this_code, &head, &tail);
}
}
/* This is probably not necessary. */
if (this_code)
{
gfc_free_statements (this_code);
this_code = NULL;
}
/* Put the temporary assignments at the top of the generated code. */
if (tmp_head && component_assignment_level == 1)
{
gfc_append_code (tmp_head, head);
head = tmp_head;
tmp_head = tmp_tail = NULL;
}
/* Now attach the remaining code chain to the input code. Step on
to the end of the new code since resolution is complete. */
gcc_assert ((*code)->op == EXEC_ASSIGN);
tail->next = (*code)->next;
/* Overwrite 'code' because this would place the intrinsic assignment
before the temporary for the lhs is created. */
gfc_free_expr ((*code)->expr1);
gfc_free_expr ((*code)->expr2);
**code = *head;
free (head);
*code = tail;
component_assignment_level--;
}
/* Given a block of code, recursively resolve everything pointed to by this
code block. */
@ -9723,6 +10117,12 @@ resolve_code (gfc_code *code, gfc_namespace *ns)
else
goto call;
}
/* F03 7.4.1.3 for non-allocatable, non-pointer components. */
if (code->expr1->ts.type == BT_DERIVED
&& code->expr1->ts.u.derived->attr.defined_assign_comp)
generate_component_assignments (&code, ns);
break;
case EXEC_LABEL_ASSIGN:
@ -11548,7 +11948,7 @@ resolve_typebound_intrinsic_op (gfc_symbol* derived, gfc_intrinsic_op op,
/* Add target to non-typebound operator list. */
if (!target->specific->deferred && !derived->attr.use_assoc
&& p->access != ACCESS_PRIVATE && derived->ns == gfc_current_ns)
&& p->access != ACCESS_PRIVATE)
{
gfc_interface *head, *intr;
if (gfc_check_new_interface (derived->ns->op[op], target_proc,
@ -11956,6 +12356,43 @@ ensure_not_abstract (gfc_symbol* sub, gfc_symbol* ancestor)
}
/* This check for typebound defined assignments is done recursively
since the order in which derived types are resolved is not always in
order of the declarations. */
static void
check_defined_assignments (gfc_symbol *derived)
{
gfc_component *c;
for (c = derived->components; c; c = c->next)
{
if (c->ts.type != BT_DERIVED
|| c->attr.pointer
|| c->attr.allocatable
|| c->attr.proc_pointer_comp
|| c->attr.class_pointer
|| c->attr.proc_pointer)
continue;
if (c->ts.u.derived->attr.defined_assign_comp
|| (c->ts.u.derived->f2k_derived
&& c->ts.u.derived->f2k_derived->tb_op[INTRINSIC_ASSIGN]))
{
derived->attr.defined_assign_comp = 1;
return;
}
check_defined_assignments (c->ts.u.derived);
if (c->ts.u.derived->attr.defined_assign_comp)
{
derived->attr.defined_assign_comp = 1;
return;
}
}
}
/* Resolve the components of a derived type. This does not have to wait until
resolution stage, but can be done as soon as the dt declaration has been
parsed. */
@ -12353,6 +12790,12 @@ resolve_fl_derived0 (gfc_symbol *sym)
return FAILURE;
}
check_defined_assignments (sym);
if (!sym->attr.defined_assign_comp && super_type)
sym->attr.defined_assign_comp
= super_type->attr.defined_assign_comp;
/* If this is a non-ABSTRACT type extending an ABSTRACT one, ensure that
all DEFERRED bindings are overridden. */
if (super_type && super_type->attr.abstract && !sym->attr.abstract
@ -14410,6 +14853,7 @@ gfc_resolve (gfc_namespace *ns)
old_cs_base = cs_base;
resolve_types (ns);
component_assignment_level = 0;
resolve_codes (ns);
gfc_current_ns = old_ns;

10
gcc/testsuite/ChangeLog
View File

@ -1,3 +1,13 @@
2012-12-01 Alessandro Fanfarillo <alessandro.fanfarillo@gmail.com>
Paul Thomas <pault@gcc.gnu.org>
PR fortran/46897
* gfortran.dg/defined_assignment_1.f90: New test.
* gfortran.dg/defined_assignment_2.f90: New test.
* gfortran.dg/defined_assignment_3.f90: New test.
* gfortran.dg/defined_assignment_4.f90: New test.
* gfortran.dg/defined_assignment_5.f90: New test.
2012-12-01 Jakub Jelinek <jakub@redhat.com>
PR c++/55542

90
gcc/testsuite/gfortran.dg/defined_assignment_1.f90 Normal file
View File

@ -0,0 +1,90 @@
! { dg-do run }
! Test the fix for PR46897.
!
! Contributed by Rouson Damian <rouson@sandia.gov>
!
module m0
implicit none
type component
integer :: i = 0
contains
procedure :: assign0
generic :: assignment(=)=>assign0
end type
type parent
type(component) :: foo
end type
type, extends(parent) :: child
integer :: j
end type
contains
subroutine assign0(lhs,rhs)
class(component), intent(out) :: lhs
class(component), intent(in) :: rhs
lhs%i = 20
end subroutine
type(child) function new_child()
end function
end module
module m1
implicit none
type component1
integer :: i = 1
contains
procedure :: assign1
generic :: assignment(=)=>assign1
end type
type t
type(component1) :: foo
end type
contains
subroutine assign1(lhs,rhs)
class(component1), intent(out) :: lhs
class(component1), intent(in) :: rhs
lhs%i = 21
end subroutine
end module
module m2
implicit none
type component2
integer :: i = 2
end type
interface assignment(=)
module procedure assign2
end interface
type t2
type(component2) :: foo
end type
contains
subroutine assign2(lhs,rhs)
type(component2), intent(out) :: lhs
type(component2), intent(in) :: rhs
lhs%i = 22
end subroutine
end module
program main
use m0
use m1
use m2
implicit none
type(child) :: infant0
type(t) :: infant1, newchild1
type(t2) :: infant2, newchild2
! Test the reported problem.
infant0 = new_child()
if (infant0%parent%foo%i .ne. 20) call abort
! Test the case of comment #1 of the PR.
infant1 = newchild1
if (infant1%foo%i .ne. 21) call abort
! Test the case of comment #2 of the PR.
infant2 = newchild2
if (infant2%foo%i .ne. 2) call abort
end

74
gcc/testsuite/gfortran.dg/defined_assignment_2.f90 Normal file
View File

@ -0,0 +1,74 @@
! { dg-do run }
! Test the fix for PR46897. defined_assignment_1.f90 checks that the PR
! testcases run correctly, this checks that other requirements of the
! standard are satisfied.
!
module m0
implicit none
type component
integer :: i = 0
integer, allocatable :: j(:)
contains
procedure :: assign0
generic :: assignment(=)=>assign0
end type
type parent
type(component) :: foo1
end type
type, extends(parent) :: child
integer :: k = 1000
integer, allocatable :: l(:)
type(component) :: foo2
end type
contains
subroutine assign0(lhs,rhs)
class(component), intent(inout) :: lhs
class(component), intent(in) :: rhs
if (lhs%i .eq. 0) then
lhs%i = rhs%i
lhs%j = rhs%j
else
lhs%i = rhs%i*2
lhs%j = [rhs%j, rhs%j*2]
end if
end subroutine
type(child) function new_child()
new_child%parent%foo1%i = 20
new_child%foo2%i = 21
new_child%parent%foo1%j = [99,199]
new_child%foo2%j = [199,299]
new_child%l = [299,399]
new_child%k = 1001
end function
end module
program main
use m0
implicit none
type(child) :: infant0
! Check that the INTENT(INOUT) of assign0 is respected and that the
! correct thing is done with allocatable components.
infant0 = new_child()
if (infant0%parent%foo1%i .ne. 20) call abort
if (infant0%foo2%i .ne. 21) call abort
if (any (infant0%parent%foo1%j .ne. [99,199])) call abort
if (any (infant0%foo2%j .ne. [199,299])) call abort
if (infant0%foo2%i .ne. 21) call abort
if (any (infant0%l .ne. [299,399])) call abort
! Now, since the defined assignment depends on whether or not the 'i'
! component is the default initialization value, the result will be
! different.
infant0 = new_child()
if (infant0%parent%foo1%i .ne. 40) call abort
if (any (infant0%parent%foo1%j .ne. [99,199,198,398])) call abort
if (any (infant0%foo2%j .ne. [199,299,398,598])) call abort
if (infant0%foo2%i .ne. 42) call abort
if (any (infant0%l .ne. [299,399])) call abort
! Finally, make sure that normal components of the declared type survive.
if (infant0%k .ne. 1001) call abort
end

38
gcc/testsuite/gfortran.dg/defined_assignment_3.f90 Normal file
View File

@ -0,0 +1,38 @@
! { dg-do run }
! Test the fix for PR46897. defined_assignment_1.f90 checks that the PR
! testcases run correctly, this checks array components are OK.
!
module m0
implicit none
type component
integer :: i = 0
contains
procedure :: assign0
generic :: assignment(=)=>assign0
end type
type parent
type(component) :: foo(2)
end type
type, extends(parent) :: child
integer :: j
end type
contains
elemental subroutine assign0(lhs,rhs)
class(component), intent(out) :: lhs
class(component), intent(in) :: rhs
lhs%i = 20
end subroutine
end module
program main
use m0
implicit none
type(child) :: infant0, infant1(2)
infant0 = child([component(1),component(2)], 99)
if (any (infant0%parent%foo%i .ne. [20, 20])) call abort
end

35
gcc/testsuite/gfortran.dg/defined_assignment_4.f90 Normal file
View File

@ -0,0 +1,35 @@
! { dg-do run }
! Test the fix for PR46897. First patch did not run this case correctly.
! Contributed by Tobias Burnus <burnus@gcc.gnu.org>
!
module a_mod
type :: a
integer :: i = 99
contains
procedure :: a_ass
generic :: assignment(=) => a_ass
end type a
type c
type(a) :: ta
end type c
type :: b
type(c) :: tc
end type b
contains
elemental subroutine a_ass(out, in)
class(a), intent(INout) :: out
type(a), intent(in) :: in
out%i = 2*in%i
end subroutine a_ass
end module a_mod
program assign
use a_mod
type(b) :: tt
type(b) :: tb1
tt = tb1
if (tt%tc%ta%i .ne. 198) call abort
end program assign

76
gcc/testsuite/gfortran.dg/defined_assignment_5.f90 Normal file
View File

@ -0,0 +1,76 @@
! { dg-do run }
! Further test of typebound defined assignment
!
module m0
implicit none
type component
integer :: i = 0
contains
procedure :: assign0
generic :: assignment(=)=>assign0
end type
type parent
type(component) :: foo(2)
end type
type, extends(parent) :: child
integer :: j
end type
contains
elemental subroutine assign0(lhs,rhs)
class(component), intent(INout) :: lhs
class(component), intent(in) :: rhs
lhs%i = 20
end subroutine
end module
module m1
implicit none
type component1
integer :: i = 0
contains
procedure :: assign1
generic :: assignment(=)=>assign1
end type
type parent1
type(component1) :: foo
end type
type, extends(parent1) :: child1
integer :: j = 7
end type
contains
elemental subroutine assign1(lhs,rhs)
class(component1), intent(out) :: lhs
class(component1), intent(in) :: rhs
lhs%i = 30
end subroutine
end module
program main
use m0
use m1
implicit none
type(child) :: infant(2)
type(parent) :: dad, mum
type(child1) :: orphan(5)
type(child1), allocatable :: annie(:)
integer :: i, j, k
dad = parent ([component (3), component (4)])
mum = parent ([component (5), component (6)])
infant = [child(dad, 999), child(mum, 9999)] ! { dg-warning "multiple part array references" }
! Check that array sections are OK
i = 3
j = 4
orphan(i:j) = child1(component1(777), 1)
if (any (orphan%parent1%foo%i .ne. [0,0,30,30,0])) call abort
if (any (orphan%j .ne. [7,7,1,1,7])) call abort
! Check that allocatable lhs's work OK.
annie = [(child1(component1(k), 2*k), k = 1,3)]
if (any (annie%parent1%foo%i .ne. [30,30,30])) call abort
if (any (annie%j .ne. [2,4,6])) call abort
end