Commit 1792349b by Andre Vehreschild Committed by Andre Vehreschild

re PR fortran/44672 ([F08] ALLOCATE with SOURCE and no array-spec)

gcc/testsuite/ChangeLog:

2015-06-15  Andre Vehreschild  <vehre@gmx.de>

	PR fortran/44672
	PR fortran/45440
	PR fortran/57307
	* gfortran.dg/allocate_with_source_3.f90: Removed check for
	unimplemented error.
	* gfortran.dg/allocate_with_source_7.f08: New test.
	* gfortran.dg/allocate_with_source_8.f08: New test.

gcc/fortran/ChangeLog:

2015-06-15  Andre Vehreschild  <vehre@gmx.de>

	PR fortran/44672
	PR fortran/45440
	PR fortran/57307
	* gfortran.h: Extend gfc_code.ext.alloc to carry a
	flag indicating that the array specification has to be
	taken from expr3.
	* resolve.c (resolve_allocate_expr): Add F2008 notify
	and flag indicating source driven array spec.
	(resolve_allocate_deallocate): Check for source driven
	array spec, when array to allocate has no explicit
	array spec.
	* trans-array.c (gfc_array_init_size): Get lower and
	upper bound from a tree array descriptor, except when
	the source expression is an array-constructor which is
	fixed to be one-based.
	(retrieve_last_ref): Extracted from gfc_array_allocate().
	(gfc_array_allocate): Enable allocate(array, source= 
	array_expression) as specified by F2008:C633.
	(gfc_conv_expr_descriptor): Add class tree expression
	into the saved descriptor for class arrays.
	* trans-array.h: Add temporary array descriptor to
	gfc_array_allocate ().
	* trans-expr.c (gfc_conv_procedure_call): Special handling
	for _copy() routine translation, that comes without an
	interface. Third and fourth argument are now passed by value.
	* trans-stmt.c (gfc_trans_allocate): Get expr3 array
	descriptor for temporary arrays to allow allocate(array,
	source = array_expression) for array without array
	specification.

