Skip to content

R
riscv-gcc-1
Commit 574284e9 by Andre Vehreschild
Options

re PR fortran/43366 ([OOP][F08] Intrinsic assign to polymorphic variable) 

gcc/fortran/ChangeLog:

2016-10-22  Andre Vehreschild  <vehre@gcc.gnu.org>

	PR fortran/43366
	PR fortran/51864
	PR fortran/57117
	PR fortran/61337
	PR fortran/61376
	* primary.c (gfc_expr_attr): For transformational functions on classes
	get the attrs from the class argument.
	* resolve.c (resolve_ordinary_assign): Remove error message due to
	feature implementation.  Rewrite POINTER_ASSIGNS to ordinary ones when
	the right-hand side is scalar class object (with some restrictions).
	* trans-array.c (trans_array_constructor): Create the temporary from
	class' inner type, i.e., the derived type.
	(build_class_array_ref): Add support for class array's storage of the
	class object or the array descriptor in the decl saved descriptor.
	(gfc_conv_expr_descriptor): When creating temporaries for class objects
	add the class object's handle into the decl saved descriptor.
	(structure_alloc_comps): Use the common way to get the _data component.
	(gfc_is_reallocatable_lhs): Add notion of allocatable class objects.
	* trans-expr.c (gfc_find_and_cut_at_last_class_ref): Remove the only ref
	only when the expression's type is BT_CLASS.
	(gfc_trans_class_init_assign): Correctly handle class arrays.
	(gfc_trans_class_assign): Joined into gfc_trans_assignment_1.
	(gfc_conv_procedure_call): Support for class types as arguments.
	(trans_get_upoly_len): For unlimited polymorphics retrieve the _len
	component's tree.
	(trans_class_vptr_len_assignment): Catch all ways to assign the _vptr
	and _len components of a class object correctly.
	(pointer_assignment_is_proc_pointer): Identify assignments of
	procedure pointers.
	(gfc_trans_pointer_assignment): Enhance support for class object pointer
	assignments.
	(gfc_trans_scalar_assign): Removed assert.
	(trans_class_assignment): Assign to a class object.
	(gfc_trans_assignment_1): Treat class objects correctly.
	(gfc_trans_assignment): Propagate flags to trans_assignment_1.
	* trans-stmt.c (gfc_trans_allocate): Use gfc_trans_assignment now
	instead of copy_class_to_class.
	* trans-stmt.h: Function prototype removed.
	* trans.c (trans_code): Less special casing for class objects.
	* trans.h: Added flags to gfc_trans_assignment () prototype.

gcc/testsuite/ChangeLog:

2016-10-22  Andre Vehreschild  <vehre@gcc.gnu.org>

        Forgot to add on original commit.
        * gfortran.dg/coarray_alloc_comp_2.f08: New test.

2016-10-22  Andre Vehreschild  <vehre@gcc.gnu.org>

	PR fortran/43366
	PR fortran/57117
	PR fortran/61337
	* gfortran.dg/alloc_comp_class_5.f03: New test.
	* gfortran.dg/class_allocate_21.f90: New test.
	* gfortran.dg/class_allocate_22.f90: New test.
	* gfortran.dg/realloc_on_assign_27.f08: New test.

