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;
}

35
gcc/fortran/gfortran.h
View File

@ -98,7 +98,7 @@ gfc_try;
/* These are flags for identifying whether we are reading a character literal
between quotes or normal source code. */
typedef enum
{ NONSTRING = 0, INSTRING_WARN, INSTRING_NOWARN }
gfc_instring;
@ -162,11 +162,11 @@ typedef enum
INTRINSIC_AND, INTRINSIC_OR, INTRINSIC_EQV, INTRINSIC_NEQV,
/* ==, /=, >, >=, <, <= */
INTRINSIC_EQ, INTRINSIC_NE, INTRINSIC_GT, INTRINSIC_GE,
INTRINSIC_LT, INTRINSIC_LE,
INTRINSIC_LT, INTRINSIC_LE,
/* .EQ., .NE., .GT., .GE., .LT., .LE. (OS = Old-Style) */
INTRINSIC_EQ_OS, INTRINSIC_NE_OS, INTRINSIC_GT_OS, INTRINSIC_GE_OS,
INTRINSIC_LT_OS, INTRINSIC_LE_OS,
INTRINSIC_NOT, INTRINSIC_USER, INTRINSIC_ASSIGN,
INTRINSIC_LT_OS, INTRINSIC_LE_OS,
INTRINSIC_NOT, INTRINSIC_USER, INTRINSIC_ASSIGN,
INTRINSIC_PARENTHESES, GFC_INTRINSIC_END /* Sentinel */
}
gfc_intrinsic_op;
@ -199,7 +199,7 @@ typedef enum
ST_INQUIRE, ST_INTERFACE, ST_SYNC_ALL, ST_SYNC_MEMORY, ST_SYNC_IMAGES,
ST_PARAMETER, ST_MODULE, ST_MODULE_PROC, ST_NAMELIST, ST_NULLIFY, ST_OPEN,
ST_PAUSE, ST_PRIVATE, ST_PROGRAM, ST_PUBLIC, ST_READ, ST_RETURN, ST_REWIND,
ST_STOP, ST_SUBROUTINE, ST_TYPE, ST_USE, ST_WHERE_BLOCK, ST_WHERE, ST_WAIT,
ST_STOP, ST_SUBROUTINE, ST_TYPE, ST_USE, ST_WHERE_BLOCK, ST_WHERE, ST_WAIT,
ST_WRITE, ST_ASSIGNMENT, ST_POINTER_ASSIGNMENT, ST_SELECT_CASE, ST_SEQUENCE,
ST_SIMPLE_IF, ST_STATEMENT_FUNCTION, ST_DERIVED_DECL, ST_LABEL_ASSIGNMENT,
ST_ENUM, ST_ENUMERATOR, ST_END_ENUM, ST_SELECT_TYPE, ST_TYPE_IS, ST_CLASS_IS,
@ -624,7 +624,7 @@ iso_fortran_env_symbol;
#define NAMED_FUNCTION(a,b,c,d) a,
typedef enum
{
ISOCBINDING_INVALID = -1,
ISOCBINDING_INVALID = -1,
#include "iso-c-binding.def"
ISOCBINDING_LAST,
ISOCBINDING_NUMBER = ISOCBINDING_LAST
@ -707,7 +707,7 @@ typedef struct
use_only:1, /* Symbol has been use-associated, with ONLY. */
use_rename:1, /* Symbol has been use-associated and renamed. */
imported:1, /* Symbol has been associated by IMPORT. */
host_assoc:1; /* Symbol has been host associated. */
host_assoc:1; /* Symbol has been host associated. */
unsigned in_namelist:1, in_common:1, in_equivalence:1;
unsigned function:1, subroutine:1, procedure:1;
@ -783,12 +783,14 @@ typedef struct
/* Special attributes for Cray pointers, pointees. */
unsigned cray_pointer:1, cray_pointee:1;
/* 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,
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;
@ -1240,7 +1242,7 @@ typedef struct gfc_symbol
struct gfc_namespace *ns; /* namespace containing this symbol */
tree backend_decl;
/* Identity of the intrinsic module the symbol comes from, or
INTMOD_NONE if it's not imported from a intrinsic module. */
intmod_id from_intmod;
@ -1655,7 +1657,7 @@ typedef struct gfc_intrinsic_sym
const char *name, *lib_name;
gfc_intrinsic_arg *formal;
gfc_typespec ts;
unsigned elemental:1, inquiry:1, transformational:1, pure:1,
unsigned elemental:1, inquiry:1, transformational:1, pure:1,
generic:1, specific:1, actual_ok:1, noreturn:1, conversion:1,
from_module:1;
@ -1722,14 +1724,14 @@ typedef struct gfc_expr
/* Sometimes, when an error has been emitted, it is necessary to prevent
it from recurring. */
unsigned int error : 1;
/* Mark an expression where a user operator has been substituted by
a function call in interface.c(gfc_extend_expr). */
unsigned int user_operator : 1;
/* Mark an expression as being a MOLD argument of ALLOCATE. */
unsigned int mold : 1;
/* If an expression comes from a Hollerith constant or compile-time
evaluation of a transfer statement, it may have a prescribed target-
memory representation, and these cannot always be backformed from
@ -2040,7 +2042,7 @@ gfc_forall_iterator;
typedef struct gfc_association_list
{
struct gfc_association_list *next;
struct gfc_association_list *next;
/* Whether this is association to a variable that can be changed; otherwise,
it's association to an expression and the name may not be used as
@ -2351,7 +2353,7 @@ typedef struct gfc_finalizer
still referenced or not for dereferencing it on deleting a gfc_finalizer
structure. */
gfc_symbol* proc_sym;
gfc_symtree* proc_tree;
gfc_symtree* proc_tree;
}
gfc_finalizer;
#define gfc_get_finalizer() XCNEW (gfc_finalizer)
@ -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);

688
gcc/fortran/resolve.c
View File

File diff suppressed because it is too large Load Diff

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