From-SVN: r224477
parent cf0c27ef
2015-06-15 Andre Vehreschild <vehre@gmx.de>
PR fortran/44672
PR fortran/45440
PR fortran/57307
* gfortran.h: Extend gfc_code.ext.alloc to carry a
flag indicating that the array specification has to be
taken from expr3.
* resolve.c (resolve_allocate_expr): Add F2008 notify
and flag indicating source driven array spec.
(resolve_allocate_deallocate): Check for source driven
array spec, when array to allocate has no explicit
array spec.
* trans-array.c (gfc_array_init_size): Get lower and
upper bound from a tree array descriptor, except when
the source expression is an array-constructor which is
fixed to be one-based.
(retrieve_last_ref): Extracted from gfc_array_allocate().
(gfc_array_allocate): Enable allocate(array, source=
array_expression) as specified by F2008:C633.
(gfc_conv_expr_descriptor): Add class tree expression
into the saved descriptor for class arrays.
* trans-array.h: Add temporary array descriptor to
gfc_array_allocate ().
* trans-expr.c (gfc_conv_procedure_call): Special handling
for _copy() routine translation, that comes without an
interface. Third and fourth argument are now passed by value.
* trans-stmt.c (gfc_trans_allocate): Get expr3 array
descriptor for temporary arrays to allow allocate(array,
source = array_expression) for array without array
specification.
2015-06-14 Thomas Koenig <tkoenig@gcc.gnu.org> 2015-06-14 Thomas Koenig <tkoenig@gcc.gnu.org>
* intrinsic.texi: Change \leq to < in descrition of imaginary * intrinsic.texi: Change \leq to < in descrition of imaginary
......
...@@ -2395,6 +2395,9 @@ typedef struct gfc_code ...@@ -2395,6 +2395,9 @@ typedef struct gfc_code
{ {
gfc_typespec ts; gfc_typespec ts;
gfc_alloc *list; gfc_alloc *list;
/* Take the array specification from expr3 to allocate arrays
without an explicit array specification. */
unsigned arr_spec_from_expr3:1;
} }
alloc; alloc;
......
...@@ -6805,7 +6805,7 @@ conformable_arrays (gfc_expr *e1, gfc_expr *e2) ...@@ -6805,7 +6805,7 @@ conformable_arrays (gfc_expr *e1, gfc_expr *e2)
have a trailing array reference that gives the size of the array. */ have a trailing array reference that gives the size of the array. */
static bool static bool
resolve_allocate_expr (gfc_expr *e, gfc_code *code) resolve_allocate_expr (gfc_expr *e, gfc_code *code, bool *array_alloc_wo_spec)
{ {
int i, pointer, allocatable, dimension, is_abstract; int i, pointer, allocatable, dimension, is_abstract;
int codimension; int codimension;
...@@ -7104,13 +7104,24 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code) ...@@ -7104,13 +7104,24 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code)
if (!ref2 || ref2->type != REF_ARRAY || ref2->u.ar.type == AR_FULL if (!ref2 || ref2->type != REF_ARRAY || ref2->u.ar.type == AR_FULL
|| (dimension && ref2->u.ar.dimen == 0)) || (dimension && ref2->u.ar.dimen == 0))
{ {
gfc_error ("Array specification required in ALLOCATE statement " /* F08:C633. */
"at %L", &e->where); if (code->expr3)
goto failure; {
if (!gfc_notify_std (GFC_STD_F2008, "Array specification required "
"in ALLOCATE statement at %L", &e->where))
goto failure;
*array_alloc_wo_spec = true;
}
else
{
gfc_error ("Array specification required in ALLOCATE statement "
"at %L", &e->where);
goto failure;
}
} }
/* Make sure that the array section reference makes sense in the /* Make sure that the array section reference makes sense in the
context of an ALLOCATE specification. */ context of an ALLOCATE specification. */
ar = &ref2->u.ar; ar = &ref2->u.ar;
...@@ -7125,7 +7136,7 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code) ...@@ -7125,7 +7136,7 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code)
for (i = 0; i < ar->dimen; i++) for (i = 0; i < ar->dimen; i++)
{ {
if (ref2->u.ar.type == AR_ELEMENT) if (ar->type == AR_ELEMENT || ar->type == AR_FULL)
goto check_symbols; goto check_symbols;
switch (ar->dimen_type[i]) switch (ar->dimen_type[i])
...@@ -7202,6 +7213,7 @@ failure: ...@@ -7202,6 +7213,7 @@ failure:
return false; return false;
} }
static void static void
resolve_allocate_deallocate (gfc_code *code, const char *fcn) resolve_allocate_deallocate (gfc_code *code, const char *fcn)
{ {
...@@ -7376,8 +7388,16 @@ resolve_allocate_deallocate (gfc_code *code, const char *fcn) ...@@ -7376,8 +7388,16 @@ resolve_allocate_deallocate (gfc_code *code, const char *fcn)
if (strcmp (fcn, "ALLOCATE") == 0) if (strcmp (fcn, "ALLOCATE") == 0)
{ {
bool arr_alloc_wo_spec = false;
for (a = code->ext.alloc.list; a; a = a->next) for (a = code->ext.alloc.list; a; a = a->next)
resolve_allocate_expr (a->expr, code); resolve_allocate_expr (a->expr, code, &arr_alloc_wo_spec);
if (arr_alloc_wo_spec && code->expr3)
{
/* Mark the allocate to have to take the array specification
from the expr3. */
code->ext.alloc.arr_spec_from_expr3 = 1;
}
} }
else else
{ {
......
...@@ -4998,7 +4998,8 @@ static tree ...@@ -4998,7 +4998,8 @@ static tree
gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset, gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset,
gfc_expr ** lower, gfc_expr ** upper, stmtblock_t * pblock, gfc_expr ** lower, gfc_expr ** upper, stmtblock_t * pblock,
stmtblock_t * descriptor_block, tree * overflow, stmtblock_t * descriptor_block, tree * overflow,
tree expr3_elem_size, tree *nelems, gfc_expr *expr3) tree expr3_elem_size, tree *nelems, gfc_expr *expr3,
tree expr3_desc, bool e3_is_array_constr)
{ {
tree type; tree type;
tree tmp; tree tmp;
...@@ -5041,7 +5042,18 @@ gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset, ...@@ -5041,7 +5042,18 @@ gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset,
/* Set lower bound. */ /* Set lower bound. */
gfc_init_se (&se, NULL); gfc_init_se (&se, NULL);
if (lower == NULL) if (expr3_desc != NULL_TREE)
{
if (e3_is_array_constr)
/* The lbound of a constant array [] starts at zero, but when
allocating it, the standard expects the array to start at
one. */
se.expr = gfc_index_one_node;
else
se.expr = gfc_conv_descriptor_lbound_get (expr3_desc,
gfc_rank_cst[n]);
}
else if (lower == NULL)
se.expr = gfc_index_one_node; se.expr = gfc_index_one_node;
else else
{ {
...@@ -5069,10 +5081,35 @@ gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset, ...@@ -5069,10 +5081,35 @@ gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset,
/* Set upper bound. */ /* Set upper bound. */
gfc_init_se (&se, NULL); gfc_init_se (&se, NULL);
gcc_assert (ubound); if (expr3_desc != NULL_TREE)
gfc_conv_expr_type (&se, ubound, gfc_array_index_type); {
gfc_add_block_to_block (pblock, &se.pre); if (e3_is_array_constr)
{
/* The lbound of a constant array [] starts at zero, but when
allocating it, the standard expects the array to start at
one. Therefore fix the upper bound to be
(desc.ubound - desc.lbound)+ 1. */
tmp = fold_build2_loc (input_location, MINUS_EXPR,
gfc_array_index_type,
gfc_conv_descriptor_ubound_get (
expr3_desc, gfc_rank_cst[n]),
gfc_conv_descriptor_lbound_get (
expr3_desc, gfc_rank_cst[n]));
tmp = fold_build2_loc (input_location, PLUS_EXPR,
gfc_array_index_type, tmp,
gfc_index_one_node);
se.expr = gfc_evaluate_now (tmp, pblock);
}
else
se.expr = gfc_conv_descriptor_ubound_get (expr3_desc,
gfc_rank_cst[n]);
}
else
{
gcc_assert (ubound);
gfc_conv_expr_type (&se, ubound, gfc_array_index_type);
gfc_add_block_to_block (pblock, &se.pre);
}
gfc_conv_descriptor_ubound_set (descriptor_block, descriptor, gfc_conv_descriptor_ubound_set (descriptor_block, descriptor,
gfc_rank_cst[n], se.expr); gfc_rank_cst[n], se.expr);
conv_ubound = se.expr; conv_ubound = se.expr;
...@@ -5242,6 +5279,33 @@ gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset, ...@@ -5242,6 +5279,33 @@ gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset,
} }
/* Retrieve the last ref from the chain. This routine is specific to
gfc_array_allocate ()'s needs. */
bool
retrieve_last_ref (gfc_ref **ref_in, gfc_ref **prev_ref_in)
{
gfc_ref *ref, *prev_ref;
ref = *ref_in;
/* Prevent warnings for uninitialized variables. */
prev_ref = *prev_ref_in;
while (ref && ref->next != NULL)
{
gcc_assert (ref->type != REF_ARRAY || ref->u.ar.type == AR_ELEMENT
|| (ref->u.ar.dimen == 0 && ref->u.ar.codimen > 0));
prev_ref = ref;
ref = ref->next;
}
if (ref == NULL || ref->type != REF_ARRAY)
return false;
*ref_in = ref;
*prev_ref_in = prev_ref;
return true;
}
/* Initializes the descriptor and generates a call to _gfor_allocate. Does /* Initializes the descriptor and generates a call to _gfor_allocate. Does
the work for an ALLOCATE statement. */ the work for an ALLOCATE statement. */
/*GCC ARRAYS*/ /*GCC ARRAYS*/
...@@ -5249,7 +5313,8 @@ gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset, ...@@ -5249,7 +5313,8 @@ gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset,
bool bool
gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg, gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg,
tree errlen, tree label_finish, tree expr3_elem_size, tree errlen, tree label_finish, tree expr3_elem_size,
tree *nelems, gfc_expr *expr3) tree *nelems, gfc_expr *expr3, tree e3_arr_desc,
bool e3_is_array_constr)
{ {
tree tmp; tree tmp;
tree pointer; tree pointer;
...@@ -5267,21 +5332,24 @@ gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg, ...@@ -5267,21 +5332,24 @@ gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg,
gfc_expr **lower; gfc_expr **lower;
gfc_expr **upper; gfc_expr **upper;
gfc_ref *ref, *prev_ref = NULL; gfc_ref *ref, *prev_ref = NULL;
bool allocatable, coarray, dimension; bool allocatable, coarray, dimension, alloc_w_e3_arr_spec = false;
ref = expr->ref; ref = expr->ref;
/* Find the last reference in the chain. */ /* Find the last reference in the chain. */
while (ref && ref->next != NULL) if (!retrieve_last_ref (&ref, &prev_ref))
return false;
if (ref->u.ar.type == AR_FULL && expr3 != NULL)
{ {
gcc_assert (ref->type != REF_ARRAY || ref->u.ar.type == AR_ELEMENT /* F08:C633: Array shape from expr3. */
|| (ref->u.ar.dimen == 0 && ref->u.ar.codimen > 0)); ref = expr3->ref;
prev_ref = ref;
ref = ref->next;
}
if (ref == NULL || ref->type != REF_ARRAY) /* Find the last reference in the chain. */
return false; if (!retrieve_last_ref (&ref, &prev_ref))
return false;
alloc_w_e3_arr_spec = true;
}
if (!prev_ref) if (!prev_ref)
{ {
...@@ -5317,7 +5385,8 @@ gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg, ...@@ -5317,7 +5385,8 @@ gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg,
break; break;
case AR_FULL: case AR_FULL:
gcc_assert (ref->u.ar.as->type == AS_EXPLICIT); gcc_assert (ref->u.ar.as->type == AS_EXPLICIT
|| alloc_w_e3_arr_spec);
lower = ref->u.ar.as->lower; lower = ref->u.ar.as->lower;
upper = ref->u.ar.as->upper; upper = ref->u.ar.as->upper;
...@@ -5331,10 +5400,12 @@ gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg, ...@@ -5331,10 +5400,12 @@ gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg,
overflow = integer_zero_node; overflow = integer_zero_node;
gfc_init_block (&set_descriptor_block); gfc_init_block (&set_descriptor_block);
size = gfc_array_init_size (se->expr, ref->u.ar.as->rank, size = gfc_array_init_size (se->expr, alloc_w_e3_arr_spec ? expr->rank
: ref->u.ar.as->rank,
ref->u.ar.as->corank, &offset, lower, upper, ref->u.ar.as->corank, &offset, lower, upper,
&se->pre, &set_descriptor_block, &overflow, &se->pre, &set_descriptor_block, &overflow,
expr3_elem_size, nelems, expr3); expr3_elem_size, nelems, expr3, e3_arr_desc,
e3_is_array_constr);
if (dimension) if (dimension)
{ {
...@@ -7073,6 +7144,16 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr) ...@@ -7073,6 +7144,16 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr)
desc = parm; desc = parm;
} }
/* For class arrays add the class tree into the saved descriptor to
enable getting of _vptr and the like. */
if (expr->expr_type == EXPR_VARIABLE && VAR_P (desc)
&& IS_CLASS_ARRAY (expr->symtree->n.sym)
&& DECL_LANG_SPECIFIC (expr->symtree->n.sym->backend_decl))
{
gfc_allocate_lang_decl (desc);
GFC_DECL_SAVED_DESCRIPTOR (desc) =
GFC_DECL_SAVED_DESCRIPTOR (expr->symtree->n.sym->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. */
......
...@@ -24,7 +24,7 @@ tree gfc_array_deallocate (tree, tree, tree, tree, tree, gfc_expr*); ...@@ -24,7 +24,7 @@ tree gfc_array_deallocate (tree, tree, tree, tree, tree, gfc_expr*);
/* Generate code to initialize and allocate an array. Statements are added to /* Generate code to initialize and allocate an array. Statements are added to
se, which should contain an expression for the array descriptor. */ se, which should contain an expression for the array descriptor. */
bool gfc_array_allocate (gfc_se *, gfc_expr *, tree, tree, tree, tree, bool gfc_array_allocate (gfc_se *, gfc_expr *, tree, tree, tree, tree,
tree, tree *, gfc_expr *); tree, tree *, gfc_expr *, tree, bool);
/* Allow the bounds of a loop to be set from a callee's array spec. */ /* Allow the bounds of a loop to be set from a callee's array spec. */
void gfc_set_loop_bounds_from_array_spec (gfc_interface_mapping *, void gfc_set_loop_bounds_from_array_spec (gfc_interface_mapping *,
......
...@@ -4561,6 +4561,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, ...@@ -4561,6 +4561,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
int has_alternate_specifier = 0; int has_alternate_specifier = 0;
bool need_interface_mapping; bool need_interface_mapping;
bool callee_alloc; bool callee_alloc;
bool ulim_copy;
gfc_typespec ts; gfc_typespec ts;
gfc_charlen cl; gfc_charlen cl;
gfc_expr *e; gfc_expr *e;
...@@ -4569,6 +4570,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, ...@@ -4569,6 +4570,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
enum {MISSING = 0, ELEMENTAL, SCALAR, SCALAR_POINTER, ARRAY}; enum {MISSING = 0, ELEMENTAL, SCALAR, SCALAR_POINTER, ARRAY};
gfc_component *comp = NULL; gfc_component *comp = NULL;
int arglen; int arglen;
unsigned int argc;
arglist = NULL; arglist = NULL;
retargs = NULL; retargs = NULL;
...@@ -4624,10 +4626,16 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, ...@@ -4624,10 +4626,16 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
} }
base_object = NULL_TREE; base_object = NULL_TREE;
/* For _vprt->_copy () routines no formal symbol is present. Nevertheless
is the third and fourth argument to such a function call a value
denoting the number of elements to copy (i.e., most of the time the
length of a deferred length string). */
ulim_copy = formal == NULL && UNLIMITED_POLY (sym)
&& strcmp ("_copy", comp->name) == 0;
/* Evaluate the arguments. */ /* Evaluate the arguments. */
for (arg = args; arg != NULL; for (arg = args, argc = 0; arg != NULL;
arg = arg->next, formal = formal ? formal->next : NULL) arg = arg->next, formal = formal ? formal->next : NULL, ++argc)
{ {
e = arg->expr; e = arg->expr;
fsym = formal ? formal->sym : NULL; fsym = formal ? formal->sym : NULL;
...@@ -4729,7 +4737,14 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, ...@@ -4729,7 +4737,14 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
gfc_init_se (&parmse, se); gfc_init_se (&parmse, se);
parm_kind = ELEMENTAL; parm_kind = ELEMENTAL;
if (fsym && fsym->attr.value) /* When no fsym is present, ulim_copy is set and this is a third or
fourth argument, use call-by-value instead of by reference to
hand the length properties to the copy routine (i.e., most of the
time this will be a call to a __copy_character_* routine where the
third and fourth arguments are the lengths of a deferred length
char array). */
if ((fsym && fsym->attr.value)
|| (ulim_copy && (argc == 2 || argc == 3)))
gfc_conv_expr (&parmse, e); gfc_conv_expr (&parmse, e);
else else
gfc_conv_expr_reference (&parmse, e); gfc_conv_expr_reference (&parmse, e);
...@@ -5322,7 +5337,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, ...@@ -5322,7 +5337,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
if (e && (e->ts.type == BT_DERIVED || e->ts.type == BT_CLASS) if (e && (e->ts.type == BT_DERIVED || e->ts.type == BT_CLASS)
&& e->ts.u.derived->attr.alloc_comp && e->ts.u.derived->attr.alloc_comp
&& !(e->symtree && e->symtree->n.sym->attr.pointer) && !(e->symtree && e->symtree->n.sym->attr.pointer)
&& (e->expr_type != EXPR_VARIABLE && !e->rank)) && e->expr_type != EXPR_VARIABLE && !e->rank)
{ {
int parm_rank; int parm_rank;
tmp = build_fold_indirect_ref_loc (input_location, tmp = build_fold_indirect_ref_loc (input_location,
......
2015-06-15 Andre Vehreschild <vehre@gmx.de>
PR fortran/44672
PR fortran/45440
PR fortran/57307
* gfortran.dg/allocate_with_source_3.f90: Removed check for
unimplemented error.
* gfortran.dg/allocate_with_source_7.f08: New test.
* gfortran.dg/allocate_with_source_8.f08: New test.
2015-06-13 Patrick Palka <ppalka@gcc.gnu.org> 2015-06-13 Patrick Palka <ppalka@gcc.gnu.org>
PR c++/65168 PR c++/65168
......
...@@ -21,7 +21,7 @@ program assumed_shape_01 ...@@ -21,7 +21,7 @@ program assumed_shape_01
type(cstruct), pointer :: u(:) type(cstruct), pointer :: u(:)
! The following is VALID Fortran 2008 but NOT YET supported ! The following is VALID Fortran 2008 but NOT YET supported
allocate(u, source=[cstruct( 4, [1.1,2.2] ) ]) ! { dg-error "Array specification required in ALLOCATE statement" } allocate(u, source=[cstruct( 4, [1.1,2.2] ) ])
call psub(t, u) call psub(t, u)
deallocate (u) deallocate (u)
......
! { dg-do run }
!
! Check that allocate with source for arrays without array-spec
! works.
! PR fortran/44672
! Contributed by Tobias Burnus <burnus@gcc.gnu.org>
! Antony Lewis <antony@cosmologist.info>
! Andre Vehreschild <vehre@gcc.gnu.org>
!
program allocate_with_source_6
type P
class(*), allocatable :: X(:,:)
end type
type t
end type t
type(t), allocatable :: a(:), b, c(:)
integer :: num_params_used = 6
integer, allocatable :: m(:)
allocate(b,c(5))
allocate(a(5), source=b)
deallocate(a)
allocate(a, source=c)
allocate(m, source=[(I, I=1, num_params_used)])
if (any(m /= [(I, I=1, num_params_used)])) call abort()
deallocate(a,b,m)
call testArrays()
contains
subroutine testArrays()
type L
class(*), allocatable :: v(:)
end type
Type(P) Y
type(L) o
real arr(3,5)
real, allocatable :: v(:)
arr = 5
allocate(Y%X, source=arr)
select type (R => Y%X)
type is (real)
if (any(reshape(R, [15]) /= [5,5,5,5,5, 5,5,5,5,5, 5,5,5,5,5])) &
call abort()
class default
call abort()
end select
deallocate(Y%X)
allocate(Y%X, source=arr(2:3,3:4))
select type (R => Y%X)
type is (real)
if (any(reshape(R, [4]) /= [5,5,5,5])) &
call abort()
class default
call abort()
end select
deallocate(Y%X)
allocate(o%v, source=arr(2,3:4))
select type (R => o%v)
type is (real)
if (any(R /= [5,5])) &
call abort()
class default
call abort()
end select
deallocate(o%v)
allocate(v, source=arr(2,1:5))
if (any(v /= [5,5,5,5,5])) call abort()
deallocate(v)
end subroutine testArrays
end
! { dg-do run }
!
! Contributed by Reinhold Bader
!
program assumed_shape_01
implicit none
type :: cstruct
integer :: i
real :: r(2)
end type cstruct
type(cstruct), pointer :: u(:)
integer, allocatable :: iv(:), iv2(:)
integer, allocatable :: im(:,:)
integer, parameter :: cim(2,3) = reshape([1,2,3, 2,3,4], [2,3])
integer :: i
integer, parameter :: lcim(2,10) = reshape([(i, i=1,10),(i,i=1,10)], [2,10])
allocate(iv, source= [ 1, 2, 3, 4])
if (any(iv /= [ 1, 2, 3, 4])) call abort()
deallocate(iv)
allocate(iv, source=(/(i, i=1,10)/))
if (any(iv /= (/(i, i=1,10)/))) call abort()
! Now 2D
allocate(im, source= cim)
if (any(im /= cim)) call abort()
deallocate(im)
allocate(im, source= reshape([iv, iv], [2, size(iv, 1)]))
if (any(im /= lcim)) call abort()
deallocate(im)
deallocate(iv)
allocate(u, source=[cstruct( 4, [1.1,2.2] )] )
if (any(u(:)%i /= 4) .or. any(abs(u(1)%r(:) - [1.1,2.2]) > 1E-6)) call abort()
deallocate (u)
allocate(iv, source= arrval())
if (any(iv /= [ 1, 2, 4, 5, 6])) call abort()
! Check simple array assign
allocate(iv2, source=iv)
if (any(iv2 /= [ 1, 2, 4, 5, 6])) call abort()
deallocate(iv, iv2)
! Now check for mold=
allocate(iv, mold= [ 1, 2, 3, 4])
if (any(shape(iv) /= [4])) call abort()
deallocate(iv)
allocate(iv, mold=(/(i, i=1,10)/))
if (any(shape(iv) /= [10])) call abort()
! Now 2D
allocate(im, mold= cim)
if (any(shape(im) /= shape(cim))) call abort()
deallocate(im)
allocate(im, mold= reshape([iv, iv], [2, size(iv, 1)]))
if (any(shape(im) /= shape(lcim))) call abort()
deallocate(im)
deallocate(iv)
allocate(u, mold=[cstruct( 4, [1.1,2.2] )] )
if (any(shape(u(1)%r(:)) /= 2)) call abort()
deallocate (u)
allocate(iv, mold= arrval())
if (any(shape(iv) /= [5])) call abort()
! Check simple array assign
allocate(iv2, mold=iv)
if (any(shape(iv2) /= [5])) call abort()
deallocate(iv, iv2)
call addData([4, 5])
call addData(["foo", "bar"])
contains
function arrval()
integer, dimension(5) :: arrval
arrval = [ 1, 2, 4, 5, 6]
end function
subroutine addData(P)
class(*), intent(in) :: P(:)
class(*), allocatable :: cP(:)
allocate (cP, source= P)
select type (cP)
type is (integer)
if (any(cP /= [4,5])) call abort()
type is (character(*))
if (len(cP) /= 3) call abort()
if (any(cP /= ["foo", "bar"])) call abort()
class default
call abort()
end select
deallocate (cP)
allocate (cP, mold= P)
select type (cP)
type is (integer)
if (any(size(cP) /= [2])) call abort()
type is (character(*))
if (len(cP) /= 3) call abort()
if (any(size(cP) /= [2])) call abort()
class default
call abort()
end select
deallocate (cP)
end subroutine
end program assumed_shape_01
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