From-SVN: r241439
parent 4e04812d
Showing with 394 additions and 54 deletions
gcc/fortran/ChangeLog
2016-10-22 Andre Vehreschild <vehre@gcc.gnu.org>
PR fortran/43366
PR fortran/51864
PR fortran/57117
PR fortran/61337
PR fortran/61376
* primary.c (gfc_expr_attr): For transformational functions on classes
get the attrs from the class argument.
* resolve.c (resolve_ordinary_assign): Remove error message due to
feature implementation. Rewrite POINTER_ASSIGNS to ordinary ones when
the right-hand side is scalar class object (with some restrictions).
* trans-array.c (trans_array_constructor): Create the temporary from
class' inner type, i.e., the derived type.
(build_class_array_ref): Add support for class array's storage of the
class object or the array descriptor in the decl saved descriptor.
(gfc_conv_expr_descriptor): When creating temporaries for class objects
add the class object's handle into the decl saved descriptor.
(structure_alloc_comps): Use the common way to get the _data component.
(gfc_is_reallocatable_lhs): Add notion of allocatable class objects.
* trans-expr.c (gfc_find_and_cut_at_last_class_ref): Remove the only ref
only when the expression's type is BT_CLASS.
(gfc_trans_class_init_assign): Correctly handle class arrays.
(gfc_trans_class_assign): Joined into gfc_trans_assignment_1.
(gfc_conv_procedure_call): Support for class types as arguments.
(trans_get_upoly_len): For unlimited polymorphics retrieve the _len
component's tree.
(trans_class_vptr_len_assignment): Catch all ways to assign the _vptr
and _len components of a class object correctly.
(pointer_assignment_is_proc_pointer): Identify assignments of
procedure pointers.
(gfc_trans_pointer_assignment): Enhance support for class object pointer
assignments.
(gfc_trans_scalar_assign): Removed assert.
(trans_class_assignment): Assign to a class object.
(gfc_trans_assignment_1): Treat class objects correctly.
(gfc_trans_assignment): Propagate flags to trans_assignment_1.
* trans-stmt.c (gfc_trans_allocate): Use gfc_trans_assignment now
instead of copy_class_to_class.
* trans-stmt.h: Function prototype removed.
* trans.c (trans_code): Less special casing for class objects.
* trans.h: Added flags to gfc_trans_assignment () prototype.
2016-10-21 Paul Thomas <pault@gcc.gnu.org> 2016-10-21 Paul Thomas <pault@gcc.gnu.org>
PR fortran/69566 PR fortran/69566
......
gcc/fortran/primary.c
...@@ -2359,6 +2359,10 @@ gfc_expr_attr (gfc_expr *e) ...@@ -2359,6 +2359,10 @@ gfc_expr_attr (gfc_expr *e)
attr.allocatable = CLASS_DATA (sym)->attr.allocatable; attr.allocatable = CLASS_DATA (sym)->attr.allocatable;
} }
} }
else if (e->value.function.isym
&& e->value.function.isym->transformational
&& e->ts.type == BT_CLASS)
attr = CLASS_DATA (e)->attr;
else else
attr = gfc_variable_attr (e, NULL); attr = gfc_variable_attr (e, NULL);
......
gcc/fortran/resolve.c
...@@ -9911,10 +9911,6 @@ resolve_ordinary_assign (gfc_code *code, gfc_namespace *ns) ...@@ -9911,10 +9911,6 @@ resolve_ordinary_assign (gfc_code *code, gfc_namespace *ns)
"requires %<-frealloc-lhs%>", &lhs->where); "requires %<-frealloc-lhs%>", &lhs->where);
return false; return false;
} }
/* See PR 43366. */
gfc_error ("Assignment to an allocatable polymorphic variable at %L "
"is not yet supported", &lhs->where);
return false;
} }
else if (lhs->ts.type == BT_CLASS) else if (lhs->ts.type == BT_CLASS)
{ {
...@@ -10817,6 +10813,19 @@ start: ...@@ -10817,6 +10813,19 @@ start:
break; break;
gfc_check_pointer_assign (code->expr1, code->expr2); gfc_check_pointer_assign (code->expr1, code->expr2);
/* Assigning a class object always is a regular assign. */
if (code->expr2->ts.type == BT_CLASS
&& !CLASS_DATA (code->expr2)->attr.dimension
&& !(UNLIMITED_POLY (code->expr2)
&& code->expr1->ts.type == BT_DERIVED
&& (code->expr1->ts.u.derived->attr.sequence
|| code->expr1->ts.u.derived->attr.is_bind_c))
&& !(gfc_expr_attr (code->expr1).proc_pointer
&& code->expr2->expr_type == EXPR_VARIABLE
&& code->expr2->symtree->n.sym->attr.flavor
== FL_PROCEDURE))
code->op = EXEC_ASSIGN;
break; break;
} }
......
gcc/fortran/trans-array.c
...@@ -2292,7 +2292,8 @@ trans_array_constructor (gfc_ss * ss, locus * where) ...@@ -2292,7 +2292,8 @@ trans_array_constructor (gfc_ss * ss, locus * where)
type = build_pointer_type (type); type = build_pointer_type (type);
} }
else else
type = gfc_typenode_for_spec (&expr->ts); type = gfc_typenode_for_spec (expr->ts.type == BT_CLASS
? &CLASS_DATA (expr)->ts : &expr->ts);
/* See if the constructor determines the loop bounds. */ /* See if the constructor determines the loop bounds. */
dynamic = false; dynamic = false;
...@@ -3036,50 +3037,57 @@ build_class_array_ref (gfc_se *se, tree base, tree index) ...@@ -3036,50 +3037,57 @@ build_class_array_ref (gfc_se *se, tree base, tree index)
tree type; tree type;
tree size; tree size;
tree offset; tree offset;
tree decl; tree decl = NULL_TREE;
tree tmp; tree tmp;
gfc_expr *expr = se->ss->info->expr; gfc_expr *expr = se->ss->info->expr;
gfc_ref *ref; gfc_ref *ref;
gfc_ref *class_ref; gfc_ref *class_ref = NULL;
gfc_typespec *ts; gfc_typespec *ts;
if (expr == NULL if (se->expr && DECL_P (se->expr) && DECL_LANG_SPECIFIC (se->expr)
|| (expr->ts.type != BT_CLASS && GFC_DECL_SAVED_DESCRIPTOR (se->expr)
&& !gfc_is_alloc_class_array_function (expr))) && GFC_CLASS_TYPE_P (TREE_TYPE (GFC_DECL_SAVED_DESCRIPTOR (se->expr))))
return false; decl = se->expr;
if (expr->symtree && expr->symtree->n.sym->ts.type == BT_CLASS)
ts = &expr->symtree->n.sym->ts;
else else
ts = NULL;
class_ref = NULL;
for (ref = expr->ref; ref; ref = ref->next)
{ {
if (ref->type == REF_COMPONENT if (expr == NULL
&& ref->u.c.component->ts.type == BT_CLASS || (expr->ts.type != BT_CLASS
&& ref->next && ref->next->type == REF_COMPONENT && !gfc_is_alloc_class_array_function (expr)
&& strcmp (ref->next->u.c.component->name, "_data") == 0 && !gfc_is_class_array_ref (expr, NULL)))
&& ref->next->next return false;
&& ref->next->next->type == REF_ARRAY
&& ref->next->next->u.ar.type != AR_ELEMENT) if (expr->symtree && expr->symtree->n.sym->ts.type == BT_CLASS)
ts = &expr->symtree->n.sym->ts;
else
ts = NULL;
for (ref = expr->ref; ref; ref = ref->next)
{ {
ts = &ref->u.c.component->ts; if (ref->type == REF_COMPONENT
class_ref = ref; && ref->u.c.component->ts.type == BT_CLASS
break; && ref->next && ref->next->type == REF_COMPONENT
&& strcmp (ref->next->u.c.component->name, "_data") == 0
&& ref->next->next
&& ref->next->next->type == REF_ARRAY
&& ref->next->next->u.ar.type != AR_ELEMENT)
{
ts = &ref->u.c.component->ts;
class_ref = ref;
break;
}
} }
}
if (ts == NULL) if (ts == NULL)
return false; return false;
}
if (class_ref == NULL && expr->symtree->n.sym->attr.function if (class_ref == NULL && expr && expr->symtree->n.sym->attr.function
&& expr->symtree->n.sym == expr->symtree->n.sym->result) && expr->symtree->n.sym == expr->symtree->n.sym->result)
{ {
gcc_assert (expr->symtree->n.sym->backend_decl == current_function_decl); gcc_assert (expr->symtree->n.sym->backend_decl == current_function_decl);
decl = gfc_get_fake_result_decl (expr->symtree->n.sym, 0); decl = gfc_get_fake_result_decl (expr->symtree->n.sym, 0);
} }
else if (gfc_is_alloc_class_array_function (expr)) else if (expr && gfc_is_alloc_class_array_function (expr))
{ {
size = NULL_TREE; size = NULL_TREE;
decl = NULL_TREE; decl = NULL_TREE;
...@@ -3105,7 +3113,8 @@ build_class_array_ref (gfc_se *se, tree base, tree index) ...@@ -3105,7 +3113,8 @@ build_class_array_ref (gfc_se *se, tree base, tree index)
} }
else if (class_ref == NULL) else if (class_ref == NULL)
{ {
decl = expr->symtree->n.sym->backend_decl; if (decl == NULL_TREE)
decl = expr->symtree->n.sym->backend_decl;
/* For class arrays the tree containing the class is stored in /* For class arrays the tree containing the class is stored in
GFC_DECL_SAVED_DESCRIPTOR of the sym's backend_decl. GFC_DECL_SAVED_DESCRIPTOR of the sym's backend_decl.
For all others it's sym's backend_decl directly. */ For all others it's sym's backend_decl directly. */
...@@ -3121,6 +3130,7 @@ build_class_array_ref (gfc_se *se, tree base, tree index) ...@@ -3121,6 +3130,7 @@ build_class_array_ref (gfc_se *se, tree base, tree index)
class_ref->next = NULL; class_ref->next = NULL;
gfc_init_se (&tmpse, NULL); gfc_init_se (&tmpse, NULL);
gfc_conv_expr (&tmpse, expr); gfc_conv_expr (&tmpse, expr);
gfc_add_block_to_block (&se->pre, &tmpse.pre);
decl = tmpse.expr; decl = tmpse.expr;
class_ref->next = ref; class_ref->next = ref;
} }
...@@ -7094,6 +7104,28 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr) ...@@ -7094,6 +7104,28 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr)
loop.from, loop.to, 0, loop.from, loop.to, 0,
GFC_ARRAY_UNKNOWN, false); GFC_ARRAY_UNKNOWN, false);
parm = gfc_create_var (parmtype, "parm"); parm = gfc_create_var (parmtype, "parm");
/* When expression is a class object, then add the class' handle to
the parm_decl. */
if (expr->ts.type == BT_CLASS && expr->expr_type == EXPR_VARIABLE)
{
gfc_expr *class_expr = gfc_find_and_cut_at_last_class_ref (expr);
gfc_se classse;
/* class_expr can be NULL, when no _class ref is in expr.
We must not fix this here with a gfc_fix_class_ref (). */
if (class_expr)
{
gfc_init_se (&classse, NULL);
gfc_conv_expr (&classse, class_expr);
gfc_free_expr (class_expr);
gcc_assert (classse.pre.head == NULL_TREE
&& classse.post.head == NULL_TREE);
gfc_allocate_lang_decl (parm);
GFC_DECL_SAVED_DESCRIPTOR (parm) = classse.expr;
}
}
} }
offset = gfc_index_zero_node; offset = gfc_index_zero_node;
...@@ -7255,6 +7287,13 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr) ...@@ -7255,6 +7287,13 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr)
: base; : base;
gfc_conv_descriptor_offset_set (&loop.pre, parm, tmp); gfc_conv_descriptor_offset_set (&loop.pre, parm, tmp);
} }
else if (IS_CLASS_ARRAY (expr) && !se->data_not_needed
&& (!rank_remap || se->use_offset)
&& GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)))
{
gfc_conv_descriptor_offset_set (&loop.pre, parm,
gfc_conv_descriptor_offset_get (desc));
}
else if (onebased && (!rank_remap || se->use_offset) else if (onebased && (!rank_remap || se->use_offset)
&& expr->symtree && expr->symtree
&& !(expr->symtree->n.sym && expr->symtree->n.sym->ts.type == BT_CLASS && !(expr->symtree->n.sym && expr->symtree->n.sym->ts.type == BT_CLASS
...@@ -7290,6 +7329,18 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr) ...@@ -7290,6 +7329,18 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr)
GFC_DECL_SAVED_DESCRIPTOR (expr->symtree->n.sym->backend_decl) GFC_DECL_SAVED_DESCRIPTOR (expr->symtree->n.sym->backend_decl)
: expr->symtree->n.sym->backend_decl; : expr->symtree->n.sym->backend_decl;
} }
else if (expr->expr_type == EXPR_ARRAY && VAR_P (desc)
&& IS_CLASS_ARRAY (expr))
{
tree vtype;
gfc_allocate_lang_decl (desc);
tmp = gfc_create_var (expr->ts.u.derived->backend_decl, "class");
GFC_DECL_SAVED_DESCRIPTOR (desc) = tmp;
vtype = gfc_class_vptr_get (tmp);
gfc_add_modify (&se->pre, vtype,
gfc_build_addr_expr (TREE_TYPE (vtype),
gfc_find_vtab (&expr->ts)->backend_decl));
}
if (!se->direct_byref || se->byref_noassign) if (!se->direct_byref || se->byref_noassign)
{ {
/* Get a pointer to the new descriptor. */ /* Get a pointer to the new descriptor. */
...@@ -8200,10 +8251,8 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl, ...@@ -8200,10 +8251,8 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
/* Allocatable CLASS components. */ /* Allocatable CLASS components. */
comp = fold_build3_loc (input_location, COMPONENT_REF, ctype, comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
decl, cdecl, NULL_TREE); decl, cdecl, NULL_TREE);
/* Add reference to '_data' component. */
tmp = CLASS_DATA (c)->backend_decl; comp = gfc_class_data_get (comp);
comp = fold_build3_loc (input_location, COMPONENT_REF,
TREE_TYPE (tmp), comp, tmp, NULL_TREE);
if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (comp))) if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (comp)))
gfc_conv_descriptor_data_set (&fnblock, comp, null_pointer_node); gfc_conv_descriptor_data_set (&fnblock, comp, null_pointer_node);
else else
...@@ -8541,6 +8590,14 @@ gfc_is_reallocatable_lhs (gfc_expr *expr) ...@@ -8541,6 +8590,14 @@ gfc_is_reallocatable_lhs (gfc_expr *expr)
if (!expr->ref) if (!expr->ref)
return false; return false;
/* An allocatable class variable with no reference. */
if (expr->symtree->n.sym->ts.type == BT_CLASS
&& CLASS_DATA (expr->symtree->n.sym)->attr.allocatable
&& expr->ref && expr->ref->type == REF_COMPONENT
&& strcmp (expr->ref->u.c.component->name, "_data") == 0
&& expr->ref->next == NULL)
return true;
/* An allocatable variable. */ /* An allocatable variable. */
if (expr->symtree->n.sym->attr.allocatable if (expr->symtree->n.sym->attr.allocatable
&& expr->ref && expr->ref
......
gcc/fortran/trans-stmt.h
...@@ -32,7 +32,6 @@ tree gfc_trans_assign (gfc_code *); ...@@ -32,7 +32,6 @@ tree gfc_trans_assign (gfc_code *);
tree gfc_trans_pointer_assign (gfc_code *); tree gfc_trans_pointer_assign (gfc_code *);
tree gfc_trans_init_assign (gfc_code *); tree gfc_trans_init_assign (gfc_code *);
tree gfc_trans_class_init_assign (gfc_code *); tree gfc_trans_class_init_assign (gfc_code *);
tree gfc_trans_class_assign (gfc_expr *, gfc_expr *, gfc_exec_op);
/* trans-stmt.c */ /* trans-stmt.c */
tree gfc_trans_cycle (gfc_code *); tree gfc_trans_cycle (gfc_code *);
......
gcc/fortran/trans.c
...@@ -1704,10 +1704,7 @@ trans_code (gfc_code * code, tree cond) ...@@ -1704,10 +1704,7 @@ trans_code (gfc_code * code, tree cond)
break; break;
case EXEC_ASSIGN: case EXEC_ASSIGN:
if (code->expr1->ts.type == BT_CLASS) res = gfc_trans_assign (code);
res = gfc_trans_class_assign (code->expr1, code->expr2, code->op);
else
res = gfc_trans_assign (code);
break; break;
case EXEC_LABEL_ASSIGN: case EXEC_LABEL_ASSIGN:
...@@ -1715,16 +1712,7 @@ trans_code (gfc_code * code, tree cond) ...@@ -1715,16 +1712,7 @@ trans_code (gfc_code * code, tree cond)
break; break;
case EXEC_POINTER_ASSIGN: case EXEC_POINTER_ASSIGN:
if (code->expr1->ts.type == BT_CLASS) res = gfc_trans_pointer_assign (code);
res = gfc_trans_class_assign (code->expr1, code->expr2, code->op);
else if (UNLIMITED_POLY (code->expr2)
&& code->expr1->ts.type == BT_DERIVED
&& (code->expr1->ts.u.derived->attr.sequence
|| code->expr1->ts.u.derived->attr.is_bind_c))
/* F2003: C717 */
res = gfc_trans_class_assign (code->expr1, code->expr2, code->op);
else
res = gfc_trans_pointer_assign (code);
break; break;
case EXEC_INIT_ASSIGN: case EXEC_INIT_ASSIGN:
......
gcc/fortran/trans.h
...@@ -699,7 +699,8 @@ tree gfc_call_realloc (stmtblock_t *, tree, tree); ...@@ -699,7 +699,8 @@ tree gfc_call_realloc (stmtblock_t *, tree, tree);
tree gfc_trans_structure_assign (tree, gfc_expr *, bool); tree gfc_trans_structure_assign (tree, gfc_expr *, bool);
/* Generate code for an assignment, includes scalarization. */ /* Generate code for an assignment, includes scalarization. */
tree gfc_trans_assignment (gfc_expr *, gfc_expr *, bool, bool); tree gfc_trans_assignment (gfc_expr *, gfc_expr *, bool, bool, bool p = false,
bool a = true);
/* Generate code for a pointer assignment. */ /* Generate code for a pointer assignment. */
tree gfc_trans_pointer_assignment (gfc_expr *, gfc_expr *); tree gfc_trans_pointer_assignment (gfc_expr *, gfc_expr *);
......
gcc/testsuite/ChangeLog
2016-10-22 Andre Vehreschild <vehre@gcc.gnu.org>
Forgot to add on original commit.
* gfortran.dg/coarray_alloc_comp_2.f08: New test.
2016-10-22 Andre Vehreschild <vehre@gcc.gnu.org>
PR fortran/43366
PR fortran/57117
PR fortran/61337
* gfortran.dg/alloc_comp_class_5.f03: New test.
* gfortran.dg/class_allocate_21.f90: New test.
* gfortran.dg/class_allocate_22.f90: New test.
* gfortran.dg/realloc_on_assign_27.f08: New test.
2016-10-21 Jeff Law <law@redhat.com> 2016-10-21 Jeff Law <law@redhat.com>
* PR tree-optimization/71947 * PR tree-optimization/71947
......
gcc/testsuite/gfortran.dg/alloc_comp_class_5.f03 0 → 100644
! { dg-do run }
!
! Contributed by Vladimir Fuka
! Check that pr61337 is fixed.
module array_list
type container
class(*), allocatable :: items(:)
end type
contains
subroutine add_item(a, e)
type(container),allocatable,intent(inout) :: a(:)
class(*),intent(in) :: e(:)
type(container),allocatable :: tmp(:)
if (.not.allocated(a)) then
allocate(a(1))
allocate(a(1)%items(size(e)), source = e)
else
call move_alloc(a,tmp)
allocate(a(size(tmp)+1))
a(1:size(tmp)) = tmp
allocate(a(size(tmp)+1)%items(size(e)), source=e)
end if
end subroutine
end module
program test_pr61337
use array_list
type(container), allocatable :: a_list(:)
integer(kind = 8) :: i
call add_item(a_list, [1, 2])
call add_item(a_list, [3.0_8, 4.0_8])
call add_item(a_list, [.true., .false.])
if (size(a_list) /= 3) call abort()
do i = 1, size(a_list)
call checkarr(a_list(i))
end do
deallocate(a_list)
contains
subroutine checkarr(c)
type(container) :: c
if (allocated(c%items)) then
select type (x=>c%items)
type is (integer)
if (any(x /= [1, 2])) call abort()
type is (real(kind=8))
if (any(x /= [3.0_8, 4.0_8])) call abort()
type is (logical)
if (any(x .neqv. [.true., .false.])) call abort()
class default
call abort()
end select
else
call abort()
end if
end subroutine
end
gcc/testsuite/gfortran.dg/class_allocate_21.f90 0 → 100644
! { dg-do run }
!
! Testcase for pr57117
implicit none
type :: ti
integer :: i
end type
class(ti), allocatable :: x(:,:), z(:)
integer :: i
allocate(x(3,3))
x%i = reshape([( i, i = 1, 9 )], [3, 3])
allocate(z(9), source=reshape(x, (/ 9 /)))
if (any( z%i /= [( i, i = 1, 9 )])) call abort()
deallocate (x, z)
end
gcc/testsuite/gfortran.dg/class_allocate_22.f90 0 → 100644
! { dg-do run }
!
! Check pr57117 is fixed.
program pr57117
implicit none
type :: ti
integer :: i
end type
class(ti), allocatable :: x(:,:), y(:,:)
integer :: i
allocate(x(2,6))
select type (x)
class is (ti)
x%i = reshape([(i,i=1, 12)],[2,6])
end select
allocate(y, source=transpose(x))
if (any( ubound(y) /= [6,2])) call abort()
if (any(reshape(y(:,:)%i, [12]) /= [ 1,3,5,7,9,11, 2,4,6,8,10,12])) call abort()
deallocate (x,y)
end
gcc/testsuite/gfortran.dg/coarray_alloc_comp_2.f08 0 → 100644
! { dg-do run }
! { dg-options "-fcoarray=lib -lcaf_single" }
! Contributed by Damian Rouson
! Check the new _caf_send_by_ref()-routine.
program main
implicit none
type :: mytype
integer :: i
integer, allocatable :: indices(:)
real, dimension(2,5,3) :: volume
integer, allocatable :: scalar
integer :: j
integer, allocatable :: matrix(:,:)
real, allocatable :: dynvol(:,:,:)
end type
type arrtype
type(mytype), allocatable :: vec(:)
type(mytype), allocatable :: mat(:,:)
end type arrtype
type(mytype), save :: object[*]
type(arrtype), save :: bar[*]
integer :: i,j,me,neighbor
integer :: idx(5)
real, allocatable :: volume(:,:,:), vol2(:,:,:)
real :: vol_static(2,5,3)
idx = (/ 1,2,1,7,5 /)
me=this_image()
neighbor = merge(1,me+1,me==num_images())
object[neighbor]%indices=[(i,i=1,5)]
object[neighbor]%i = 37
object[neighbor]%scalar = 42
vol_static = reshape([(i, i=1, 2*5*3)], [2, 5, 3])
object[neighbor]%volume = vol_static
object[neighbor]%matrix = reshape([(i, i=1, 70)], [10, 7])
object[neighbor]%dynvol = vol_static
sync all
if (object%scalar /= 42) call abort()
if (any( object%indices /= [1,2,3,4,5] )) call abort()
if (any( object%matrix /= reshape([(i, i=1, 70)], [10, 7]))) call abort()
if (any( object%volume /= vol_static)) call abort()
if (any( object%dynvol /= vol_static)) call abort()
vol2 = vol_static
vol2(:, ::2, :) = 42
object[neighbor]%volume(:, ::2, :) = 42
object[neighbor]%dynvol(:, ::2, :) = 42
if (any( object%volume /= vol2)) call abort()
if (any( object%dynvol /= vol2)) call abort()
allocate(bar%vec(-2:2))
bar[neighbor]%vec(1)%volume = vol_static
if (any(bar%vec(1)%volume /= vol_static)) call abort()
i = 15
bar[neighbor]%vec(1)%scalar = i
if (.not. allocated(bar%vec(1)%scalar)) call abort()
if (bar%vec(1)%scalar /= 15) call abort()
bar[neighbor]%vec(0)%scalar = 27
if (.not. allocated(bar%vec(0)%scalar)) call abort()
if (bar%vec(0)%scalar /= 27) call abort()
bar[neighbor]%vec(1)%indices = [ 3, 4, 15 ]
allocate(bar%vec(2)%indices(5))
bar[neighbor]%vec(2)%indices = 89
if (.not. allocated(bar%vec(1)%indices)) call abort()
if (allocated(bar%vec(-2)%indices)) call abort()
if (allocated(bar%vec(-1)%indices)) call abort()
if (allocated(bar%vec( 0)%indices)) call abort()
if (.not. allocated(bar%vec( 2)%indices)) call abort()
if (any(bar%vec(2)%indices /= 89)) call abort()
if (any (bar%vec(1)%indices /= [ 3,4,15])) call abort()
end program
gcc/testsuite/gfortran.dg/realloc_on_assign_27.f08 0 → 100644
! { dg-do run }
type :: t
integer :: i
end type
type, extends(t) :: r
real :: r
end type
class(t), allocatable :: x
type(r) :: y = r (3, 42)
x = y
if (x%i /= 3) call abort()
select type(x)
class is (r)
if (x%r /= 42.0) call abort()
class default
call abort()
end select
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