Skip to content

R
riscv-gcc-1
Commit 4d382327 by Alessandro Fanfarillo Committed by Paul Thomas
Options

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

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
parent 2eb342ee
Showing with 403 additions and 12 deletions
gcc/fortran/ChangeLog
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> 2012-11-28 Tobias Burnus <burnus@net-b.de>
PR fortran/52161 PR fortran/52161
......
gcc/fortran/expr.c
...@@ -3899,6 +3899,33 @@ gfc_get_variable_expr (gfc_symtree *var) ...@@ -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_expr *
gfc_lval_expr_from_sym (gfc_symbol *sym) gfc_lval_expr_from_sym (gfc_symbol *sym)
{ {
...@@ -3912,16 +3939,8 @@ 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. */ /* It will always be a full array. */
lval->rank = sym->as ? sym->as->rank : 0; lval->rank = sym->as ? sym->as->rank : 0;
if (lval->rank) if (lval->rank)
{ gfc_add_full_array_ref (lval, sym->ts.type == BT_CLASS ?
lval->ref = gfc_get_ref (); CLASS_DATA (sym)->as : sym->as);
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;
}
return lval; return lval;
} }
......
gcc/fortran/gfortran.h
...@@ -786,9 +786,11 @@ typedef struct ...@@ -786,9 +786,11 @@ typedef struct
/* The symbol is a derived type with allocatable components, pointer /* The symbol is a derived type with allocatable components, pointer
components or private components, procedure pointer components, components or private components, procedure pointer components,
possibly nested. zero_comp is true if the derived type has no 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, 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. */ /* This is a temporary selector for SELECT TYPE. */
unsigned select_type_temporary:1; unsigned select_type_temporary:1;
...@@ -2761,6 +2763,7 @@ gfc_try gfc_check_assign_symbol (gfc_symbol *, gfc_expr *); ...@@ -2761,6 +2763,7 @@ gfc_try gfc_check_assign_symbol (gfc_symbol *, gfc_expr *);
bool gfc_has_default_initializer (gfc_symbol *); bool gfc_has_default_initializer (gfc_symbol *);
gfc_expr *gfc_default_initializer (gfc_typespec *); gfc_expr *gfc_default_initializer (gfc_typespec *);
gfc_expr *gfc_get_variable_expr (gfc_symtree *); 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_expr * gfc_lval_expr_from_sym (gfc_symbol *);
gfc_array_spec *gfc_get_full_arrayspec_from_expr (gfc_expr *expr); gfc_array_spec *gfc_get_full_arrayspec_from_expr (gfc_expr *expr);
......
gcc/testsuite/ChangeLog
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> 2012-12-01 Jakub Jelinek <jakub@redhat.com>
PR c++/55542 PR c++/55542
......
gcc/testsuite/gfortran.dg/defined_assignment_1.f90 0 → 100644
! { 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
gcc/testsuite/gfortran.dg/defined_assignment_2.f90 0 → 100644
! { 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
gcc/testsuite/gfortran.dg/defined_assignment_3.f90 0 → 100644
! { 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
gcc/testsuite/gfortran.dg/defined_assignment_4.f90 0 → 100644
! { 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
gcc/testsuite/gfortran.dg/defined_assignment_5.f90 0 → 100644
! { 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
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment